diff options
403 files changed, 17014 insertions, 7278 deletions
diff --git a/.gitignore b/.gitignore index 5b4ffa77b..6624f901a 100644 --- a/.gitignore +++ b/.gitignore @@ -153,3 +153,4 @@ ide/index_urls.txt dev/ocamldoc/html/ dev/ocamldoc/coq.* dev/ocamldoc/ocamldoc.sty +dev/myinclude @@ -1,6 +1,38 @@ Changes from V8.4 ================= +Logic + +- Primitive projections for records allow for a compact representation of +projections, without parameters and avoid the behavior of defined +projections that can unfold to a case expression. To turn the use of +native projections on, use [Set Primitive Projections]. Record, Class +and Structure types defined while this option is set will be defined +with primitive projections instead of the usual encoding as a case +expression. For compatibility, when p is a primitive projection, @p can +be used to refer to the projection with explicit parameters, i.e. [@p] +is definitionaly equal to [λ params r. r.(p)]. Records with primitive +projections have eta-conversion, the canonical form being +[mkR pars (p1 t) ... (pn t)]. + + With native projections, the parsing of projection applications changes: +- r.(p) and (p r) elaborate to native projection application, and the + parameters cannot be mentionned. The following arguments are + parsed according to the remaining implicits declared for the projection + (i.e. the implicits after the record type argument). In dot notation, + the record type argument is considered explicit no matter what its + implicit status is. +- r.(@p params) and @p args are parsed as regular applications of the projection + with explicit parameters. +- [simpl p] is forbidden, but [simpl @p] will simplify both the projection + and it's explicit [@p] version. +- [unfold p] has no effect on projection applications unless it is applied + to a constructor. If the explicit version appears it reduces to the + projection application. +- [pattern x at n], [rewrite x at n] and in general abstraction and selection + of occurrences may fail due to the disappearance of parameters. + + Vernacular commands - The command "Record foo ..." does not generate induction principles @@ -258,7 +258,21 @@ devdocclean: .PHONY: tags printenv tags: - echo $(MLIFILES) $(MLSTATICFILES) $(ML4FILES) | sort -r | xargs \ + echo $(filter-out checker/%, $(MLIFILES)) $(filter-out checker/%, $(MLSTATICFILES)) $(ML4FILES) | sort -r | xargs \ + etags --language=none\ + "--regex=/let[ \t]+\([^ \t]+\)/\1/" \ + "--regex=/let[ \t]+rec[ \t]+\([^ \t]+\)/\1/" \ + "--regex=/and[ \t]+\([^ \t]+\)/\1/" \ + "--regex=/type[ \t]+\([^ \t]+\)/\1/" \ + "--regex=/exception[ \t]+\([^ \t]+\)/\1/" \ + "--regex=/val[ \t]+\([^ \t]+\)/\1/" \ + "--regex=/module[ \t]+\([^ \t]+\)/\1/" + echo $(ML4FILES) | sort -r | xargs \ + etags --append --language=none\ + "--regex=/[ \t]*\([^: \t]+\)[ \t]*:/\1/" + +checker-tags: + echo $(filter-out kernel/%, $(MLIFILES)) $(filter-out kernel/%, $(MLSTATICFILES)) $(ML4FILES) | sort -r | xargs \ etags --language=none\ "--regex=/let[ \t]+\([^ \t]+\)/\1/" \ "--regex=/let[ \t]+rec[ \t]+\([^ \t]+\)/\1/" \ diff --git a/Makefile.build b/Makefile.build index db2d0f720..6d12063ca 100644 --- a/Makefile.build +++ b/Makefile.build @@ -59,7 +59,7 @@ CURDEPS:=$(addsuffix .d, $(CURFILES)) VERBOSE= NO_RECOMPILE_ML4= NO_RECALC_DEPS= -READABLE_ML4= # non-empty means .ml of .ml4 will be ascii instead of binary +READABLE_ML4=true # non-empty means .ml of .ml4 will be ascii instead of binary VALIDATE= COQ_XML= # is "-xml" when building XML library VM= # is "-no-vm" to not use the vm" diff --git a/checker/cic.mli b/checker/cic.mli index 380093c57..d2f785abf 100644 --- a/checker/cic.mli +++ b/checker/cic.mli @@ -163,14 +163,7 @@ type engagement = ImpredicativeSet (** {6 Representation of constants (Definition/Axiom) } *) -type polymorphic_arity = { - poly_param_levels : Univ.universe option list; - poly_level : Univ.universe; -} - -type constant_type = - | NonPolymorphicType of constr - | PolymorphicArity of rel_context * polymorphic_arity +type constant_type = constr (** Inlining level of parameters at functor applications. This is ignored by the checker. *) @@ -203,15 +196,6 @@ type recarg = type wf_paths = recarg Rtree.t -type monomorphic_inductive_arity = { - mind_user_arity : constr; - mind_sort : sorts; -} - -type inductive_arity = -| Monomorphic of monomorphic_inductive_arity -| Polymorphic of polymorphic_arity - type one_inductive_body = { (** {8 Primitive datas } *) @@ -219,7 +203,7 @@ type one_inductive_body = { mind_arity_ctxt : rel_context; (** Arity context of [Ii] with parameters: [forall params, Ui] *) - mind_arity : inductive_arity; (** Arity sort and original user arity if monomorphic *) + mind_arity : constr; (** Arity sort and original user arity if monomorphic *) mind_consnames : Id.t array; (** Names of the constructors: [cij] *) diff --git a/checker/declarations.ml b/checker/declarations.ml index baf2e57db..4dd814d57 100644 --- a/checker/declarations.ml +++ b/checker/declarations.ml @@ -433,6 +433,9 @@ let subst_constant_def sub = function | Def c -> Def (subst_constr_subst sub c) | OpaqueDef lc -> OpaqueDef (subst_lazy_constr sub lc) +(** Local variables and graph *) +type universe_context = Univ.LSet.t * Univ.constraints + let body_of_constant cb = match cb.const_body with | Undef _ -> None | Def c -> Some (force_constr c) @@ -488,9 +491,8 @@ let eq_wf_paths = Rtree.equal eq_recarg with In (params) : Un := cn1 : Tn1 | ... | cnpn : Tnpn *) -let subst_arity sub = function -| NonPolymorphicType s -> NonPolymorphicType (subst_mps sub s) -| PolymorphicArity (ctx,s) -> PolymorphicArity (subst_rel_context sub ctx,s) +let subst_arity sub s = subst_mps sub s + (* TODO: should be changed to non-coping after Term.subst_mps *) (* NB: we leave bytecode and native code fields untouched *) @@ -499,14 +501,6 @@ let subst_const_body sub cb = const_body = subst_constant_def sub cb.const_body; const_type = subst_arity sub cb.const_type } -let subst_arity sub = function -| Monomorphic s -> - Monomorphic { - mind_user_arity = subst_mps sub s.mind_user_arity; - mind_sort = s.mind_sort; - } -| Polymorphic s as x -> x - let subst_mind_packet sub mbp = { mind_consnames = mbp.mind_consnames; mind_consnrealdecls = mbp.mind_consnrealdecls; diff --git a/checker/environ.ml b/checker/environ.ml index eb084a910..79234e9e2 100644 --- a/checker/environ.ml +++ b/checker/environ.ml @@ -77,7 +77,7 @@ let push_rec_types (lna,typarray,_) env = (* Universe constraints *) let add_constraints c env = - if c == empty_constraint then + if c == Constraint.empty then env else let s = env.env_stratification in diff --git a/checker/indtypes.ml b/checker/indtypes.ml index a64232442..5927e1633 100644 --- a/checker/indtypes.ml +++ b/checker/indtypes.ml @@ -139,14 +139,12 @@ let typecheck_arity env params inds = let nparamargs = rel_context_nhyps params in let nparamdecls = rel_context_length params in let check_arity arctxt = function - Monomorphic mar -> - let ar = mar.mind_user_arity in - let _ = infer_type env ar in - conv env (it_mkProd_or_LetIn (Sort mar.mind_sort) arctxt) ar; - ar - | Polymorphic par -> - check_polymorphic_arity env params par; - it_mkProd_or_LetIn (Sort(Type par.poly_level)) arctxt in + mar -> + let _ = infer_type env mar in + mar in + (* | Polymorphic par -> *) + (* check_polymorphic_arity env params par; *) + (* it_mkProd_or_LetIn (Sort(Type par.poly_level)) arctxt in *) let env_arities = Array.fold_left (fun env_ar ind -> @@ -178,11 +176,11 @@ let typecheck_arity env params inds = let check_predicativity env s small level = match s, engagement env with Type u, _ -> - let u' = fresh_local_univ () in - let cst = - merge_constraints (enforce_leq u u' empty_constraint) - (universes env) in - if not (check_leq cst level u') then + (* let u' = fresh_local_univ () in *) + (* let cst = *) + (* merge_constraints (enforce_leq u u' empty_constraint) *) + (* (universes env) in *) + if not (check_leq (universes env) level u) then failwith "impredicative Type inductive type" | Prop Pos, Some ImpredicativeSet -> () | Prop Pos, _ -> @@ -191,8 +189,8 @@ let check_predicativity env s small level = let sort_of_ind = function - Monomorphic mar -> mar.mind_sort - | Polymorphic par -> Type par.poly_level + mar -> snd (destArity mar) + (* | Polymorphic par -> Type par.poly_level *) let all_sorts = [InProp;InSet;InType] let small_sorts = [InProp;InSet] diff --git a/checker/inductive.ml b/checker/inductive.ml index e6a24f705..b32379b35 100644 --- a/checker/inductive.ml +++ b/checker/inductive.ml @@ -161,11 +161,11 @@ let rec make_subst env = function (* (actualize_decl_level), then to the conclusion of the arity (via *) (* the substitution) *) let ctx,subst = make_subst env (sign, exp, []) in - if polymorphism_on_non_applied_parameters then - let s = fresh_local_univ () in - let t = actualize_decl_level env (Type s) t in - (na,None,t)::ctx, cons_subst u s subst - else + (* if polymorphism_on_non_applied_parameters then *) + (* let s = fresh_local_univ () in *) + (* let t = actualize_decl_level env (Type s) t in *) + (* (na,None,t)::ctx, cons_subst u s subst *) + (* else *) d::ctx, subst | sign, [], _ -> (* Uniform parameters are exhausted *) @@ -173,23 +173,21 @@ let rec make_subst env = function | [], _, _ -> assert false -let instantiate_universes env ctx ar argsorts = - let args = Array.to_list argsorts in - let ctx,subst = make_subst env (ctx,ar.poly_param_levels,args) in - let level = subst_large_constraints subst ar.poly_level in - ctx, - if is_type0m_univ level then Prop Null - else if is_type0_univ level then Prop Pos - else Type level +(* let instantiate_universes env ctx ar argsorts = *) +(* let args = Array.to_list argsorts in *) +(* let ctx,subst = make_subst env (ctx,ar.poly_param_levels,args) in *) +(* let level = subst_large_constraints subst ar.poly_level in *) +(* ctx, *) +(* if is_type0m_univ level then Prop Null *) +(* else if is_type0_univ level then Prop Pos *) +(* else Type level *) let type_of_inductive_knowing_parameters env mip paramtyps = - match mip.mind_arity with - | Monomorphic s -> - s.mind_user_arity - | Polymorphic ar -> - let ctx = List.rev mip.mind_arity_ctxt in - let ctx,s = instantiate_universes env ctx ar paramtyps in - mkArity (List.rev ctx,s) + mip.mind_arity + (* | Polymorphic ar -> *) + (* let ctx = List.rev mip.mind_arity_ctxt in *) + (* let ctx,s = instantiate_universes env ctx ar paramtyps in *) + (* mkArity (List.rev ctx,s) *) (* Type of a (non applied) inductive type *) @@ -236,9 +234,7 @@ let error_elim_expln kp ki = (* Get type of inductive, with parameters instantiated *) let inductive_sort_family mip = - match mip.mind_arity with - | Monomorphic s -> family_of_sort s.mind_sort - | Polymorphic _ -> InType + family_of_sort (snd (destArity mip.mind_arity)) let mind_arity mip = mip.mind_arity_ctxt, inductive_sort_family mip diff --git a/checker/inductive.mli b/checker/inductive.mli index 0e9b9ccf3..082bdae19 100644 --- a/checker/inductive.mli +++ b/checker/inductive.mli @@ -54,8 +54,8 @@ val type_of_inductive_knowing_parameters : val max_inductive_sort : sorts array -> Univ.universe -val instantiate_universes : env -> rel_context -> - polymorphic_arity -> constr array -> rel_context * sorts +(* val instantiate_universes : env -> rel_context -> *) +(* inductive_arity -> constr array -> rel_context * sorts *) (***************************************************************) (* Debug *) diff --git a/checker/mod_checking.ml b/checker/mod_checking.ml index add993581..4f4cc5560 100644 --- a/checker/mod_checking.ml +++ b/checker/mod_checking.ml @@ -14,31 +14,30 @@ open Environ (** {6 Checking constants } *) -let refresh_arity ar = - let ctxt, hd = decompose_prod_assum ar in - match hd with - Sort (Type u) when not (Univ.is_univ_variable u) -> - let u' = Univ.fresh_local_univ() in - mkArity (ctxt,Type u'), - Univ.enforce_leq u u' Univ.empty_constraint - | _ -> ar, Univ.empty_constraint +(* let refresh_arity ar = *) +(* let ctxt, hd = decompose_prod_assum ar in *) +(* match hd with *) +(* Sort (Type u) when not (Univ.is_univ_variable u) -> *) +(* let u' = Univ.fresh_local_univ() in *) +(* mkArity (ctxt,Type u'), *) +(* Univ.enforce_leq u u' Univ.empty_constraint *) +(* | _ -> ar, Univ.empty_constraint *) let check_constant_declaration env kn cb = Flags.if_verbose ppnl (str " checking cst: " ++ prcon kn); (* let env = add_constraints cb.const_constraints env in*) (match cb.const_type with - NonPolymorphicType ty -> - let ty, cu = refresh_arity ty in - let envty = add_constraints cu env in - let _ = infer_type envty ty in - (match body_of_constant cb with + ty -> + let env' = add_constraints cb.const_constraints env in + let _ = infer_type env' ty in + (match body_of_constant cb with | Some bd -> - let j = infer env bd in - conv_leq envty j ty + let j = infer env' bd in + conv_leq env' j ty | None -> ()) - | PolymorphicArity(ctxt,par) -> - let _ = check_ctxt env ctxt in - check_polymorphic_arity env ctxt par); + (* | PolymorphicArity(ctxt,par) -> *) + (* let _ = check_ctxt env ctxt in *) + (* check_polymorphic_arity env ctxt par *)); add_constant kn cb env diff --git a/checker/term.ml b/checker/term.ml index ea81f5dab..67d380336 100644 --- a/checker/term.ml +++ b/checker/term.ml @@ -347,7 +347,7 @@ let compare_sorts s1 s2 = match s1, s2 with | Pos, Null -> false | Null, Pos -> false end -| Type u1, Type u2 -> Universe.equal u1 u2 +| Type u1, Type u2 -> Universe.eq u1 u2 | Prop _, Type _ -> false | Type _, Prop _ -> false diff --git a/checker/typeops.ml b/checker/typeops.ml index 95753769d..6a705b198 100644 --- a/checker/typeops.ml +++ b/checker/typeops.ml @@ -67,12 +67,11 @@ let judge_of_relative env n = (* Type of constants *) let type_of_constant_knowing_parameters env t paramtyps = - match t with - | NonPolymorphicType t -> t - | PolymorphicArity (sign,ar) -> - let ctx = List.rev sign in - let ctx,s = instantiate_universes env ctx ar paramtyps in - mkArity (List.rev ctx,s) + t + (* | PolymorphicArity (sign,ar) -> *) + (* let ctx = List.rev sign in *) + (* let ctx,s = instantiate_universes env ctx ar paramtyps in *) + (* mkArity (List.rev ctx,s) *) let type_of_constant_type env t = type_of_constant_knowing_parameters env t [||] @@ -220,14 +219,14 @@ let type_fixpoint env lna lar lbody vdefj = (************************************************************************) -let refresh_arity env ar = - let ctxt, hd = decompose_prod_assum ar in - match hd with - Sort (Type u) when not (is_univ_variable u) -> - let u' = fresh_local_univ() in - let env' = add_constraints (enforce_leq u u' empty_constraint) env in - env', mkArity (ctxt,Type u') - | _ -> env, ar +(* let refresh_arity env ar = *) +(* let ctxt, hd = decompose_prod_assum ar in *) +(* match hd with *) +(* Sort (Type u) when not (is_univ_variable u) -> *) +(* let u' = fresh_local_univ() in *) +(* let env' = add_constraints (enforce_leq u u' empty_constraint) env in *) +(* env', mkArity (ctxt,Type u') *) +(* | _ -> env, ar *) (* The typing machine. *) @@ -282,7 +281,7 @@ let rec execute env cstr = (* /!\ c2 can be an inferred type => refresh (but the pushed type is still c2) *) let _ = - let env',c2' = refresh_arity env c2 in + let env',c2' = (* refresh_arity env *) env, c2 in let _ = execute_type env' c2' in judge_of_cast env' (c1,j1) DEFAULTcast c2' in let env1 = push_rel (name,Some c1,c2) env in @@ -365,14 +364,14 @@ let check_kind env ar u = if snd (dest_prod env ar) = Sort(Type u) then () else failwith "not the correct sort" -let check_polymorphic_arity env params par = - let pl = par.poly_param_levels in - let rec check_p env pl params = - match pl, params with - Some u::pl, (na,None,ty)::params -> - check_kind env ty u; - check_p (push_rel (na,None,ty) env) pl params - | None::pl,d::params -> check_p (push_rel d env) pl params - | [], _ -> () - | _ -> failwith "check_poly: not the right number of params" in - check_p env pl (List.rev params) +(* let check_polymorphic_arity env params par = *) +(* let pl = par.poly_param_levels in *) +(* let rec check_p env pl params = *) +(* match pl, params with *) +(* Some u::pl, (na,None,ty)::params -> *) +(* check_kind env ty u; *) +(* check_p (push_rel (na,None,ty) env) pl params *) +(* | None::pl,d::params -> check_p (push_rel d env) pl params *) +(* | [], _ -> () *) +(* | _ -> failwith "check_poly: not the right number of params" in *) +(* check_p env pl (List.rev params) *) diff --git a/checker/typeops.mli b/checker/typeops.mli index 92535606f..97d79fe54 100644 --- a/checker/typeops.mli +++ b/checker/typeops.mli @@ -16,8 +16,8 @@ open Environ val infer : env -> constr -> constr val infer_type : env -> constr -> sorts val check_ctxt : env -> rel_context -> env -val check_polymorphic_arity : - env -> rel_context -> polymorphic_arity -> unit +(* val check_polymorphic_arity : *) +(* env -> rel_context -> polymorphic_arity -> unit *) -val type_of_constant_type : env -> constant_type -> constr +val type_of_constant_type : env -> constr -> constr diff --git a/dev/base_include b/dev/base_include index c889d17eb..c58a35748 100644 --- a/dev/base_include +++ b/dev/base_include @@ -93,6 +93,7 @@ open Evarutil open Evarsolve open Tacred open Evd +open Universes open Termops open Namegen open Indrec diff --git a/dev/include b/dev/include index 23fcbd8db..58fff078b 100644 --- a/dev/include +++ b/dev/include @@ -29,12 +29,25 @@ #install_printer (* pattern *) pppattern;; #install_printer (* glob_constr *) ppglob_constr;; - +#install_printer (* open constr *) ppopenconstr;; #install_printer (* constr *) ppconstr;; #install_printer (* constr_substituted *) ppsconstr;; +#install_printer (* constraints *) ppconstraints;; +#install_printer (* univ constraints *) ppuniverseconstraints;; #install_printer (* universe *) ppuni;; #install_printer (* universes *) ppuniverses;; -#install_printer (* constraints *) ppconstraints;; +#install_printer (* univ level *) ppuni_level;; +#install_printer (* univ context *) ppuniverse_context;; +#install_printer (* univ context set *) ppuniverse_context_set;; +#install_printer (* univ set *) ppuniverse_set;; +#install_printer (* univ instance *) ppuniverse_instance;; +#install_printer (* univ subst *) ppuniverse_subst;; +#install_printer (* univ full subst *) ppuniverse_level_subst;; +#install_printer (* univ opt subst *) ppuniverse_opt_subst;; +#install_printer (* evar univ ctx *) ppevar_universe_context;; +#install_printer (* constraints_map *) ppconstraints_map;; +#install_printer (* inductive *) ppind;; +#install_printer (* 'a scheme_kind *) ppscheme;; #install_printer (* type_judgement *) pptype;; #install_printer (* judgement *) ppj;; diff --git a/dev/myinclude b/dev/myinclude new file mode 100644 index 000000000..48de3647a --- /dev/null +++ b/dev/myinclude @@ -0,0 +1 @@ +#use "include";; diff --git a/dev/printers.mllib b/dev/printers.mllib index 1e2764997..fb8d4c73e 100644 --- a/dev/printers.mllib +++ b/dev/printers.mllib @@ -82,6 +82,7 @@ Type_errors Modops Inductive Typeops +Fast_typeops Indtypes Cooking Term_typing @@ -89,6 +90,7 @@ Subtyping Mod_typing Nativelibrary Safe_typing +Unionfind Summary Nameops @@ -107,6 +109,7 @@ Locusops Miscops Termops Namegen +Universes Evd Glob_ops Redops @@ -188,4 +191,9 @@ Himsg Cerrors Locality Vernacinterp +Dischargedhypsmap +Discharge +Declare +Ind_tables Top_printers + diff --git a/dev/top_printers.ml b/dev/top_printers.ml index 7d6370b9d..31c5e608a 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -22,6 +22,7 @@ open Evd open Goptions open Genarg open Clenv +open Universes let _ = Constrextern.print_evar_arguments := true let _ = Constrextern.print_universes := true @@ -44,9 +45,11 @@ let ppmp mp = pp(str (string_of_mp mp)) let ppcon con = pp(debug_pr_con con) let ppkn kn = pp(pr_kn kn) let ppmind kn = pp(debug_pr_mind kn) +let ppind (kn,i) = pp(debug_pr_mind kn ++ str"," ++int i) let ppsp sp = pp(pr_path sp) let ppqualid qid = pp(pr_qualid qid) let ppclindex cl = pp(Classops.pr_cl_index cl) +let ppscheme k = pp (Ind_tables.pr_scheme_kind k) let pprecarg = function | Declarations.Norec -> str "Norec" @@ -60,6 +63,7 @@ let ppwf_paths x = pp (Rtree.pp_tree pprecarg x) let rawdebug = ref false let ppevar evk = pp (str (Evd.string_of_existential evk)) let ppconstr x = pp (Termops.print_constr x) +let ppconstr_expr x = pp (Ppconstr.pr_constr_expr x) let ppconstrdb x = pp(Flags.with_option rawdebug Termops.print_constr x) let ppterm = ppconstr let ppsconstr x = ppconstr (Mod_subst.force_constr x) @@ -67,7 +71,6 @@ let ppconstr_univ x = Constrextern.with_universes ppconstr x let ppglob_constr = (fun x -> pp(pr_lglob_constr x)) let pppattern = (fun x -> pp(pr_constr_pattern x)) let pptype = (fun x -> try pp(pr_ltype x) with e -> pp (str (Printexc.to_string e))) - let ppfconstr c = ppconstr (Closure.term_of_fconstr c) let ppbigint n = pp (str (Bigint.to_string n));; @@ -145,6 +148,10 @@ let ppexistentialfilter filter = match Evd.Filter.repr filter with let ppclenv clenv = pp(pr_clenv clenv) let ppgoalgoal gl = pp(Goal.pr_goal gl) let ppgoal g = pp(Printer.pr_goal g) +let ppgoalsigma g = pp(Printer.pr_goal g ++ pr_evar_map None (Refiner.project g)) + +let ppopenconstr (x : Evd.open_constr) = + let (evd,c) = x in pp (pr_evar_map (Some 2) evd ++ pr_constr c) (* spiwack: deactivated until a replacement is found let pppftreestate p = pp(print_pftreestate p) *) @@ -163,10 +170,20 @@ let pppftreestate p = pp(print_pftreestate p) (* let pproof p = pp(print_proof Evd.empty empty_named_context p) *) let ppuni u = pp(pr_uni u) - -let ppuniverses u = pp (str"[" ++ pr_universes u ++ str"]") - +let ppuni_level u = pp (Level.pr u) +let ppuniverses u = pp (str"[" ++ Universe.pr u ++ str"]") + +let ppuniverse_set l = pp (LSet.pr l) +let ppuniverse_instance l = pp (Instance.pr l) +let ppuniverse_context l = pp (pr_universe_context l) +let ppuniverse_context_set l = pp (pr_universe_context_set l) +let ppuniverse_subst l = pp (Univ.pr_universe_subst l) +let ppuniverse_opt_subst l = pp (Universes.pr_universe_opt_subst l) +let ppuniverse_level_subst l = pp (Univ.pr_universe_level_subst l) +let ppevar_universe_context l = pp (Evd.pr_evar_universe_context l) +let ppconstraints_map c = pp (Universes.pr_constraints_map c) let ppconstraints c = pp (pr_constraints c) +let ppuniverseconstraints c = pp (UniverseConstraints.pr c) let ppenv e = pp (str "[" ++ pr_named_context_of e ++ str "]" ++ spc() ++ @@ -202,12 +219,13 @@ let constr_display csr = ^(term_display t)^","^(term_display c)^")" | App (c,l) -> "App("^(term_display c)^","^(array_display l)^")\n" | Evar (e,l) -> "Evar("^(string_of_existential e)^","^(array_display l)^")" - | Const c -> "Const("^(string_of_con c)^")" - | Ind (sp,i) -> - "MutInd("^(string_of_mind sp)^","^(string_of_int i)^")" - | Construct ((sp,i),j) -> + | Const (c,u) -> "Const("^(string_of_con c)^","^(universes_display u)^")" + | Ind ((sp,i),u) -> + "MutInd("^(string_of_mind sp)^","^(string_of_int i)^","^(universes_display u)^")" + | Construct (((sp,i),j),u) -> "MutConstruct(("^(string_of_mind sp)^","^(string_of_int i)^")," - ^(string_of_int j)^")" + ^","^(universes_display u)^(string_of_int j)^")" + | Proj (p, c) -> "Proj("^(string_of_con p)^","^term_display c ^")" | Case (ci,p,c,bl) -> "MutCase(<abs>,"^(term_display p)^","^(term_display c)^"," ^(array_display bl)^")" @@ -231,13 +249,22 @@ let constr_display csr = (fun x i -> (term_display x)^(if not(i="") then (";"^i) else "")) v "")^"|]" + and univ_display u = + incr cnt; pp (str "with " ++ int !cnt ++ str" " ++ pr_uni u ++ fnl ()) + + and level_display u = + incr cnt; pp (str "with " ++ int !cnt ++ str" " ++ Level.pr u ++ fnl ()) + and sort_display = function | Prop(Pos) -> "Prop(Pos)" | Prop(Null) -> "Prop(Null)" - | Type u -> - incr cnt; pp (str "with " ++ int !cnt ++ pr_uni u ++ fnl ()); + | Type u -> univ_display u; "Type("^(string_of_int !cnt)^")" + and universes_display l = + Array.fold_right (fun x i -> level_display x; (string_of_int !cnt)^(if not(i="") + then (" "^i) else "")) (Instance.to_array l) "" + and name_display = function | Name id -> "Name("^(Id.to_string id)^")" | Anonymous -> "Anonymous" @@ -282,19 +309,28 @@ let print_pure_constr csr = | Evar (e,l) -> print_string "Evar#"; print_int (Evar.repr e); print_string "{"; Array.iter (fun x -> print_space (); box_display x) l; print_string"}" - | Const c -> print_string "Cons("; + | Const (c,u) -> print_string "Cons("; sp_con_display c; + print_string ","; universes_display u; + print_string ")" + | Proj (p,c') -> print_string "Proj("; + sp_con_display p; + print_string ","; + box_display c'; print_string ")" - | Ind (sp,i) -> + | Ind ((sp,i),u) -> print_string "Ind("; sp_display sp; print_string ","; print_int i; + print_string ","; universes_display u; print_string ")" - | Construct ((sp,i),j) -> + | Construct (((sp,i),j),u) -> print_string "Constr("; sp_display sp; print_string ","; - print_int i; print_string ","; print_int j; print_string ")" + print_int i; print_string ","; print_int j; + print_string ","; universes_display u; + print_string ")" | Case (ci,p,c,bl) -> open_vbox 0; print_string "<"; box_display p; print_string ">"; @@ -336,6 +372,9 @@ let print_pure_constr csr = and box_display c = open_hovbox 1; term_display c; close_box() + and universes_display u = + Array.iter (fun u -> print_space (); pp (Level.pr u)) (Instance.to_array u) + and sort_display = function | Prop(Pos) -> print_string "Set" | Prop(Null) -> print_string "Prop" @@ -404,7 +443,7 @@ let in_current_context f c = let (evmap,sign) = try Pfedit.get_current_goal_context () with e when Logic.catchable_exception e -> (Evd.empty, Global.env()) in - f (Constrintern.interp_constr evmap sign c) + f (fst (Constrintern.interp_constr evmap sign c))(*FIXME*) (* We expand the result of preprocessing to be independent of camlp4 diff --git a/grammar/q_constr.ml4 b/grammar/q_constr.ml4 index a731ade68..cf671adcb 100644 --- a/grammar/q_constr.ml4 +++ b/grammar/q_constr.ml4 @@ -18,7 +18,7 @@ let dloc = <:expr< Loc.ghost >> let apply_ref f l = <:expr< - Glob_term.GApp ($dloc$, Glob_term.GRef ($dloc$, Lazy.force $f$), $mlexpr_of_list (fun x -> x) l$) + Glob_term.GApp ($dloc$, Glob_term.GRef ($dloc$, Lazy.force $f$, None), $mlexpr_of_list (fun x -> x) l$) >> EXTEND @@ -74,7 +74,7 @@ EXTEND | "?"; id = ident -> <:expr< Glob_term.GPatVar($dloc$,(False,$id$)) >> | "{"; c1 = constr; "}"; "+"; "{"; c2 = constr; "}" -> apply_ref <:expr< coq_sumbool_ref >> [c1;c2] - | "%"; e = string -> <:expr< Glob_term.GRef ($dloc$,Lazy.force $lid:e$) >> + | "%"; e = string -> <:expr< Glob_term.GRef ($dloc$,Lazy.force $lid:e$, None) >> | c = match_constr -> c | "("; c = constr LEVEL "200"; ")" -> c ] ] ; diff --git a/grammar/q_coqast.ml4 b/grammar/q_coqast.ml4 index b3f60dee6..9a0a22b9f 100644 --- a/grammar/q_coqast.ml4 +++ b/grammar/q_coqast.ml4 @@ -140,10 +140,10 @@ let mlexpr_of_binder_kind = function $mlexpr_of_binding_kind b'$ $mlexpr_of_bool b''$ >> let rec mlexpr_of_constr = function - | Constrexpr.CRef (Libnames.Ident (loc,id)) when is_meta (Id.to_string id) -> + | Constrexpr.CRef (Libnames.Ident (loc,id),_) when is_meta (Id.to_string id) -> let loc = of_coqloc loc in anti loc (Id.to_string id) - | Constrexpr.CRef r -> <:expr< Constrexpr.CRef $mlexpr_of_reference r$ >> + | Constrexpr.CRef (r,n) -> <:expr< Constrexpr.CRef $mlexpr_of_reference r$ None >> | Constrexpr.CFix (loc,_,_) -> failwith "mlexpr_of_constr: TODO" | Constrexpr.CCoFix (loc,_,_) -> failwith "mlexpr_of_constr: TODO" | Constrexpr.CProdN (loc,l,a) -> @@ -154,8 +154,9 @@ let rec mlexpr_of_constr = function let loc = of_coqloc loc in <:expr< Constrexpr.CLambdaN $dloc$ $mlexpr_of_list (mlexpr_of_triple (mlexpr_of_list (mlexpr_of_pair (fun _ -> dloc) mlexpr_of_name)) mlexpr_of_binder_kind mlexpr_of_constr) l$ $mlexpr_of_constr a$ >> | Constrexpr.CLetIn (loc,_,_,_) -> failwith "mlexpr_of_constr: TODO" - | Constrexpr.CAppExpl (loc,a,l) -> + | Constrexpr.CAppExpl (loc,(p,r,us),l) -> let loc = of_coqloc loc in + let a = (p,r) in <:expr< Constrexpr.CAppExpl $dloc$ $mlexpr_of_pair (mlexpr_of_option mlexpr_of_int) mlexpr_of_reference a$ $mlexpr_of_list mlexpr_of_constr l$ >> | Constrexpr.CApp (loc,a,l) -> let loc = of_coqloc loc in diff --git a/interp/constrexpr_ops.ml b/interp/constrexpr_ops.ml index 85ad1cee7..1ba0cafa7 100644 --- a/interp/constrexpr_ops.ml +++ b/interp/constrexpr_ops.ml @@ -91,10 +91,16 @@ and cases_pattern_notation_substitution_eq (s1, n1) (s2, n2) = List.equal cases_pattern_expr_eq s1 s2 && List.equal (List.equal cases_pattern_expr_eq) n1 n2 +let eq_universes u1 u2 = + match u1, u2 with + | None, None -> true + | Some l, Some l' -> l = l' + | _, _ -> false + let rec constr_expr_eq e1 e2 = if e1 == e2 then true else match e1, e2 with - | CRef r1, CRef r2 -> eq_reference r1 r2 + | CRef (r1,u1), CRef (r2,u2) -> eq_reference r1 r2 && eq_universes u1 u2 | CFix(_,id1,fl1), CFix(_,id2,fl2) -> eq_located Id.equal id1 id2 && List.equal fix_expr_eq fl1 fl2 @@ -111,7 +117,7 @@ let rec constr_expr_eq e1 e2 = Name.equal na1 na2 && constr_expr_eq a1 a2 && constr_expr_eq b1 b2 - | CAppExpl(_,(proj1,r1),al1), CAppExpl(_,(proj2,r2),al2) -> + | CAppExpl(_,(proj1,r1,_),al1), CAppExpl(_,(proj2,r2,_),al2) -> Option.equal Int.equal proj1 proj2 && eq_reference r1 r2 && List.equal constr_expr_eq al1 al2 @@ -221,8 +227,8 @@ and constr_notation_substitution_eq (e1, el1, bl1) (e2, el2, bl2) = List.equal (List.equal local_binder_eq) bl1 bl2 let constr_loc = function - | CRef (Ident (loc,_)) -> loc - | CRef (Qualid (loc,_)) -> loc + | CRef (Ident (loc,_),_) -> loc + | CRef (Qualid (loc,_),_) -> loc | CFix (loc,_,_) -> loc | CCoFix (loc,_,_) -> loc | CProdN (loc,_,_) -> loc @@ -272,8 +278,8 @@ let local_binders_loc bll = match bll with (** Pseudo-constructors *) -let mkIdentC id = CRef (Ident (Loc.ghost, id)) -let mkRefC r = CRef r +let mkIdentC id = CRef (Ident (Loc.ghost, id),None) +let mkRefC r = CRef (r,None) let mkCastC (a,k) = CCast (Loc.ghost,a,k) let mkLambdaC (idl,bk,a,b) = CLambdaN (Loc.ghost,[idl,bk,a],b) let mkLetInC (id,a,b) = CLetIn (Loc.ghost,id,a,b) @@ -324,13 +330,13 @@ let coerce_reference_to_id = function str "This expression should be a simple identifier.") let coerce_to_id = function - | CRef (Ident (loc,id)) -> (loc,id) + | CRef (Ident (loc,id),_) -> (loc,id) | a -> Errors.user_err_loc (constr_loc a,"coerce_to_id", str "This expression should be a simple identifier.") let coerce_to_name = function - | CRef (Ident (loc,id)) -> (loc,Name id) + | CRef (Ident (loc,id),_) -> (loc,Name id) | CHole (loc,_,_) -> (loc,Anonymous) | a -> Errors.user_err_loc (constr_loc a,"coerce_to_name", diff --git a/interp/constrextern.ml b/interp/constrextern.ml index 6a893bde6..e4ac9426b 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -439,6 +439,11 @@ let occur_name na aty = let is_projection nargs = function | Some r when not !Flags.raw_print && !print_projections -> + if true (* FIXME *) (* !Record.primitive_flag *) then + (match r with + | ConstRef c when Environ.is_projection c (Global.env ()) -> Some 1 + | _ -> None) + else (try let n = Recordops.find_projection_nparams r + 1 in if n <= nargs then Some n else None @@ -477,10 +482,12 @@ let explicitize loc inctx impl (cf,f) args = | args, [] -> List.map (fun a -> (a,None)) args (*In case of polymorphism*) | [], _ -> [] in match is_projection (List.length args) cf with - | Some i as ip -> + | Some i -> if not (List.is_empty impl) && is_status_implicit (List.nth impl (i-1)) then - let f' = match f with CRef f -> f | _ -> assert false in - CAppExpl (loc,(ip,f'),args) + let args = exprec 1 (args,impl) in + CApp (loc, (None, f), args) + (* let f',us = match f with CRef (f,us) -> f,us | _ -> assert false in *) + (* CAppExpl (loc,(ip,f',us),args) *) else let (args1,args2) = List.chop i args in let (impl1,impl2) = if List.is_empty impl then [],[] else List.chop i impl in @@ -488,29 +495,29 @@ let explicitize loc inctx impl (cf,f) args = let args2 = exprec (i+1) (args2,impl2) in CApp (loc,(Some (List.length args1),f),args1@args2) | None -> - let args = exprec 1 (args,impl) in - if List.is_empty args then f else CApp (loc, (None, f), args) + let args = exprec 1 (args,impl) in + if List.is_empty args then f else CApp (loc, (None, f), args) -let extern_global loc impl f = +let extern_global loc impl f us = if not !Constrintern.parsing_explicit && not (List.is_empty impl) && List.for_all is_status_implicit impl then - CAppExpl (loc, (None, f), []) + CAppExpl (loc, (None, f, us), []) else - CRef f + CRef (f,us) -let extern_app loc inctx impl (cf,f) args = +let extern_app loc inctx impl (cf,f) us args = if List.is_empty args then (* If coming from a notation "Notation a := @b" *) - CAppExpl (loc, (None, f), []) + CAppExpl (loc, (None, f, us), []) else if not !Constrintern.parsing_explicit && ((!Flags.raw_print || (!print_implicits && not !print_implicits_explicit_args)) && List.exists is_status_implicit impl) then - CAppExpl (loc, (is_projection (List.length args) cf, f), args) + CAppExpl (loc, (is_projection (List.length args) cf,f,us), args) else - explicitize loc inctx impl (cf,CRef f) args + explicitize loc inctx impl (cf,CRef (f,us)) args let rec extern_args extern scopes env args subscopes = match args with @@ -522,7 +529,7 @@ let rec extern_args extern scopes env args subscopes = extern argscopes env a :: extern_args extern scopes env args subscopes let rec remove_coercions inctx = function - | GApp (loc,GRef (_,r),args) as c + | GApp (loc,GRef (_,r,_),args) as c when not (!Flags.raw_print || !print_coercions) -> let nargs = List.length args in @@ -579,6 +586,10 @@ let extern_glob_sort = function | GType (Some _) as s when !print_universes -> s | GType _ -> GType None +let extern_universes = function + | Some _ as l when !print_universes -> l + | _ -> None + let rec extern inctx scopes vars r = let r' = remove_coercions inctx r in try @@ -590,11 +601,11 @@ let rec extern inctx scopes vars r = if !Flags.raw_print || !print_no_symbol then raise No_match; extern_symbol scopes vars r'' (uninterp_notations r'') with No_match -> match r' with - | GRef (loc,ref) -> + | GRef (loc,ref,us) -> extern_global loc (select_stronger_impargs (implicits_of_global ref)) - (extern_reference loc vars ref) + (extern_reference loc vars ref) (extern_universes us) - | GVar (loc,id) -> CRef (Ident (loc,id)) + | GVar (loc,id) -> CRef (Ident (loc,id),None) | GEvar (loc,n,None) when !print_meta_as_hole -> CHole (loc, None, None) @@ -606,7 +617,7 @@ let rec extern inctx scopes vars r = | GApp (loc,f,args) -> (match f with - | GRef (rloc,ref) -> + | GRef (rloc,ref,us) -> let subscopes = find_arguments_scope ref in let args = extern_args (extern true) (snd scopes) vars args subscopes in @@ -652,11 +663,24 @@ let rec extern inctx scopes vars r = | Not_found | No_match | Exit -> extern_app loc inctx (select_stronger_impargs (implicits_of_global ref)) - (Some ref,extern_reference rloc vars ref) args + (Some ref,extern_reference rloc vars ref) (extern_universes us) args end + + | GProj (loc,p,c) -> + let ref = ConstRef p in + let subscopes = find_arguments_scope ref in + let args = + extern_args (extern true) (snd scopes) vars (c :: args) subscopes + in + extern_app loc inctx [] (Some ref, extern_reference loc vars ref) + None args + | _ -> - explicitize loc inctx [] (None,sub_extern false scopes vars f) - (List.map (sub_extern true scopes vars) args)) + explicitize loc inctx [] (None,sub_extern false scopes vars f) + (List.map (sub_extern true scopes vars) args)) + + | GProj (loc,p,c) -> + extern inctx scopes vars (GApp (loc,r',[])) | GLetIn (loc,na,t,c) -> CLetIn (loc,(loc,na),sub_extern false scopes vars t, @@ -816,7 +840,7 @@ and extern_symbol (tmp_scope,scopes as allscopes) vars t = function let args1, args2 = List.chop n args in let subscopes, impls = match f with - | GRef (_,ref) -> + | GRef (_,ref,us) -> let subscopes = try List.skipn n (find_arguments_scope ref) with Failure _ -> [] in @@ -830,13 +854,13 @@ and extern_symbol (tmp_scope,scopes as allscopes) vars t = function [], [] in (if Int.equal n 0 then f else GApp (Loc.ghost,f,args1)), args2, subscopes, impls - | GApp (_,(GRef (_,ref) as f),args), None -> + | GApp (_,(GRef (_,ref,us) as f),args), None -> let subscopes = find_arguments_scope ref in let impls = select_impargs_size (List.length args) (implicits_of_global ref) in f, args, subscopes, impls - | GRef _, Some 0 -> GApp (Loc.ghost,t,[]), [], [], [] + | GRef (_,ref,us), Some 0 -> GApp (Loc.ghost,t,[]), [], [], [] | _, None -> t, [], [], [] | _ -> raise No_match in (* Try matching ... *) @@ -871,7 +895,7 @@ and extern_symbol (tmp_scope,scopes as allscopes) vars t = function List.map (fun (c,(scopt,scl)) -> extern true (scopt,scl@scopes) vars c, None) terms in - let a = CRef (Qualid (loc, shortest_qualid_of_syndef vars kn)) in + let a = CRef (Qualid (loc, shortest_qualid_of_syndef vars kn),None) in if List.is_empty l then a else CApp (loc,(None,a),l) in if List.is_empty args then e else @@ -934,7 +958,7 @@ let any_any_branch = (loc,[],[PatVar (loc,Anonymous)],GHole (loc,Evar_kinds.InternalHole,None)) let rec glob_of_pat env = function - | PRef ref -> GRef (loc,ref) + | PRef ref -> GRef (loc,ref,None) | PVar id -> GVar (loc,id) | PEvar (n,l) -> GEvar (loc,n,Some (Array.map_to_list (glob_of_pat env) l)) | PRel n -> @@ -946,6 +970,7 @@ let rec glob_of_pat env = function GVar (loc,id) | PMeta None -> GHole (loc,Evar_kinds.InternalHole, None) | PMeta (Some n) -> GPatVar (loc,(false,n)) + | PProj (p,c) -> GApp (loc,GRef (loc, ConstRef p,None),[glob_of_pat env c]) | PApp (f,args) -> GApp (loc,glob_of_pat env f,Array.map_to_list (glob_of_pat env) args) | PSoApp (n,args) -> diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 7fba83e66..0905ad1d6 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -93,7 +93,7 @@ let global_reference_of_reference ref = locate_reference (snd (qualid_of_reference ref)) let global_reference id = - constr_of_global (locate_reference (qualid_of_ident id)) + Universes.constr_of_global (locate_reference (qualid_of_ident id)) let construct_reference ctx id = try @@ -102,7 +102,7 @@ let construct_reference ctx id = global_reference id let global_reference_in_absolute_module dir id = - constr_of_global (Nametab.global_of_path (Libnames.make_path dir id)) + Universes.constr_of_global (Nametab.global_of_path (Libnames.make_path dir id)) (**********************************************************************) (* Internalization errors *) @@ -300,7 +300,7 @@ let reset_tmp_scope env = {env with tmp_scope = None} let set_scope env = function | CastConv (GSort _) -> set_type_scope env - | CastConv (GRef (_,ref) | GApp (_,GRef (_,ref),_)) -> + | CastConv (GRef (_,ref,_) | GApp (_,GRef (_,ref,_),_)) -> {env with tmp_scope = compute_scope_of_global ref} | _ -> env @@ -410,7 +410,7 @@ let intern_generalized_binder ?(global_level=false) intern_type lvar let name = let id = match ty with - | CApp (_, (_, CRef (Ident (loc,id))), _) -> id + | CApp (_, (_, CRef (Ident (loc,id),_)), _) -> id | _ -> Id.of_string "H" in Implicit_quantifiers.make_fresh ids' (Global.env ()) id in Name name @@ -650,7 +650,7 @@ let intern_var genv (ltacvars,ntnvars) namedctx loc id = try let ty,expl_impls,impls,argsc = Id.Map.find id genv.impls in let expl_impls = List.map - (fun id -> CRef (Ident (loc,id)), Some (loc,ExplByName id)) expl_impls in + (fun id -> CRef (Ident (loc,id),None), Some (loc,ExplByName id)) expl_impls in let tys = string_of_ty ty in Dumpglob.dump_reference loc "<>" (Id.to_string id) tys; GVar (loc,id), make_implicits_list impls, argsc, expl_impls @@ -682,19 +682,38 @@ let intern_var genv (ltacvars,ntnvars) namedctx loc id = let impls = implicits_of_global ref in let scopes = find_arguments_scope ref in Dumpglob.dump_reference loc "<>" (string_of_qualid (Decls.variable_secpath id)) "var"; - GRef (loc, ref), impls, scopes, [] + GRef (loc, ref, None), impls, scopes, [] with e when Errors.noncritical e -> (* [id] a goal variable *) GVar (loc,id), [], [], [] -let find_appl_head_data = function - | GRef (_,ref) as x -> x,implicits_of_global ref,find_arguments_scope ref,[] - | GApp (_,GRef (_,ref),l) as x +let is_projection_ref = function + | ConstRef r -> if Environ.is_projection r (Global.env ()) then Some r else None + | _ -> None + +let find_appl_head_data c = + match c with + | GRef (loc,ref,_) as x -> + let impls = implicits_of_global ref in + let isproj, impls = + match is_projection_ref ref with + | Some r -> true, List.map (projection_implicits (Global.env ()) r) impls + | None -> false, impls + in + let scopes = find_arguments_scope ref in + x, isproj, impls, scopes, [] + | GApp (_,GRef (_,ref,_),l) as x when l != [] && Flags.version_strictly_greater Flags.V8_2 -> let n = List.length l in - x,List.map (drop_first_implicits n) (implicits_of_global ref), - List.skipn_at_least n (find_arguments_scope ref),[] - | x -> x,[],[],[] + let impls = implicits_of_global ref in + let isproj, impls = + match is_projection_ref ref with + | Some r -> true, List.map (projection_implicits (Global.env ()) r) impls + | None -> false, impls + in + x, isproj, List.map (drop_first_implicits n) impls, + List.skipn_at_least n (find_arguments_scope ref),[] + | x -> x,false,[],[],[] let error_not_enough_arguments loc = user_err_loc (loc,"",str "Abbreviation is not applied enough.") @@ -726,8 +745,7 @@ let intern_reference ref = (* Is it a global reference or a syntactic definition? *) let intern_qualid loc qid intern env lvar args = match intern_extended_global_of_qualid (loc,qid) with - | TrueGlobal ref -> - GRef (loc, ref), args + | TrueGlobal ref -> GRef (loc, ref, None), args | SynDef sp -> let (ids,c) = Syntax_def.search_syntactic_definition sp in let nids = List.length ids in @@ -742,7 +760,7 @@ let intern_qualid loc qid intern env lvar args = (* Rule out section vars since these should have been found by intern_var *) let intern_non_secvar_qualid loc qid intern env lvar args = match intern_qualid loc qid intern env lvar args with - | GRef (_, VarRef _),_ -> raise Not_found + | GRef (_, VarRef _, _),_ -> raise Not_found | r -> r let intern_applied_reference intern env namedctx lvar args = function @@ -751,22 +769,24 @@ let intern_applied_reference intern env namedctx lvar args = function try intern_qualid loc qid intern env lvar args with Not_found -> error_global_not_found_loc loc qid in - find_appl_head_data r, args2 + let x, isproj, imp, scopes, l = find_appl_head_data r in + (x,imp,scopes,l), isproj, args2 | Ident (loc, id) -> - try intern_var env lvar namedctx loc id, args + try intern_var env lvar namedctx loc id, false, args with Not_found -> let qid = qualid_of_ident id in try let r,args2 = intern_non_secvar_qualid loc qid intern env lvar args in - find_appl_head_data r, args2 + let x, isproj, imp, scopes, l = find_appl_head_data r in + (x,imp,scopes,l), isproj, args2 with Not_found -> (* Extra allowance for non globalizing functions *) if !interning_grammar || env.unb then - (GVar (loc,id), [], [], []),args + (GVar (loc,id), [], [], []), false, args else error_global_not_found_loc loc qid let interp_reference vars r = - let (r,_,_,_),_ = + let (r,_,_,_),_,_ = intern_applied_reference (fun _ -> error_not_enough_arguments Loc.ghost) {ids = Id.Set.empty; unb = false ; tmp_scope = None; scopes = []; impls = empty_internalization_env} [] @@ -1276,10 +1296,9 @@ let merge_impargs l args = let check_projection isproj nargs r = match (r,isproj) with - | GRef (loc, ref), Some _ -> + | GRef (loc, ref, _), Some _ -> (try - let n = Recordops.find_projection_nparams ref + 1 in - if not (Int.equal nargs n) then + if not (Int.equal nargs 1) then user_err_loc (loc,"",str "Projection does not have the right number of explicit parameters."); with Not_found -> user_err_loc @@ -1291,7 +1310,8 @@ let get_implicit_name n imps = Some (Impargs.name_of_implicit (List.nth imps (n-1))) let set_hole_implicit i b = function - | GRef (loc,r) | GApp (_,GRef (loc,r),_) -> (loc,Evar_kinds.ImplicitArg (r,i,b),None) + | GRef (loc,r,_) | GApp (_,GRef (loc,r,_),_) -> (loc,Evar_kinds.ImplicitArg (r,i,b),None) + | GProj (loc,p,_) -> (loc,Evar_kinds.ImplicitArg (ConstRef p,i,b),None) | GVar (loc,id) -> (loc,Evar_kinds.ImplicitArg (VarRef id,i,b),None) | _ -> anomaly (Pp.str "Only refs have implicits") @@ -1335,14 +1355,17 @@ let extract_explicit_arg imps args = (**********************************************************************) (* Main loop *) +let is_projection_ref env = function + | ConstRef c -> Environ.is_projection c env + | _ -> false + let internalize globalenv env allow_patvar lvar c = let rec intern env = function - | CRef ref as x -> - let (c,imp,subscopes,l),_ = + | CRef (ref,us) as x -> + let (c,imp,subscopes,l),isproj,_ = intern_applied_reference intern env (Environ.named_context globalenv) lvar [] ref in - (match intern_impargs c env imp subscopes l with - | [] -> c - | l -> GApp (constr_loc x, c, l)) + apply_impargs (None, isproj) c env imp subscopes l (constr_loc x) + | CFix (loc, (locid,iddef), dl) -> let lf = List.map (fun ((_, id),_,_,_,_) -> id) dl in let dl = Array.of_list dl in @@ -1435,33 +1458,35 @@ let internalize globalenv env allow_patvar lvar c = | CDelimiters (loc, key, e) -> intern {env with tmp_scope = None; scopes = find_delimiters_scope loc key :: env.scopes} e - | CAppExpl (loc, (isproj,ref), args) -> - let (f,_,args_scopes,_),args = + | CAppExpl (loc, (isproj,ref,us), args) -> + let (f,_,args_scopes,_),_,args = let args = List.map (fun a -> (a,None)) args in - intern_applied_reference intern env (Environ.named_context globalenv) lvar args ref in - check_projection isproj (List.length args) f; + intern_applied_reference intern env (Environ.named_context globalenv) + lvar args ref in + (* check_projection isproj (List.length args) f; *) (* Rem: GApp(_,f,[]) stands for @f *) - GApp (loc, f, intern_args env args_scopes (List.map fst args)) + GApp (loc, f, intern_args env args_scopes (List.map fst args)) + | CApp (loc, (isproj,f), args) -> let isproj,f,args = match f with (* Compact notations like "t.(f args') args" *) - | CApp (_,(Some _,f), args') when not (Option.has_some isproj) -> isproj,f,args'@args + | CApp (_,(Some _ as isproj',f), args') when not (Option.has_some isproj) -> + isproj',f,args'@args (* Don't compact "(f args') args" to resolve implicits separately *) | _ -> isproj,f,args in - let (c,impargs,args_scopes,l),args = + let (c,impargs,args_scopes,l),isprojf,args = match f with - | CRef ref -> intern_applied_reference intern env (Environ.named_context globalenv) lvar args ref + | CRef (ref,us) -> + intern_applied_reference intern env + (Environ.named_context globalenv) lvar args ref | CNotation (loc,ntn,([],[],[])) -> let c = intern_notation intern env lvar loc ntn ([],[],[]) in - find_appl_head_data c, args - | x -> (intern env f,[],[],[]), args in - let args = - intern_impargs c env impargs args_scopes (merge_impargs l args) in - check_projection isproj (List.length args) c; - (match c with - (* Now compact "(f args') args" *) - | GApp (loc', f', args') -> GApp (Loc.merge loc' loc, f',args'@args) - | _ -> GApp (loc, c, args)) + let x, isproj, impl, scopes, l = find_appl_head_data c in + (x,impl,scopes,l), false, args + | x -> (intern env f,[],[],[]), false, args in + apply_impargs (isproj,isprojf) c env impargs args_scopes + (merge_impargs l args) loc + | CRecord (loc, _, fs) -> let cargs = sort_fields true loc fs @@ -1472,7 +1497,7 @@ let internalize globalenv env allow_patvar lvar c = | None -> user_err_loc (loc, "intern", str"No constructor inference.") | Some (n, constrname, args) -> let pars = List.make n (CHole (loc, None, None)) in - let app = CAppExpl (loc, (None, constrname), List.rev_append pars args) in + let app = CAppExpl (loc, (None, constrname,None), List.rev_append pars args) in intern env app end | CCases (loc, sty, rtnpo, tms, eqns) -> @@ -1500,7 +1525,7 @@ let internalize globalenv env allow_patvar lvar c = | [] -> Option.map (intern_type env') rtnpo (* Only PatVar in "in" clauses *) | l -> let thevars,thepats=List.split l in Some ( - GCases(Loc.ghost,Term.RegularStyle,Some (GSort (Loc.ghost,GType None)), (* "return Type" *) + GCases(Loc.ghost,Term.RegularStyle,(* Some (GSort (Loc.ghost,GType None)) *)None, (* "return Type" *) List.map (fun id -> GVar (Loc.ghost,id),(Name id,None)) thevars, (* "match v1,..,vn" *) [Loc.ghost,[],thepats, (* "|p1,..,pn" *) Option.cata (intern_type env') (GHole(Loc.ghost,Evar_kinds.CasesType,None)) rtnpo; (* "=> P" is there were a P "=> _" else *) @@ -1599,7 +1624,7 @@ let internalize globalenv env allow_patvar lvar c = (* the "as" part *) let extra_id,na = match tm', na with | GVar (loc,id), None when not (Id.Map.mem id (snd lvar)) -> Some id,(loc,Name id) - | GRef (loc, VarRef id), None -> Some id,(loc,Name id) + | GRef (loc, VarRef id, _), None -> Some id,(loc,Name id) | _, None -> None,(Loc.ghost,Anonymous) | _, Some (loc,na) -> None,(loc,na) in (* the "in" part *) @@ -1691,6 +1716,41 @@ let internalize globalenv env allow_patvar lvar c = intern_args env subscopes rargs in aux 1 l subscopes eargs rargs + and make_first_explicit (l, r) = + match r with + | hd :: tl -> l, None :: tl + | [] -> l, [] + + and apply_impargs (isproj,isprojf) c env imp subscopes l loc = + let l = + let imp = + if isprojf && isproj <> None then + (* Drop first implicit which corresponds to record given in c.(p) notation *) + List.map make_first_explicit imp + else imp + in intern_impargs c env imp subscopes l + in + if isprojf then + match c, l with + | GApp (loc', GRef (loc'', ConstRef f, _), hd :: tl), rest -> + let proj = GProj (Loc.merge loc'' (loc_of_glob_constr hd), f, hd) in + if List.is_empty tl then smart_gapp proj loc rest + else GApp (loc, proj, tl @ rest) + | GRef (loc', ConstRef f, _), hd :: tl -> + let proj = GProj (Loc.merge loc' (loc_of_glob_constr hd), f, hd) in + smart_gapp proj loc tl + | _ -> user_err_loc (loc, "apply_impargs", + str"Projection is not applied to enough arguments") + else + (* check_projection isproj *) + smart_gapp c loc l + + and smart_gapp f loc = function + | [] -> f + | l -> match f with + | GApp (loc', g, args) -> GApp (Loc.merge loc' loc, g, args@l) + | _ -> GApp (Loc.merge (loc_of_glob_constr f) loc, f, l) + and intern_args env subscopes = function | [] -> [] | a::args -> @@ -1871,7 +1931,7 @@ let interp_rawcontext_evars evdref env bl = (push_rel d env, d::params, succ n, impls) | Some b -> let c = understand_judgment_tcc evdref env b in - let d = (na, Some c.uj_val, Termops.refresh_universes c.uj_type) in + let d = (na, Some c.uj_val, c.uj_type) in (push_rel d env, d::params, succ n, impls)) (env,[],1,[]) (List.rev bl) in (env, par), impls diff --git a/interp/constrintern.mli b/interp/constrintern.mli index a0bcdc4f4..9ce6ec779 100644 --- a/interp/constrintern.mli +++ b/interp/constrintern.mli @@ -91,13 +91,13 @@ val intern_context : bool -> env -> internalization_env -> local_binder list -> (** Main interpretation functions expecting evars to be all resolved *) val interp_constr : evar_map -> env -> ?impls:internalization_env -> - constr_expr -> constr + constr_expr -> constr Univ.in_universe_context_set val interp_casted_constr : evar_map -> env -> ?impls:internalization_env -> - constr_expr -> types -> constr + constr_expr -> types -> constr Univ.in_universe_context_set val interp_type : evar_map -> env -> ?impls:internalization_env -> - constr_expr -> types + constr_expr -> types Univ.in_universe_context_set (** Main interpretation function expecting evars to be all resolved *) @@ -142,7 +142,7 @@ val interp_reference : ltac_sign -> reference -> glob_constr (** Interpret binders *) -val interp_binder : evar_map -> env -> Name.t -> constr_expr -> types +val interp_binder : evar_map -> env -> Name.t -> constr_expr -> types Univ.in_universe_context_set val interp_binder_evars : evar_map ref -> env -> Name.t -> constr_expr -> types @@ -153,6 +153,16 @@ val interp_context_evars : evar_map ref -> env -> local_binder list -> internalization_env * ((env * rel_context) * Impargs.manual_implicits) +(* val interp_context_gen : (env -> glob_constr -> unsafe_type_judgment Evd.in_evar_universe_context) -> *) +(* (env -> Evarutil.type_constraint -> glob_constr -> unsafe_judgment Evd.in_evar_universe_context) -> *) +(* ?global_level:bool -> ?impl_env:internalization_env -> *) +(* evar_map -> env -> local_binder list -> internalization_env * ((env * Evd.evar_universe_context * rel_context * sorts list) * Impargs.manual_implicits) *) + +(* val interp_context : ?global_level:bool -> ?impl_env:internalization_env -> *) +(* evar_map -> env -> local_binder list -> *) +(* internalization_env * *) +(* ((env * Evd.evar_universe_context * rel_context * sorts list) * Impargs.manual_implicits) *) + (** Locating references of constructions, possibly via a syntactic definition (these functions do not modify the glob file) *) diff --git a/interp/coqlib.ml b/interp/coqlib.ml index bf5d225b2..3df071aff 100644 --- a/interp/coqlib.ml +++ b/interp/coqlib.ml @@ -32,7 +32,7 @@ let find_reference locstr dir s = anomaly ~label:locstr (str "cannot find " ++ Libnames.pr_path sp) let coq_reference locstr dir s = find_reference locstr (coq::dir) s -let coq_constant locstr dir s = constr_of_global (coq_reference locstr dir s) +let coq_constant locstr dir s = Universes.constr_of_global (coq_reference locstr dir s) let gen_reference = coq_reference let gen_constant = coq_constant @@ -44,7 +44,7 @@ let has_suffix_in_dirs dirs ref = let global_of_extended q = try Some (global_of_extended_global q) with Not_found -> None -let gen_constant_in_modules locstr dirs s = +let gen_reference_in_modules locstr dirs s = let dirs = List.map make_dir dirs in let qualid = qualid_of_string s in let all = Nametab.locate_extended_all qualid in @@ -52,7 +52,7 @@ let gen_constant_in_modules locstr dirs s = let all = List.sort_uniquize RefOrdered_env.compare all in let these = List.filter (has_suffix_in_dirs dirs) all in match these with - | [x] -> constr_of_global x + | [x] -> x | [] -> anomaly ~label:locstr (str ("cannot find "^s^ " in module"^(if List.length dirs > 1 then "s " else " ")) ++ @@ -65,6 +65,9 @@ let gen_constant_in_modules locstr dirs s = str (" in module"^(if List.length dirs > 1 then "s " else " ")) ++ prlist_with_sep pr_comma pr_dirpath dirs) +let gen_constant_in_modules locstr dirs s = + Universes.constr_of_global (gen_reference_in_modules locstr dirs s) + (* For tactics/commands requiring vernacular libraries *) @@ -100,6 +103,10 @@ let logic_constant dir s = let d = "Logic"::dir in check_required_library (coq::d); gen_constant "Coqlib" d s +let logic_reference dir s = + let d = "Logic"::dir in + check_required_library ("Coq"::d); gen_reference "Coqlib" d s + let arith_dir = [coq;"Arith"] let arith_modules = [arith_dir] @@ -144,10 +151,14 @@ let make_con dir id = Globnames.encode_con dir (Id.of_string id) (** Identity *) -let id = make_con datatypes_module "id" -let type_of_id = make_con datatypes_module "ID" +let id = make_con datatypes_module "idProp" +let type_of_id = make_con datatypes_module "IDProp" -let _ = Termops.set_impossible_default_clause (mkConst id,mkConst type_of_id) +let _ = Termops.set_impossible_default_clause + (fun () -> + let c, ctx = Universes.fresh_global_instance (Global.env()) (ConstRef id) in + let (_, u) = destConst c in + (c,mkConstU (type_of_id,u)), ctx) (** Natural numbers *) let nat_kn = make_ind datatypes_module "nat" @@ -181,11 +192,11 @@ let jmeq_kn = make_ind jmeq_module "JMeq" let glob_jmeq = IndRef (jmeq_kn,0) type coq_sigma_data = { - proj1 : constr; - proj2 : constr; - elim : constr; - intro : constr; - typ : constr } + proj1 : global_reference; + proj2 : global_reference; + elim : global_reference; + intro : global_reference; + typ : global_reference } type coq_bool_data = { andb : constr; @@ -200,56 +211,58 @@ let build_bool_type () = let build_sigma_set () = anomaly (Pp.str "Use build_sigma_type") let build_sigma_type () = - { proj1 = init_constant ["Specif"] "projT1"; - proj2 = init_constant ["Specif"] "projT2"; - elim = init_constant ["Specif"] "sigT_rect"; - intro = init_constant ["Specif"] "existT"; - typ = init_constant ["Specif"] "sigT" } + { proj1 = init_reference ["Specif"] "projT1"; + proj2 = init_reference ["Specif"] "projT2"; + elim = init_reference ["Specif"] "sigT_rect"; + intro = init_reference ["Specif"] "existT"; + typ = init_reference ["Specif"] "sigT" } let build_sigma () = - { proj1 = init_constant ["Specif"] "proj1_sig"; - proj2 = init_constant ["Specif"] "proj2_sig"; - elim = init_constant ["Specif"] "sig_rect"; - intro = init_constant ["Specif"] "exist"; - typ = init_constant ["Specif"] "sig" } + { proj1 = init_reference ["Specif"] "proj1_sig"; + proj2 = init_reference ["Specif"] "proj2_sig"; + elim = init_reference ["Specif"] "sig_rect"; + intro = init_reference ["Specif"] "exist"; + typ = init_reference ["Specif"] "sig" } + let build_prod () = - { proj1 = init_constant ["Datatypes"] "fst"; - proj2 = init_constant ["Datatypes"] "snd"; - elim = init_constant ["Datatypes"] "prod_rec"; - intro = init_constant ["Datatypes"] "pair"; - typ = init_constant ["Datatypes"] "prod" } + { proj1 = init_reference ["Datatypes"] "fst"; + proj2 = init_reference ["Datatypes"] "snd"; + elim = init_reference ["Datatypes"] "prod_rec"; + intro = init_reference ["Datatypes"] "pair"; + typ = init_reference ["Datatypes"] "prod" } (* Equalities *) type coq_eq_data = { - eq : constr; - ind : constr; - refl : constr; - sym : constr; - trans: constr; - congr: constr } + eq : global_reference; + ind : global_reference; + refl : global_reference; + sym : global_reference; + trans: global_reference; + congr: global_reference } (* Data needed for discriminate and injection *) type coq_inversion_data = { - inv_eq : constr; (* : forall params, t -> Prop *) - inv_ind : constr; (* : forall params P y, eq params y -> P y *) - inv_congr: constr (* : forall params B (f:t->B) y, eq params y -> f c=f y *) + inv_eq : global_reference; (* : forall params, t -> Prop *) + inv_ind : global_reference; (* : forall params P y, eq params y -> P y *) + inv_congr: global_reference (* : forall params B (f:t->B) y, eq params y -> f c=f y *) } +let lazy_init_reference dir id = lazy (init_reference dir id) let lazy_init_constant dir id = lazy (init_constant dir id) -let lazy_logic_constant dir id = lazy (logic_constant dir id) +let lazy_logic_reference dir id = lazy (logic_reference dir id) (* Leibniz equality on Type *) -let coq_eq_eq = lazy_init_constant ["Logic"] "eq" -let coq_eq_refl = lazy_init_constant ["Logic"] "eq_refl" -let coq_eq_ind = lazy_init_constant ["Logic"] "eq_ind" -let coq_eq_congr = lazy_init_constant ["Logic"] "f_equal" -let coq_eq_sym = lazy_init_constant ["Logic"] "eq_sym" -let coq_eq_trans = lazy_init_constant ["Logic"] "eq_trans" -let coq_f_equal2 = lazy_init_constant ["Logic"] "f_equal2" +let coq_eq_eq = lazy_init_reference ["Logic"] "eq" +let coq_eq_refl = lazy_init_reference ["Logic"] "eq_refl" +let coq_eq_ind = lazy_init_reference ["Logic"] "eq_ind" +let coq_eq_congr = lazy_init_reference ["Logic"] "f_equal" +let coq_eq_sym = lazy_init_reference ["Logic"] "eq_sym" +let coq_eq_trans = lazy_init_reference ["Logic"] "eq_trans" +let coq_f_equal2 = lazy_init_reference ["Logic"] "f_equal2" let coq_eq_congr_canonical = - lazy_init_constant ["Logic"] "f_equal_canonical_form" + lazy_init_reference ["Logic"] "f_equal_canonical_form" let build_coq_eq_data () = let _ = check_required_library logic_module_name in { @@ -260,6 +273,9 @@ let build_coq_eq_data () = trans = Lazy.force coq_eq_trans; congr = Lazy.force coq_eq_congr } +let make_dirpath dir = + Names.make_dirpath (List.map id_of_string dir) + let build_coq_eq () = Lazy.force coq_eq_eq let build_coq_eq_refl () = Lazy.force coq_eq_refl let build_coq_eq_sym () = Lazy.force coq_eq_sym @@ -273,14 +289,15 @@ let build_coq_inversion_eq_data () = (* Heterogenous equality on Type *) -let coq_jmeq_eq = lazy_logic_constant ["JMeq"] "JMeq" -let coq_jmeq_refl = lazy_logic_constant ["JMeq"] "JMeq_refl" -let coq_jmeq_ind = lazy_logic_constant ["JMeq"] "JMeq_ind" -let coq_jmeq_sym = lazy_logic_constant ["JMeq"] "JMeq_sym" -let coq_jmeq_congr = lazy_logic_constant ["JMeq"] "JMeq_congr" -let coq_jmeq_trans = lazy_logic_constant ["JMeq"] "JMeq_trans" +let coq_jmeq_eq = lazy_logic_reference ["JMeq"] "JMeq" +let coq_jmeq_hom = lazy_logic_reference ["JMeq"] "JMeq_hom" +let coq_jmeq_refl = lazy_logic_reference ["JMeq"] "JMeq_refl" +let coq_jmeq_ind = lazy_logic_reference ["JMeq"] "JMeq_ind" +let coq_jmeq_sym = lazy_logic_reference ["JMeq"] "JMeq_sym" +let coq_jmeq_congr = lazy_logic_reference ["JMeq"] "JMeq_congr" +let coq_jmeq_trans = lazy_logic_reference ["JMeq"] "JMeq_trans" let coq_jmeq_congr_canonical = - lazy_logic_constant ["JMeq"] "JMeq_congr_canonical_form" + lazy_logic_reference ["JMeq"] "JMeq_congr_canonical_form" let build_coq_jmeq_data () = let _ = check_required_library jmeq_module_name in { @@ -291,14 +308,9 @@ let build_coq_jmeq_data () = trans = Lazy.force coq_jmeq_trans; congr = Lazy.force coq_jmeq_congr } -let join_jmeq_types eq = - mkLambda(Name (Id.of_string "A"),Termops.new_Type(), - mkLambda(Name (Id.of_string "x"),mkRel 1, - mkApp (eq,[|mkRel 2;mkRel 1;mkRel 2|]))) - let build_coq_inversion_jmeq_data () = let _ = check_required_library logic_module_name in { - inv_eq = join_jmeq_types (Lazy.force coq_jmeq_eq); + inv_eq = Lazy.force coq_jmeq_hom; inv_ind = Lazy.force coq_jmeq_ind; inv_congr = Lazy.force coq_jmeq_congr_canonical } @@ -308,13 +320,13 @@ let coq_sumbool = lazy_init_constant ["Specif"] "sumbool" let build_coq_sumbool () = Lazy.force coq_sumbool (* Equality on Type as a Type *) -let coq_identity_eq = lazy_init_constant ["Datatypes"] "identity" -let coq_identity_refl = lazy_init_constant ["Datatypes"] "identity_refl" -let coq_identity_ind = lazy_init_constant ["Datatypes"] "identity_ind" -let coq_identity_congr = lazy_init_constant ["Logic_Type"] "identity_congr" -let coq_identity_sym = lazy_init_constant ["Logic_Type"] "identity_sym" -let coq_identity_trans = lazy_init_constant ["Logic_Type"] "identity_trans" -let coq_identity_congr_canonical = lazy_init_constant ["Logic_Type"] "identity_congr_canonical_form" +let coq_identity_eq = lazy_init_reference ["Datatypes"] "identity" +let coq_identity_refl = lazy_init_reference ["Datatypes"] "identity_refl" +let coq_identity_ind = lazy_init_reference ["Datatypes"] "identity_ind" +let coq_identity_congr = lazy_init_reference ["Logic_Type"] "identity_congr" +let coq_identity_sym = lazy_init_reference ["Logic_Type"] "identity_sym" +let coq_identity_trans = lazy_init_reference ["Logic_Type"] "identity_trans" +let coq_identity_congr_canonical = lazy_init_reference ["Logic_Type"] "identity_congr_canonical_form" let build_coq_identity_data () = let _ = check_required_library datatypes_module_name in { @@ -333,9 +345,9 @@ let build_coq_inversion_identity_data () = inv_congr = Lazy.force coq_identity_congr_canonical } (* Equality to true *) -let coq_eq_true_eq = lazy_init_constant ["Datatypes"] "eq_true" -let coq_eq_true_ind = lazy_init_constant ["Datatypes"] "eq_true_ind" -let coq_eq_true_congr = lazy_init_constant ["Logic"] "eq_true_congr" +let coq_eq_true_eq = lazy_init_reference ["Datatypes"] "eq_true" +let coq_eq_true_ind = lazy_init_reference ["Datatypes"] "eq_true_ind" +let coq_eq_true_congr = lazy_init_reference ["Logic"] "eq_true_congr" let build_coq_inversion_eq_true_data () = let _ = check_required_library datatypes_module_name in diff --git a/interp/coqlib.mli b/interp/coqlib.mli index 9b0f8deb9..d253cf7dd 100644 --- a/interp/coqlib.mli +++ b/interp/coqlib.mli @@ -42,6 +42,7 @@ val gen_reference : message -> string list -> string -> global_reference (** Search in several modules (not prefixed by "Coq") *) val gen_constant_in_modules : string->string list list-> string -> constr +val gen_reference_in_modules : string->string list list-> string -> global_reference val arith_modules : string list list val zarith_base_modules : string list list val init_modules : string list list @@ -101,43 +102,49 @@ val build_bool_type : coq_bool_data delayed (** {6 For Equality tactics } *) type coq_sigma_data = { - proj1 : constr; - proj2 : constr; - elim : constr; - intro : constr; - typ : constr } + proj1 : global_reference; + proj2 : global_reference; + elim : global_reference; + intro : global_reference; + typ : global_reference } val build_sigma_set : coq_sigma_data delayed val build_sigma_type : coq_sigma_data delayed val build_sigma : coq_sigma_data delayed +(* val build_sigma_type_in : Environ.env -> coq_sigma_data Univ.in_universe_context_set *) +(* val build_sigma_in : Environ.env -> coq_sigma_data Univ.in_universe_context_set *) +(* val build_prod_in : Environ.env -> coq_sigma_data Univ.in_universe_context_set *) +(* val build_coq_eq_data_in : Environ.env -> coq_eq_data Univ.in_universe_context_set *) + (** Non-dependent pairs in Set from Datatypes *) val build_prod : coq_sigma_data delayed type coq_eq_data = { - eq : constr; - ind : constr; - refl : constr; - sym : constr; - trans: constr; - congr: constr } + eq : global_reference; + ind : global_reference; + refl : global_reference; + sym : global_reference; + trans: global_reference; + congr: global_reference } val build_coq_eq_data : coq_eq_data delayed + val build_coq_identity_data : coq_eq_data delayed val build_coq_jmeq_data : coq_eq_data delayed -val build_coq_eq : constr delayed (** = [(build_coq_eq_data()).eq] *) -val build_coq_eq_refl : constr delayed (** = [(build_coq_eq_data()).refl] *) -val build_coq_eq_sym : constr delayed (** = [(build_coq_eq_data()).sym] *) -val build_coq_f_equal2 : constr delayed +val build_coq_eq : global_reference delayed (** = [(build_coq_eq_data()).eq] *) +val build_coq_eq_refl : global_reference delayed (** = [(build_coq_eq_data()).refl] *) +val build_coq_eq_sym : global_reference delayed (** = [(build_coq_eq_data()).sym] *) +val build_coq_f_equal2 : global_reference delayed (** Data needed for discriminate and injection *) type coq_inversion_data = { - inv_eq : constr; (** : forall params, args -> Prop *) - inv_ind : constr; (** : forall params P (H : P params) args, eq params args + inv_eq : global_reference; (** : forall params, args -> Prop *) + inv_ind : global_reference; (** : forall params P (H : P params) args, eq params args -> P args *) - inv_congr: constr (** : forall params B (f:t->B) args, eq params args -> + inv_congr: global_reference (** : forall params B (f:t->B) args, eq params args -> f params = f args *) } diff --git a/interp/dumpglob.ml b/interp/dumpglob.ml index ca5b0eddd..80b5830fd 100644 --- a/interp/dumpglob.ml +++ b/interp/dumpglob.ml @@ -110,7 +110,7 @@ let type_of_global_ref gr = "var" ^ type_of_logical_kind (Decls.variable_kind v) | Globnames.IndRef ind -> let (mib,oib) = Inductive.lookup_mind_specif (Global.env ()) ind in - if mib.Declarations.mind_record then + if mib.Declarations.mind_record <> None then if mib.Declarations.mind_finite then "rec" else "corec" else if mib.Declarations.mind_finite then "ind" diff --git a/interp/implicit_quantifiers.ml b/interp/implicit_quantifiers.ml index 2d55a6b63..c69eb629d 100644 --- a/interp/implicit_quantifiers.ml +++ b/interp/implicit_quantifiers.ml @@ -90,8 +90,8 @@ let free_vars_of_constr_expr c ?(bound=Id.Set.empty) l = else l in let rec aux bdvars l c = match c with - | CRef (Ident (loc,id)) -> found loc id bdvars l - | CNotation (_, "{ _ : _ | _ }", (CRef (Ident (_, id)) :: _, [], [])) when not (Id.Set.mem id bdvars) -> + | CRef (Ident (loc,id),_) -> found loc id bdvars l + | CNotation (_, "{ _ : _ | _ }", (CRef (Ident (_, id),_) :: _, [], [])) when not (Id.Set.mem id bdvars) -> Topconstr.fold_constr_expr_with_binders (fun a l -> Id.Set.add a l) aux (Id.Set.add id bdvars) l c | c -> Topconstr.fold_constr_expr_with_binders (fun a l -> Id.Set.add a l) aux bdvars l c in aux bound l c @@ -127,6 +127,7 @@ let generalizable_vars_of_glob_constr ?(bound=Id.Set.empty) ?(allowed=Id.Set.emp else (id, loc) :: vs else vs | GApp (loc,f,args) -> List.fold_left (vars bound) vs (f::args) + | GProj (loc,p,c) -> vars bound vs c | GLambda (loc,na,_,ty,c) | GProd (loc,na,_,ty,c) | GLetIn (loc,na,ty,c) -> let vs' = vars bound vs ty in let bound' = add_name_to_ids bound na in @@ -241,19 +242,19 @@ let combine_params avoid fn applied needed = let combine_params_freevar = fun avoid (_, (na, _, _)) -> let id' = next_name_away_from na avoid in - (CRef (Ident (Loc.ghost, id')), Id.Set.add id' avoid) + (CRef (Ident (Loc.ghost, id'),None), Id.Set.add id' avoid) let destClassApp cl = match cl with - | CApp (loc, (None, CRef ref), l) -> loc, ref, List.map fst l - | CAppExpl (loc, (None, ref), l) -> loc, ref, l - | CRef ref -> loc_of_reference ref, ref, [] + | CApp (loc, (None, CRef (ref,_)), l) -> loc, ref, List.map fst l + | CAppExpl (loc, (None, ref,_), l) -> loc, ref, l + | CRef (ref,_) -> loc_of_reference ref, ref, [] | _ -> raise Not_found let destClassAppExpl cl = match cl with - | CApp (loc, (None, CRef ref), l) -> loc, ref, l - | CRef ref -> loc_of_reference ref, ref, [] + | CApp (loc, (None, CRef (ref,_)), l) -> loc, ref, l + | CRef (ref,_) -> loc_of_reference ref, ref, [] | _ -> raise Not_found let implicit_application env ?(allow_partial=true) f ty = @@ -285,7 +286,7 @@ let implicit_application env ?(allow_partial=true) f ty = end; let pars = List.rev (List.combine ci rd) in let args, avoid = combine_params avoid f par pars in - CAppExpl (loc, (None, id), args), avoid + CAppExpl (loc, (None, id, None), args), avoid in c, avoid let implicits_of_glob_constr ?(with_products=true) l = diff --git a/interp/modintern.ml b/interp/modintern.ml index 81d0a0f64..2d81194f2 100644 --- a/interp/modintern.ml +++ b/interp/modintern.ml @@ -61,7 +61,7 @@ let transl_with_decl env = function | CWith_Module ((_,fqid),qid) -> WithMod (fqid,lookup_module qid) | CWith_Definition ((_,fqid),c) -> - WithDef (fqid,interp_constr Evd.empty env c) + WithDef (fqid,fst (interp_constr Evd.empty env c)) (*FIXME*) let loc_of_module = function | CMident (loc,_) | CMapply (loc,_,_) | CMwith (loc,_,_) -> loc diff --git a/interp/notation.ml b/interp/notation.ml index 6e5ac5f33..6fd6001f4 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -258,12 +258,12 @@ let notations_key_table = ref (KeyMap.empty : notation_rule list KeyMap.t) let prim_token_key_table = ref KeyMap.empty let glob_prim_constr_key = function - | GApp (_,GRef (_,ref),_) | GRef (_,ref) -> RefKey (canonical_gr ref) + | GApp (_,GRef (_,ref,_),_) | GRef (_,ref,_) -> RefKey (canonical_gr ref) | _ -> Oth let glob_constr_keys = function - | GApp (_,GRef (_,ref),_) -> [RefKey (canonical_gr ref); Oth] - | GRef (_,ref) -> [RefKey (canonical_gr ref)] + | GApp (_,GRef (_,ref,_),_) -> [RefKey (canonical_gr ref); Oth] + | GRef (_,ref,_) -> [RefKey (canonical_gr ref)] | _ -> [Oth] let cases_pattern_key = function @@ -455,8 +455,8 @@ let interp_prim_token = let rec rcp_of_glob looked_for = function | GVar (loc,id) -> RCPatAtom (loc,Some id) | GHole (loc,_,_) -> RCPatAtom (loc,None) - | GRef (loc,g) -> looked_for g; RCPatCstr (loc, g,[],[]) - | GApp (loc,GRef (_,g),l) -> + | GRef (loc,g,_) -> looked_for g; RCPatCstr (loc, g,[],[]) + | GApp (loc,GRef (_,g,_),l) -> looked_for g; RCPatCstr (loc, g, List.map (rcp_of_glob looked_for) l,[]) | _ -> raise Not_found @@ -502,7 +502,7 @@ let uninterp_prim_token_ind_pattern ind args = if not b then raise Notation_ops.No_match; let args' = List.map (fun x -> snd (glob_constr_of_closed_cases_pattern x)) args in - let ref = GRef (Loc.ghost,ref) in + let ref = GRef (Loc.ghost,ref,None) in match numpr (GApp (Loc.ghost,ref,args')) with | None -> raise Notation_ops.No_match | Some n -> (sc,n) @@ -655,13 +655,13 @@ let rebuild_arguments_scope (req,r,l,_) = match req with | ArgsScopeNoDischarge -> assert false | ArgsScopeAuto -> - let scs,cls = compute_arguments_scope_full (Global.type_of_global r) in + let scs,cls = compute_arguments_scope_full (fst(Universes.type_of_global r)(*FIXME?*)) in (req,r,scs,cls) | ArgsScopeManual -> (* Add to the manually given scopes the one found automatically for the extra parameters of the section. Discard the classes of the manually given scopes to avoid further re-computations. *) - let l',cls = compute_arguments_scope_full (Global.type_of_global r) in + let l',cls = compute_arguments_scope_full (Global.type_of_global_unsafe r) in let nparams = List.length l' - List.length l in let l1 = List.firstn nparams l' in let cls1 = List.firstn nparams cls in @@ -705,7 +705,7 @@ let find_arguments_scope r = with Not_found -> [] let declare_ref_arguments_scope ref = - let t = Global.type_of_global ref in + let t = Global.type_of_global_unsafe ref in declare_arguments_scope_gen ArgsScopeAuto ref (compute_arguments_scope_full t) diff --git a/interp/notation_ops.ml b/interp/notation_ops.ml index 12b256c45..4984bfc38 100644 --- a/interp/notation_ops.ml +++ b/interp/notation_ops.ml @@ -55,6 +55,7 @@ let ldots_var = Id.of_string ".." let glob_constr_of_notation_constr_with_binders loc g f e = function | NVar id -> GVar (loc,id) | NApp (a,args) -> GApp (loc,f e a, List.map (f e) args) + | NProj (p,c) -> GProj (loc,p,f e c) | NList (x,y,iter,tail,swap) -> let t = f e tail in let it = f e iter in let innerl = (ldots_var,t)::(if swap then [] else [x,GVar(loc,y)]) in @@ -106,7 +107,7 @@ let glob_constr_of_notation_constr_with_binders loc g f e = function | NSort x -> GSort (loc,x) | NHole (x, arg) -> GHole (loc, x, arg) | NPatVar n -> GPatVar (loc,(false,n)) - | NRef x -> GRef (loc,x) + | NRef x -> GRef (loc,x,None) let glob_constr_of_notation_constr loc x = let rec aux () x = @@ -146,9 +147,10 @@ let split_at_recursive_part c = let on_true_do b f c = if b then (f c; b) else b let compare_glob_constr f add t1 t2 = match t1,t2 with - | GRef (_,r1), GRef (_,r2) -> eq_gr r1 r2 + | GRef (_,r1,_), GRef (_,r2,_) -> eq_gr r1 r2 | GVar (_,v1), GVar (_,v2) -> on_true_do (Id.equal v1 v2) add (Name v1) | GApp (_,f1,l1), GApp (_,f2,l2) -> f f1 f2 && List.for_all2eq f l1 l2 + | GProj (_,p1,c1), GProj (_, p2, c2) -> eq_constant p1 p2 && f c1 c2 | GLambda (_,na1,bk1,ty1,c1), GLambda (_,na2,bk2,ty2,c2) when Name.equal na1 na2 && Constrexpr_ops.binding_kind_eq bk1 bk2 -> on_true_do (f ty1 ty2 && f c1 c2) add na1 @@ -164,7 +166,7 @@ let compare_glob_constr f add t1 t2 = match t1,t2 with | _,(GCases _ | GRec _ | GPatVar _ | GEvar _ | GLetTuple _ | GIf _ | GCast _) -> error "Unsupported construction in recursive notations." - | (GRef _ | GVar _ | GApp _ | GLambda _ | GProd _ + | (GRef _ | GVar _ | GApp _ | GProj _ | GLambda _ | GProd _ | GHole _ | GSort _ | GLetIn _), _ -> false @@ -259,6 +261,7 @@ let notation_constr_and_vars_of_glob_constr a = and aux' = function | GVar (_,id) -> add_id found id; NVar id | GApp (_,g,args) -> NApp (aux g, List.map aux args) + | GProj (_,p,c) -> NProj (p, aux c) | GLambda (_,na,bk,ty,c) -> add_name found na; NLambda (na,aux ty,aux c) | GProd (_,na,bk,ty,c) -> add_name found na; NProd (na,aux ty,aux c) | GLetIn (_,na,b,c) -> add_name found na; NLetIn (na,aux b,aux c) @@ -288,7 +291,7 @@ let notation_constr_and_vars_of_glob_constr a = | GCast (_,c,k) -> NCast (aux c,Miscops.map_cast_type aux k) | GSort (_,s) -> NSort s | GHole (_,w,arg) -> NHole (w, arg) - | GRef (_,r) -> NRef r + | GRef (_,r,_) -> NRef r | GPatVar (_,(_,n)) -> NPatVar n | GEvar _ -> error "Existential variables not allowed in notations." @@ -365,7 +368,7 @@ let rec subst_pat subst pat = match pat with | PatVar _ -> pat | PatCstr (loc,((kn,i),j),cpl,n) -> - let kn' = subst_ind subst kn + let kn' = subst_mind subst kn and cpl' = List.smartmap (subst_pat subst) cpl in if kn' == kn && cpl' == cpl then pat else PatCstr (loc,((kn',i),j),cpl',n) @@ -385,6 +388,12 @@ let rec subst_notation_constr subst bound raw = if r' == r && rl' == rl then raw else NApp(r',rl') + | NProj (p,c) -> + let p' = subst_constant subst p in + let c' = subst_notation_constr subst bound c in + if p == p' && c == c' then raw else + NProj (p',c') + | NList (id1,id2,r1,r2,b) -> let r1' = subst_notation_constr subst bound r1 and r2' = subst_notation_constr subst bound r2 in @@ -421,7 +430,7 @@ let rec subst_notation_constr subst bound raw = (fun (a,(n,signopt) as x) -> let a' = subst_notation_constr subst bound a in let signopt' = Option.map (fun ((indkn,i),nal as z) -> - let indkn' = subst_ind subst indkn in + let indkn' = subst_mind subst indkn in if indkn == indkn' then z else ((indkn',i),nal)) signopt in if a' == a && signopt' == signopt then x else (a',(n,signopt'))) rl @@ -658,7 +667,7 @@ let rec match_ inner u alp (tmetas,blmetas as metas) sigma a1 a2 = (* Matching compositionally *) | GVar (_,id1), NVar id2 when alpha_var id1 id2 alp -> sigma - | GRef (_,r1), NRef r2 when (eq_gr r1 r2) -> sigma + | GRef (_,r1,_), NRef r2 when (eq_gr r1 r2) -> sigma | GPatVar (_,(_,n1)), NPatVar n2 when Id.equal n1 n2 -> sigma | GApp (loc,f1,l1), NApp (f2,l2) -> let n1 = List.length l1 and n2 = List.length l2 in diff --git a/interp/topconstr.ml b/interp/topconstr.ml index cea506059..b043f3d42 100644 --- a/interp/topconstr.ml +++ b/interp/topconstr.ml @@ -101,7 +101,7 @@ let rec fold_local_binders g f n acc b = function f n acc b let fold_constr_expr_with_binders g f n acc = function - | CAppExpl (loc,(_,_),l) -> List.fold_left (f n) acc l + | CAppExpl (loc,(_,_,_),l) -> List.fold_left (f n) acc l | CApp (loc,(_,t),l) -> List.fold_left (f n) (f n acc t) (List.map fst l) | CProdN (_,l,b) | CLambdaN (_,l,b) -> fold_constr_expr_binders g f n acc b l | CLetIn (_,na,a,b) -> fold_constr_expr_binders g f n acc b [[na],default_binder_kind,a] @@ -141,7 +141,7 @@ let fold_constr_expr_with_binders g f n acc = function let free_vars_of_constr_expr c = let rec aux bdvars l = function - | CRef (Ident (_,id)) -> if Id.List.mem id bdvars then l else Id.Set.add id l + | CRef (Ident (_,id),_) -> if Id.List.mem id bdvars then l else Id.Set.add id l | c -> fold_constr_expr_with_binders (fun a l -> a::l) aux bdvars l c in aux [] Id.Set.empty c @@ -250,8 +250,8 @@ let map_constr_expr_with_binders g f e = function (* Used in constrintern *) let rec replace_vars_constr_expr l = function - | CRef (Ident (loc,id)) as x -> - (try CRef (Ident (loc,Id.Map.find id l)) with Not_found -> x) + | CRef (Ident (loc,id),us) as x -> + (try CRef (Ident (loc,Id.Map.find id l),us) with Not_found -> x) | c -> map_constr_expr_with_binders Id.Map.remove replace_vars_constr_expr l c diff --git a/intf/constrexpr.mli b/intf/constrexpr.mli index 64bbd1e83..af6aea164 100644 --- a/intf/constrexpr.mli +++ b/intf/constrexpr.mli @@ -62,13 +62,13 @@ and cases_pattern_notation_substitution = cases_pattern_expr list list (** for recursive notations *) type constr_expr = - | CRef of reference + | CRef of reference * Univ.universe_instance option | CFix of Loc.t * Id.t located * fix_expr list | CCoFix of Loc.t * Id.t located * cofix_expr list | CProdN of Loc.t * binder_expr list * constr_expr | CLambdaN of Loc.t * binder_expr list * constr_expr | CLetIn of Loc.t * Name.t located * constr_expr * constr_expr - | CAppExpl of Loc.t * (proj_flag * reference) * constr_expr list + | CAppExpl of Loc.t * (proj_flag * reference * Univ.universe_instance option) * constr_expr list | CApp of Loc.t * (proj_flag * constr_expr) * (constr_expr * explicitation located option) list | CRecord of Loc.t * constr_expr option * (reference * constr_expr) list diff --git a/intf/decl_kinds.mli b/intf/decl_kinds.mli index 7111fd055..2ed776c2d 100644 --- a/intf/decl_kinds.mli +++ b/intf/decl_kinds.mli @@ -12,6 +12,8 @@ type locality = Discharge | Local | Global type binding_kind = Explicit | Implicit +type polymorphic = bool + type theorem_kind = | Theorem | Lemma @@ -45,9 +47,9 @@ type assumption_object_kind = Definitional | Logical | Conjectural Logical | Hypothesis | Axiom *) -type assumption_kind = locality * assumption_object_kind +type assumption_kind = locality * polymorphic * assumption_object_kind -type definition_kind = locality * definition_object_kind +type definition_kind = locality * polymorphic * definition_object_kind (** Kinds used in proofs *) @@ -55,7 +57,7 @@ type goal_object_kind = | DefinitionBody of definition_object_kind | Proof of theorem_kind -type goal_kind = locality * goal_object_kind +type goal_kind = locality * polymorphic * goal_object_kind (** Kinds used in library *) diff --git a/intf/glob_term.mli b/intf/glob_term.mli index 1d200ca79..d07766e18 100644 --- a/intf/glob_term.mli +++ b/intf/glob_term.mli @@ -28,7 +28,7 @@ type cases_pattern = (** [PatCstr(p,C,l,x)] = "|'C' 'l' as 'x'" *) type glob_constr = - | GRef of (Loc.t * global_reference) + | GRef of (Loc.t * global_reference * Univ.universe_instance option) | GVar of (Loc.t * Id.t) | GEvar of Loc.t * existential_key * glob_constr list option | GPatVar of Loc.t * (bool * patvar) (** Used for patterns only *) @@ -39,7 +39,7 @@ type glob_constr = | GCases of Loc.t * case_style * glob_constr option * tomatch_tuples * cases_clauses (** [GCases(l,style,r,tur,cc)] = "match 'tur' return 'r' with 'cc'" (in [MatchStyle]) *) - + | GProj of Loc.t * projection * glob_constr | GLetTuple of Loc.t * Name.t list * (Name.t * glob_constr option) * glob_constr * glob_constr | GIf of Loc.t * glob_constr * (Name.t * glob_constr option) * glob_constr * glob_constr diff --git a/intf/notation_term.mli b/intf/notation_term.mli index daf605ab2..8bb43e96a 100644 --- a/intf/notation_term.mli +++ b/intf/notation_term.mli @@ -25,6 +25,7 @@ type notation_constr = | NVar of Id.t | NApp of notation_constr * notation_constr list | NHole of Evar_kinds.t * Genarg.glob_generic_argument option + | NProj of projection * notation_constr | NList of Id.t * Id.t * notation_constr * notation_constr * bool (** Part only in [glob_constr] *) | NLambda of Name.t * notation_constr * notation_constr diff --git a/intf/pattern.mli b/intf/pattern.mli index d0ccb2d9b..4fa5f418d 100644 --- a/intf/pattern.mli +++ b/intf/pattern.mli @@ -65,6 +65,7 @@ type constr_pattern = | PRel of int | PApp of constr_pattern * constr_pattern array | PSoApp of patvar * constr_pattern list + | PProj of projection * constr_pattern | PLambda of Name.t * constr_pattern * constr_pattern | PProd of Name.t * constr_pattern * constr_pattern | PLetIn of Name.t * constr_pattern * constr_pattern diff --git a/intf/vernacexpr.mli b/intf/vernacexpr.mli index 850f06f87..857f75ed6 100644 --- a/intf/vernacexpr.mli +++ b/intf/vernacexpr.mli @@ -289,7 +289,7 @@ type vernac_expr = (* Gallina *) | VernacDefinition of (locality option * definition_object_kind) * lident * definition_expr - | VernacStartTheoremProof of theorem_kind * + | VernacStartTheoremProof of theorem_kind * (lident option * (local_binder list * constr_expr * (lident option * recursion_order_expr) option)) list * bool | VernacEndProof of proof_end @@ -428,6 +428,7 @@ type vernac_expr = (* Flags *) | VernacProgram of vernac_expr + | VernacPolymorphic of bool * vernac_expr | VernacLocal of bool * vernac_expr and located_vernac_expr = Loc.t * vernac_expr diff --git a/kernel/cbytegen.ml b/kernel/cbytegen.ml index d0da84623..894f88710 100644 --- a/kernel/cbytegen.ml +++ b/kernel/cbytegen.ml @@ -353,7 +353,7 @@ let rec str_const c = | App(f,args) -> begin match kind_of_term f with - | Construct((kn,j),i) -> + | Construct(((kn,j),i),u) -> begin let oib = lookup_mind kn !global_env in let oip = oib.mind_packets.(j) in @@ -422,8 +422,8 @@ let rec str_const c = end | _ -> Bconstr c end - | Ind ind -> Bstrconst (Const_ind ind) - | Construct ((kn,j),i) -> + | Ind (ind,u) -> Bstrconst (Const_ind ind) + | Construct (((kn,j),i),u) -> begin (* spiwack: tries first to apply the run-time compilation behavior of the constructor, as in 2/ above *) @@ -487,11 +487,11 @@ let rec compile_fv reloc l sz cont = (* Compiling constants *) let rec get_allias env kn = - let tps = (lookup_constant kn env).const_body_code in - match Cemitcodes.force tps with - | BCallias kn' -> get_allias env kn' - | _ -> kn - + let cb = lookup_constant kn env in + let tps = cb.const_body_code in + (match Cemitcodes.force tps with + | BCallias kn' -> get_allias env kn' + | _ -> kn) (* Compiling expressions *) @@ -499,12 +499,19 @@ let rec compile_constr reloc c sz cont = match kind_of_term c with | Meta _ -> invalid_arg "Cbytegen.compile_constr : Meta" | Evar _ -> invalid_arg "Cbytegen.compile_constr : Evar" + | Proj (p,c) -> + (* compile_const reloc p [|c|] sz cont *) + let cb = lookup_constant p !global_env in + (* TODO: better representation of projections *) + let pb = Option.get cb.const_proj in + let args = Array.make pb.proj_npars mkProp in + compile_const reloc p Univ.Instance.empty (Array.append args [|c|]) sz cont | Cast(c,_,_) -> compile_constr reloc c sz cont | Rel i -> pos_rel i reloc sz :: cont | Var id -> pos_named id reloc :: cont - | Const kn -> compile_const reloc kn [||] sz cont + | Const (kn,u) -> compile_const reloc kn u [||] sz cont | Sort _ | Ind _ | Construct _ -> compile_str_cst reloc (str_const c) sz cont @@ -531,7 +538,7 @@ let rec compile_constr reloc c sz cont = begin match kind_of_term f with | Construct _ -> compile_str_cst reloc (str_const c) sz cont - | Const kn -> compile_const reloc kn args sz cont + | Const (kn,u) -> compile_const reloc kn u args sz cont | _ -> comp_app compile_constr compile_constr reloc f args sz cont end | Fix ((rec_args,init),(_,type_bodies,rec_bodies)) -> @@ -682,14 +689,14 @@ and compile_str_cst reloc sc sz cont = (* spiwack : compilation of constants with their arguments. Makes a special treatment with 31-bit integer addition *) and compile_const = - fun reloc-> fun kn -> fun args -> fun sz -> fun cont -> + fun reloc-> fun kn u -> fun args -> fun sz -> fun cont -> let nargs = Array.length args in (* spiwack: checks if there is a specific way to compile the constant if there is not, Not_found is raised, and the function falls back on its normal behavior *) try Retroknowledge.get_vm_compiling_info (!global_env).retroknowledge - (mkConst kn) reloc args sz cont + (mkConstU (kn,u)) reloc args sz cont with Not_found -> if Int.equal nargs 0 then Kgetglobal (get_allias !global_env kn) :: cont @@ -723,7 +730,7 @@ let compile_constant_body env = function match kind_of_term body with | Const kn' -> (* we use the canonical name of the constant*) - let con= constant_of_kn (canonical_con kn') in + let con= constant_of_kn (canonical_con (Univ.out_punivs kn')) in BCallias (get_allias env con) | _ -> let res = compile env body in @@ -751,7 +758,7 @@ let compile_structured_int31 fc args = Const_b0 (Array.fold_left (fun temp_i -> fun t -> match kind_of_term t with - | Construct (_,d) -> 2*temp_i+d-1 + | Construct ((_,d),_) -> 2*temp_i+d-1 | _ -> raise NotClosed) 0 args ) diff --git a/kernel/cemitcodes.ml b/kernel/cemitcodes.ml index 2b9ca425f..2de8ef2bf 100644 --- a/kernel/cemitcodes.ml +++ b/kernel/cemitcodes.ml @@ -320,16 +320,16 @@ let rec subst_strcst s sc = match sc with | Const_sorts _ | Const_b0 _ -> sc | Const_bn(tag,args) -> Const_bn(tag,Array.map (subst_strcst s) args) - | Const_ind(ind) -> let kn,i = ind in Const_ind((subst_ind s kn, i)) + | Const_ind(ind) -> let kn,i = ind in Const_ind((subst_mind s kn, i)) let subst_patch s (ri,pos) = match ri with | Reloc_annot a -> let (kn,i) = a.ci.ci_ind in - let ci = {a.ci with ci_ind = (subst_ind s kn,i)} in + let ci = {a.ci with ci_ind = (subst_mind s kn,i)} in (Reloc_annot {a with ci = ci},pos) | Reloc_const sc -> (Reloc_const (subst_strcst s sc), pos) - | Reloc_getglobal kn -> (Reloc_getglobal (fst (subst_con s kn)), pos) + | Reloc_getglobal kn -> (Reloc_getglobal (fst (subst_con_kn s kn)), pos) let subst_to_patch s (code,pl,fv) = code,List.rev_map (subst_patch s) pl,fv @@ -341,7 +341,7 @@ type body_code = let subst_body_code s = function | BCdefined tp -> BCdefined (subst_to_patch s tp) - | BCallias kn -> BCallias (fst (subst_con s kn)) + | BCallias kn -> BCallias (fst (subst_con_kn s kn)) | BCconstant -> BCconstant type to_patch_substituted = body_code substituted diff --git a/kernel/closure.ml b/kernel/closure.ml index 7b94ecfb8..fd3ab525e 100644 --- a/kernel/closure.ml +++ b/kernel/closure.ml @@ -206,32 +206,39 @@ let unfold_red kn = * instantiations (cbv or lazy) are. *) -type table_key = id_key +type table_key = constant puniverses tableKey +let eq_pconstant_key (c,u) (c',u') = + eq_constant_key c c' && Univ.Instance.eq u u' + module IdKeyHash = struct - type t = id_key - let equal = Names.eq_id_key open Hashset.Combine + type t = table_key + let equal = Names.eq_table_key eq_pconstant_key let hash = function - | ConstKey c -> combinesmall 1 (Constant.UserOrd.hash c) + | ConstKey (c, _) -> combinesmall 1 (Constant.UserOrd.hash c) | VarKey id -> combinesmall 2 (Id.hash id) | RelKey i -> combinesmall 3 (Int.hash i) end module KeyTable = Hashtbl.Make(IdKeyHash) -let eq_table_key = Names.eq_id_key +let eq_table_key = IdKeyHash.equal -type 'a infos = { - i_flags : reds; +type 'a infos_cache = { i_repr : 'a infos -> constr -> 'a; i_env : env; i_sigma : existential -> constr option; i_rels : constr option array; i_tab : 'a KeyTable.t } +and 'a infos = { + i_flags : reds; + i_cache : 'a infos_cache } + let info_flags info = info.i_flags +let info_env info = info.i_cache.i_env let rec assoc_defined id = function | [] -> raise Not_found @@ -239,34 +246,34 @@ let rec assoc_defined id = function | (id', Some c, _) :: ctxt -> if Id.equal id id' then c else assoc_defined id ctxt -let ref_value_cache info ref = +let ref_value_cache ({i_cache = cache} as infos) ref = try - Some (KeyTable.find info.i_tab ref) + Some (KeyTable.find cache.i_tab ref) with Not_found -> try let body = match ref with | RelKey n -> - let len = Array.length info.i_rels in + let len = Array.length cache.i_rels in let i = n - 1 in let () = if i < 0 || len <= i then raise Not_found in - begin match Array.unsafe_get info.i_rels i with + begin match Array.unsafe_get cache.i_rels i with | None -> raise Not_found | Some t -> lift n t end - | VarKey id -> assoc_defined id (named_context info.i_env) - | ConstKey cst -> constant_value info.i_env cst + | VarKey id -> assoc_defined id (named_context cache.i_env) + | ConstKey cst -> constant_value_in cache.i_env cst in - let v = info.i_repr info body in - KeyTable.add info.i_tab ref v; + let v = cache.i_repr infos body in + KeyTable.add cache.i_tab ref v; Some v with | Not_found (* List.assoc *) | NotEvaluableConst _ (* Const *) -> None -let evar_value info ev = - info.i_sigma ev +let evar_value cache ev = + cache.i_sigma ev let defined_rels flags env = (* if red_local_const (snd flags) then*) @@ -282,12 +289,13 @@ let defined_rels flags env = (* else (0,[])*) let create mk_cl flgs env evars = - { i_flags = flgs; - i_repr = mk_cl; - i_env = env; - i_sigma = evars; - i_rels = defined_rels flgs env; - i_tab = KeyTable.create 17 } + let cache = + { i_repr = mk_cl; + i_env = env; + i_sigma = evars; + i_rels = defined_rels flgs env; + i_tab = KeyTable.create 17 } + in { i_flags = flgs; i_cache = cache } (**********************************************************************) @@ -327,9 +335,10 @@ and fterm = | FAtom of constr (* Metas and Sorts *) | FCast of fconstr * cast_kind * fconstr | FFlex of table_key - | FInd of inductive - | FConstruct of constructor + | FInd of pinductive + | FConstruct of pconstructor | FApp of fconstr * fconstr array + | FProj of constant * fconstr | FFix of fixpoint * fconstr subs | FCoFix of cofixpoint * fconstr subs | FCases of case_info * fconstr * fconstr * fconstr array @@ -362,6 +371,7 @@ let update v1 no t = type stack_member = | Zapp of fconstr array | Zcase of case_info * fconstr * fconstr array + | Zproj of int * int * constant | Zfix of fconstr * stack | Zshift of int | Zupdate of fconstr @@ -494,6 +504,9 @@ let rec compact_constr (lg, subs as s) c k = let (s, f') = compact_constr s f k in let (s, v') = compact_vect s v k in if f==f' && v==v' then s, c else s, mkApp(f',v') + | Proj (p,t) -> + let (s, t') = compact_constr s t k in + if t'==t then s, c else s, mkProj (p,t') | Lambda(n,a,b) -> let (s, a') = compact_constr s a k in let (s, b') = compact_constr s b (k+1) in @@ -559,7 +572,7 @@ let mk_clos e t = | Meta _ | Sort _ -> { norm = Norm; term = FAtom t } | Ind kn -> { norm = Norm; term = FInd kn } | Construct kn -> { norm = Cstr; term = FConstruct kn } - | (CoFix _|Lambda _|Fix _|Prod _|Evar _|App _|Case _|Cast _|LetIn _) -> + | (CoFix _|Lambda _|Fix _|Prod _|Evar _|App _|Case _|Cast _|LetIn _|Proj _) -> {norm = Red; term = FCLOS(t,e)} let mk_clos_vect env v = CArray.Fun1.map mk_clos env v @@ -578,6 +591,9 @@ let mk_clos_deep clos_fun env t = | App (f,v) -> { norm = Red; term = FApp (clos_fun env f, CArray.Fun1.map clos_fun env v) } + | Proj (p,c) -> + { norm = Red; + term = FProj (p, clos_fun env c) } | Case (ci,p,c,v) -> { norm = Red; term = FCases (ci, clos_fun env p, clos_fun env c, @@ -609,9 +625,9 @@ let rec to_constr constr_fun lfts v = | FAtom c -> exliftn lfts c | FCast (a,k,b) -> mkCast (constr_fun lfts a, k, constr_fun lfts b) - | FFlex (ConstKey op) -> mkConst op - | FInd op -> mkInd op - | FConstruct op -> mkConstruct op + | FFlex (ConstKey op) -> mkConstU op + | FInd op -> mkIndU op + | FConstruct op -> mkConstructU op | FCases (ci,p,c,ve) -> mkCase (ci, constr_fun lfts p, constr_fun lfts c, @@ -633,6 +649,9 @@ let rec to_constr constr_fun lfts v = | FApp (f,ve) -> mkApp (constr_fun lfts f, CArray.Fun1.map constr_fun lfts ve) + | FProj (p,c) -> + mkProj (p,constr_fun lfts c) + | FLambda _ -> let (na,ty,bd) = destFLambda mk_clos2 v in mkLambda (na, constr_fun lfts ty, @@ -688,6 +707,8 @@ let rec zip m stk rem = match stk with | Zcase(ci,p,br)::s -> let t = FCases(ci, p, m, br) in zip {norm=neutr m.norm; term=t} s rem +| Zproj (i,j,cst) :: s -> + zip {norm=neutr m.norm; term=FProj (cst,m)} s rem | Zfix(fx,par)::s -> zip fx par ((Zapp [|m|] :: s) :: rem) | Zshift(n)::s -> @@ -774,7 +795,7 @@ let rec get_args n tys f e stk = (* Eta expansion: add a reference to implicit surrounding lambda at end of stack *) let rec eta_expand_stack = function - | (Zapp _ | Zfix _ | Zcase _ | Zshift _ | Zupdate _ as e) :: s -> + | (Zapp _ | Zfix _ | Zcase _ | Zshift _ | Zupdate _ | Zproj _ as e) :: s -> e :: eta_expand_stack s | [] -> [Zshift 1; Zapp [|{norm=Norm; term= FRel 1}|]] @@ -808,6 +829,64 @@ let rec drop_parameters depth n argstk = | _ -> assert false (* strip_update_shift_app only produces Zapp and Zshift items *) +let rec get_parameters depth n argstk = + match argstk with + Zapp args::s -> + let q = Array.length args in + if n > q then Array.append args (get_parameters depth (n-q) s) + else if Int.equal n q then [||] + else Array.sub args 0 n + | Zshift(k)::s -> + get_parameters (depth-k) n s + | [] -> (* we know that n < stack_args_size(argstk) (if well-typed term) *) + if Int.equal n 0 then [||] + else raise Not_found (* Trying to eta-expand a partial application..., should do + eta expansion first? *) + | _ -> assert false + (* strip_update_shift_app only produces Zapp and Zshift items *) + +let eta_expand_ind_stack env lft (ind,u) m s (lft, h) = + let mib = lookup_mind (fst ind) env in + match mib.Declarations.mind_record with + | None -> raise Not_found + | Some (exp,_) -> + let pars = mib.Declarations.mind_nparams in + let h' = fapp_stack h in + let (depth, args, _) = strip_update_shift_app m s in + let paramargs = get_parameters depth pars args in + let subs = subs_cons (Array.append paramargs [|h'|], subs_id 0) in + let fexp = mk_clos subs exp in + (lft, (fexp, [])) + +let eta_expand_ind_stacks env ind m s h = + let mib = lookup_mind (fst ind) env in + match mib.Declarations.mind_record with + | Some (exp,projs) when Array.length projs > 0 -> + let pars = mib.Declarations.mind_nparams in + let h' = fapp_stack h in + let (depth, args, _) = strip_update_shift_app m s in + let primitive = Environ.is_projection projs.(0) env in + if primitive then + let s' = drop_parameters depth pars args in + (* Construct, pars1 .. parsm :: arg1...argn :: s ~= (t, []) -> + arg1..argn :: s ~= (proj1 t...projn t) s + *) + let hstack = Array.map (fun p -> { norm = Red; + term = FProj (p, h') }) projs in + s', [Zapp hstack] + else raise Not_found (* disallow eta-exp for non-primitive records *) + | _ -> raise Not_found + +let rec project_nth_arg n argstk = + match argstk with + | Zapp args :: s -> + let q = Array.length args in + if n >= q then project_nth_arg (n - q) s + else (* n < q *) args.(n) + | _ -> assert false + (* After drop_parameters we have a purely applicative stack *) + + (* Iota reduction: expansion of a fixpoint. * Given a fixpoint and a substitution, returns the corresponding * fixpoint body, and the substitution in which it should be @@ -832,39 +911,48 @@ let contract_fix_vect fix = in (subs_cons(Array.init nfix make_body, env), thisbody) - (*********************************************************************) (* A machine that inspects the head of a term until it finds an atom or a subterm that may produce a redex (abstraction, constructor, cofix, letin, constant), or a neutral term (product, inductive) *) -let rec knh m stk = +let rec knh info m stk = match m.term with - | FLIFT(k,a) -> knh a (zshift k stk) - | FCLOS(t,e) -> knht e t (zupdate m stk) + | FLIFT(k,a) -> knh info a (zshift k stk) + | FCLOS(t,e) -> knht info e t (zupdate m stk) | FLOCKED -> assert false - | FApp(a,b) -> knh a (append_stack b (zupdate m stk)) - | FCases(ci,p,t,br) -> knh t (Zcase(ci,p,br)::zupdate m stk) + | FApp(a,b) -> knh info a (append_stack b (zupdate m stk)) + | FCases(ci,p,t,br) -> knh info t (Zcase(ci,p,br)::zupdate m stk) | FFix(((ri,n),(_,_,_)),_) -> (match get_nth_arg m ri.(n) stk with - (Some(pars,arg),stk') -> knh arg (Zfix(m,pars)::stk') + (Some(pars,arg),stk') -> knh info arg (Zfix(m,pars)::stk') | (None, stk') -> (m,stk')) - | FCast(t,_,_) -> knh t stk + | FCast(t,_,_) -> knh info t stk + | FProj (p,c) -> + if red_set info.i_flags (fCONST p) then + (match try Some (lookup_projection p (info_env info)) with Not_found -> None with + | None -> (m, stk) + | Some pb -> + knh info c (Zproj (pb.Declarations.proj_npars, pb.Declarations.proj_arg, p) + :: zupdate m stk)) + else (m,stk) + (* cases where knh stops *) | (FFlex _|FLetIn _|FConstruct _|FEvar _| FCoFix _|FLambda _|FRel _|FAtom _|FInd _|FProd _) -> (m, stk) (* The same for pure terms *) -and knht e t stk = +and knht info e t stk = match kind_of_term t with | App(a,b) -> - knht e a (append_stack (mk_clos_vect e b) stk) + knht info e a (append_stack (mk_clos_vect e b) stk) | Case(ci,p,t,br) -> - knht e t (Zcase(ci, mk_clos e p, mk_clos_vect e br)::stk) - | Fix _ -> knh (mk_clos2 e t) stk - | Cast(a,_,_) -> knht e a stk - | Rel n -> knh (clos_rel e n) stk + knht info e t (Zcase(ci, mk_clos e p, mk_clos_vect e br)::stk) + | Fix _ -> knh info (mk_clos2 e t) stk + | Cast(a,_,_) -> knht info e a stk + | Rel n -> knh info (clos_rel e n) stk + | Proj (p,c) -> knh info (mk_clos2 e t) stk | (Lambda _|Prod _|Construct _|CoFix _|Ind _| LetIn _|Const _|Var _|Evar _|Meta _|Sort _) -> (mk_clos2 e t, stk) @@ -879,8 +967,8 @@ let rec knr info m stk = (match get_args n tys f e stk with Inl e', s -> knit info e' f s | Inr lam, s -> (lam,s)) - | FFlex(ConstKey kn) when red_set info.i_flags (fCONST kn) -> - (match ref_value_cache info (ConstKey kn) with + | FFlex(ConstKey (kn,_ as c)) when red_set info.i_flags (fCONST kn) -> + (match ref_value_cache info (ConstKey c) with Some v -> kni info v stk | None -> (set_norm m; (m,stk))) | FFlex(VarKey id) when red_set info.i_flags (fVAR id) -> @@ -891,7 +979,7 @@ let rec knr info m stk = (match ref_value_cache info (RelKey k) with Some v -> kni info v stk | None -> (set_norm m; (m,stk))) - | FConstruct(ind,c) when red_set info.i_flags fIOTA -> + | FConstruct((ind,c),u) when red_set info.i_flags fIOTA -> (match strip_update_shift_app m stk with (depth, args, Zcase(ci,_,br)::s) -> assert (ci.ci_npar>=0); @@ -902,6 +990,10 @@ let rec knr info m stk = let stk' = par @ append_stack [|rarg|] s in let (fxe,fxbd) = contract_fix_vect fx.term in knit info fxe fxbd stk' + | (depth, args, Zproj (n, m, cst)::s) -> + let rargs = drop_parameters depth n args in + let rarg = project_nth_arg m rargs in + kni info rarg s | (_,args,s) -> (m,args@s)) | FCoFix _ when red_set info.i_flags fIOTA -> (match strip_update_shift_app m stk with @@ -912,17 +1004,17 @@ let rec knr info m stk = | FLetIn (_,v,_,bd,e) when red_set info.i_flags fZETA -> knit info (subs_cons([|v|],e)) bd stk | FEvar(ev,env) -> - (match evar_value info ev with + (match evar_value info.i_cache ev with Some c -> knit info env c stk | None -> (m,stk)) | _ -> (m,stk) (* Computes the weak head normal form of a term *) and kni info m stk = - let (hm,s) = knh m stk in + let (hm,s) = knh info m stk in knr info hm s and knit info e t stk = - let (ht,s) = knht e t stk in + let (ht,s) = knht info e t stk in knr info ht s let kh info v stk = fapp_stack(kni info v stk) @@ -937,6 +1029,9 @@ let rec zip_term zfun m stk = | Zcase(ci,p,br)::s -> let t = mkCase(ci, zfun p, m, Array.map zfun br) in zip_term zfun t s + | Zproj(_,_,p)::s -> + let t = mkProj (p, m) in + zip_term zfun t s | Zfix(fx,par)::s -> let h = mkApp(zip_term zfun (zfun fx) par,[|m|]) in zip_term zfun h s @@ -985,6 +1080,8 @@ and norm_head info m = mkFix(n,(na, CArray.Fun1.map kl info ftys, CArray.Fun1.map kl info fbds)) | FEvar((i,args),env) -> mkEvar(i, Array.map (fun a -> kl info (mk_clos env a)) args) + | FProj (p,c) -> + mkProj (p, kl info c) | t -> term_of_fconstr m (* Initialization and then normalization *) @@ -1009,6 +1106,20 @@ type clos_infos = fconstr infos let create_clos_infos ?(evars=fun _ -> None) flgs env = create (fun _ -> inject) flgs env evars -let oracle_of_infos { i_env } = Environ.oracle i_env - -let unfold_reference = ref_value_cache +let oracle_of_infos infos = Environ.oracle infos.i_cache.i_env + +let infos_with_reds infos reds = + { infos with i_flags = reds } + +let unfold_reference info key = + match key with + | ConstKey (kn,_) -> + if red_set info.i_flags (fCONST kn) then + ref_value_cache info key + else None + | VarKey i -> + if red_set info.i_flags (fVAR i) then + ref_value_cache info key + else None + | _ -> ref_value_cache info key + diff --git a/kernel/closure.mli b/kernel/closure.mli index 19baedf27..ee35e7d49 100644 --- a/kernel/closure.mli +++ b/kernel/closure.mli @@ -80,14 +80,20 @@ val unfold_side_red : reds val unfold_red : evaluable_global_reference -> reds (***********************************************************************) -type table_key = id_key +type table_key = constant puniverses tableKey + +type 'a infos_cache +type 'a infos = { + i_flags : reds; + i_cache : 'a infos_cache } -type 'a infos val ref_value_cache: 'a infos -> table_key -> 'a option -val info_flags: 'a infos -> reds val create: ('a infos -> constr -> 'a) -> reds -> env -> (existential -> constr option) -> 'a infos -val evar_value : 'a infos -> existential -> constr option +val evar_value : 'a infos_cache -> existential -> constr option + +val info_env : 'a infos -> env +val info_flags: 'a infos -> reds (*********************************************************************** s Lazy reduction. *) @@ -104,9 +110,10 @@ type fterm = | FAtom of constr (** Metas and Sorts *) | FCast of fconstr * cast_kind * fconstr | FFlex of table_key - | FInd of inductive - | FConstruct of constructor + | FInd of inductive puniverses + | FConstruct of constructor puniverses | FApp of fconstr * fconstr array + | FProj of constant * fconstr | FFix of fixpoint * fconstr subs | FCoFix of cofixpoint * fconstr subs | FCases of case_info * fconstr * fconstr * fconstr array @@ -126,6 +133,7 @@ type fterm = type stack_member = | Zapp of fconstr array | Zcase of case_info * fconstr * fconstr array + | Zproj of int * int * constant | Zfix of fconstr * stack | Zshift of int | Zupdate of fconstr @@ -159,11 +167,13 @@ val destFLambda : (fconstr subs -> constr -> fconstr) -> fconstr -> Name.t * fconstr * fconstr (** Global and local constant cache *) -type clos_infos +type clos_infos = fconstr infos val create_clos_infos : ?evars:(existential->constr option) -> reds -> env -> clos_infos val oracle_of_infos : clos_infos -> Conv_oracle.oracle +val infos_with_reds : clos_infos -> reds -> clos_infos + (** Reduction function *) (** [norm_val] is for strong normalization *) @@ -177,6 +187,12 @@ val whd_val : clos_infos -> fconstr -> constr val whd_stack : clos_infos -> fconstr -> stack -> fconstr * stack +val eta_expand_ind_stack : env -> lift -> pinductive -> fconstr -> stack -> + (lift * (fconstr * stack)) -> lift * (fconstr * stack) + +val eta_expand_ind_stacks : env -> inductive -> fconstr -> stack -> + (fconstr * stack) -> stack * stack + (** Conversion auxiliary functions to do step by step normalisation *) (** [unfold_reference] unfolds references in a [fconstr] *) diff --git a/kernel/constr.ml b/kernel/constr.ml index e9e21d30d..89c138a08 100644 --- a/kernel/constr.ml +++ b/kernel/constr.ml @@ -25,7 +25,7 @@ open Util open Names - +open Univ type existential_key = Evar.t type metavariable = int @@ -61,6 +61,10 @@ type ('constr, 'types) pfixpoint = (int array * int) * ('constr, 'types) prec_declaration type ('constr, 'types) pcofixpoint = int * ('constr, 'types) prec_declaration +type 'a puniverses = 'a Univ.puniverses +type pconstant = constant puniverses +type pinductive = inductive puniverses +type pconstructor = constructor puniverses (* [Var] is used for named variables and [Rel] for variables as de Bruijn indices. *) @@ -75,13 +79,13 @@ type ('constr, 'types) kind_of_term = | Lambda of Name.t * 'types * 'constr | LetIn of Name.t * 'constr * 'types * 'constr | App of 'constr * 'constr array - | Const of constant - | Ind of inductive - | Construct of constructor + | Const of pconstant + | Ind of pinductive + | Construct of pconstructor | Case of case_info * 'constr * 'constr * 'constr array | Fix of ('constr, 'types) pfixpoint | CoFix of ('constr, 'types) pcofixpoint - + | Proj of constant * 'constr (* constr is the fixpoint of the previous type. Requires option -rectypes of the Caml compiler to be set *) type t = (t,t) kind_of_term @@ -139,19 +143,29 @@ let mkApp (f, a) = | App (g, cl) -> App (g, Array.append cl a) | _ -> App (f, a) +let out_punivs (a, _) = a +let map_puniverses f (x,u) = (f x, u) +let in_punivs a = (a, Univ.Instance.empty) + (* Constructs a constant *) -let mkConst c = Const c +let mkConst c = Const (in_punivs c) +let mkConstU c = Const c + +(* Constructs an applied projection *) +let mkProj (p,c) = Proj (p,c) (* Constructs an existential variable *) let mkEvar e = Evar e (* Constructs the ith (co)inductive type of the block named kn *) -let mkInd m = Ind m +let mkInd m = Ind (in_punivs m) +let mkIndU m = Ind m (* Constructs the jth constructor of the ith (co)inductive type of the - block named kn. The array of terms correspond to the variables - introduced in the section *) -let mkConstruct c = Construct c + block named kn. *) +let mkConstruct c = Construct (in_punivs c) +let mkConstructU c = Construct c +let mkConstructUi ((ind,u),i) = Construct ((ind,i),u) (* Constructs the term <p>Case c of c1 | c2 .. | cn end *) let mkCase (ci, p, c, ac) = Case (ci, p, c, ac) @@ -225,6 +239,7 @@ let fold f acc c = match kind c with | Lambda (_,t,c) -> f (f acc t) c | LetIn (_,b,t,c) -> f (f (f acc b) t) c | App (c,l) -> Array.fold_left f (f acc c) l + | Proj (p,c) -> f acc c | Evar (_,l) -> Array.fold_left f acc l | Case (_,p,c,bl) -> Array.fold_left f (f (f acc p) c) bl | Fix (_,(lna,tl,bl)) -> @@ -244,6 +259,7 @@ let iter f c = match kind c with | Lambda (_,t,c) -> f t; f c | LetIn (_,b,t,c) -> f b; f t; f c | App (c,l) -> f c; Array.iter f l + | Proj (p,c) -> f c | Evar (_,l) -> Array.iter f l | Case (_,p,c,bl) -> f p; f c; Array.iter f bl | Fix (_,(_,tl,bl)) -> Array.iter f tl; Array.iter f bl @@ -265,6 +281,7 @@ let iter_with_binders g f n c = match kind c with | App (c,l) -> f n c; CArray.Fun1.iter f n l | Evar (_,l) -> CArray.Fun1.iter f n l | Case (_,p,c,bl) -> f n p; f n c; CArray.Fun1.iter f n bl + | Proj (p,c) -> f n c | Fix (_,(_,tl,bl)) -> CArray.Fun1.iter f n tl; CArray.Fun1.iter f (iterate g (Array.length tl) n) bl @@ -305,6 +322,10 @@ let map f c = match kind c with let l' = Array.smartmap f l in if b'==b && l'==l then c else mkApp (b', l') + | Proj (p,t) -> + let t' = f t in + if t' == t then c + else mkProj (p, t') | Evar (e,l) -> let l' = Array.smartmap f l in if l'==l then c @@ -413,6 +434,10 @@ let map_with_binders g f l c0 = match kind c0 with let al' = CArray.Fun1.smartmap f l al in if c' == c && al' == al then c0 else mkApp (c', al') + | Proj (p, t) -> + let t' = f l t in + if t' == t then c0 + else mkProj (p, t') | Evar (e, al) -> let al' = CArray.Fun1.smartmap f l al in if al' == al then c0 @@ -435,13 +460,13 @@ let map_with_binders g f l c0 = match kind c0 with let bl' = CArray.Fun1.smartmap f l' bl in mkCoFix (ln,(lna,tl',bl')) -(* [compare f c1 c2] compare [c1] and [c2] using [f] to compare - the immediate subterms of [c1] of [c2] if needed; Cast's, +(* [compare_head_gen u s f c1 c2] compare [c1] and [c2] using [f] to compare + the immediate subterms of [c1] of [c2] if needed, [u] to compare universe + instances and [s] to compare sorts; Cast's, application associativity, binders name and Cases annotations are not taken into account *) - -let compare_head f t1 t2 = +let compare_head_gen eq_universes eq_sorts f t1 t2 = match kind t1, kind t2 with | Rel n1, Rel n2 -> Int.equal n1 n2 | Meta m1, Meta m2 -> Int.equal m1 m2 @@ -458,9 +483,10 @@ let compare_head f t1 t2 = Int.equal (Array.length l1) (Array.length l2) && f c1 c2 && Array.equal f l1 l2 | Evar (e1,l1), Evar (e2,l2) -> Evar.equal e1 e2 && Array.equal f l1 l2 - | Const c1, Const c2 -> eq_constant c1 c2 - | Ind c1, Ind c2 -> eq_ind c1 c2 - | Construct c1, Construct c2 -> eq_constructor c1 c2 + | Proj (p1,c1), Proj (p2,c2) -> eq_constant p1 p2 && f c1 c2 + | Const (c1,u1), Const (c2,u2) -> eq_constant c1 c2 && eq_universes true u1 u2 + | Ind (c1,u1), Ind (c2,u2) -> eq_ind c1 c2 && eq_universes false u1 u2 + | Construct (c1,u1), Construct (c2,u2) -> eq_constructor c1 c2 && eq_universes false u1 u2 | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) -> f p1 p2 && f c1 c2 && Array.equal f bl1 bl2 | Fix ((ln1, i1),(_,tl1,bl1)), Fix ((ln2, i2),(_,tl2,bl2)) -> @@ -470,6 +496,44 @@ let compare_head f t1 t2 = Int.equal ln1 ln2 && Array.equal f tl1 tl2 && Array.equal f bl1 bl2 | _ -> false +let compare_head = compare_head_gen (fun _ -> Univ.Instance.eq) Sorts.equal + +(* [compare_head_gen_leq u s sl eq leq c1 c2] compare [c1] and [c2] using [eq] to compare + the immediate subterms of [c1] of [c2] for conversion if needed, [leq] for cumulativity, + [u] to compare universe instances and [s] to compare sorts; Cast's, + application associativity, binders name and Cases annotations are + not taken into account *) + +let compare_head_gen_leq eq_universes eq_sorts leq_sorts eq leq t1 t2 = + match kind t1, kind t2 with + | Rel n1, Rel n2 -> Int.equal n1 n2 + | Meta m1, Meta m2 -> Int.equal m1 m2 + | Var id1, Var id2 -> Int.equal (id_ord id1 id2) 0 + | Sort s1, Sort s2 -> leq_sorts s1 s2 + | Cast (c1,_,_), _ -> leq c1 t2 + | _, Cast (c2,_,_) -> leq t1 c2 + | Prod (_,t1,c1), Prod (_,t2,c2) -> eq t1 t2 && leq c1 c2 + | Lambda (_,t1,c1), Lambda (_,t2,c2) -> eq t1 t2 && eq c1 c2 + | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) -> eq b1 b2 && eq t1 t2 && leq c1 c2 + | App (Cast(c1, _, _),l1), _ -> leq (mkApp (c1,l1)) t2 + | _, App (Cast (c2, _, _),l2) -> leq t1 (mkApp (c2,l2)) + | App (c1,l1), App (c2,l2) -> + Int.equal (Array.length l1) (Array.length l2) && + eq c1 c2 && Array.equal eq l1 l2 + | Proj (p1,c1), Proj (p2,c2) -> eq_constant p1 p2 && eq c1 c2 + | Evar (e1,l1), Evar (e2,l2) -> Evar.equal e1 e2 && Array.equal eq l1 l2 + | Const (c1,u1), Const (c2,u2) -> eq_constant c1 c2 && eq_universes true u1 u2 + | Ind (c1,u1), Ind (c2,u2) -> eq_ind c1 c2 && eq_universes false u1 u2 + | Construct (c1,u1), Construct (c2,u2) -> eq_constructor c1 c2 && eq_universes false u1 u2 + | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) -> + eq p1 p2 && eq c1 c2 && Array.equal eq bl1 bl2 + | Fix ((ln1, i1),(_,tl1,bl1)), Fix ((ln2, i2),(_,tl2,bl2)) -> + Int.equal i1 i2 && Array.equal Int.equal ln1 ln2 + && Array.equal eq tl1 tl2 && Array.equal eq bl1 bl2 + | CoFix(ln1,(_,tl1,bl1)), CoFix(ln2,(_,tl2,bl2)) -> + Int.equal ln1 ln2 && Array.equal eq tl1 tl2 && Array.equal eq bl1 bl2 + | _ -> false + (*******************************) (* alpha conversion functions *) (*******************************) @@ -477,10 +541,81 @@ let compare_head f t1 t2 = (* alpha conversion : ignore print names and casts *) let rec eq_constr m n = - (m == n) || compare_head eq_constr m n + (m == n) || compare_head_gen (fun _ -> Univ.Instance.eq) Sorts.equal eq_constr m n + +(** Strict equality of universe instances. *) +let compare_constr = compare_head_gen (fun _ -> Univ.Instance.eq) Sorts.equal let equal m n = eq_constr m n (* to avoid tracing a recursive fun *) +let eq_constr_univs univs m n = + if m == n then true + else + let eq_universes _ = Univ.Instance.check_eq univs in + let eq_sorts s1 s2 = Univ.check_eq univs (Sorts.univ_of_sort s1) (Sorts.univ_of_sort s2) in + let rec eq_constr' m n = + m == n || compare_head_gen eq_universes eq_sorts eq_constr' m n + in compare_head_gen eq_universes eq_sorts eq_constr' m n + +let leq_constr_univs univs m n = + if m == n then true + else + let eq_universes _ = Univ.Instance.check_eq univs in + let eq_sorts s1 s2 = Univ.check_eq univs (Sorts.univ_of_sort s1) (Sorts.univ_of_sort s2) in + let leq_sorts s1 s2 = Univ.check_leq univs (Sorts.univ_of_sort s1) (Sorts.univ_of_sort s2) in + let rec eq_constr' m n = + m == n || compare_head_gen eq_universes eq_sorts eq_constr' m n + in + let rec compare_leq m n = + compare_head_gen_leq eq_universes eq_sorts leq_sorts eq_constr' leq_constr' m n + and leq_constr' m n = m == n || compare_leq m n in + compare_leq m n + +let eq_constr_universes m n = + if m == n then true, UniverseConstraints.empty + else + let cstrs = ref UniverseConstraints.empty in + let eq_universes strict l l' = + cstrs := Univ.enforce_eq_instances_univs strict l l' !cstrs; true in + let eq_sorts s1 s2 = + cstrs := Univ.UniverseConstraints.add + (Sorts.univ_of_sort s1, Univ.UEq, Sorts.univ_of_sort s2) !cstrs; + true + in + let rec eq_constr' m n = + m == n || compare_head_gen eq_universes eq_sorts eq_constr' m n + in + let res = compare_head_gen eq_universes eq_sorts eq_constr' m n in + res, !cstrs + +let leq_constr_universes m n = + if m == n then true, UniverseConstraints.empty + else + let cstrs = ref UniverseConstraints.empty in + let eq_universes strict l l' = + cstrs := Univ.enforce_eq_instances_univs strict l l' !cstrs; true in + let eq_sorts s1 s2 = + cstrs := Univ.UniverseConstraints.add + (Sorts.univ_of_sort s1,Univ.UEq,Sorts.univ_of_sort s2) !cstrs; true + in + let leq_sorts s1 s2 = + cstrs := Univ.UniverseConstraints.add + (Sorts.univ_of_sort s1,Univ.ULe,Sorts.univ_of_sort s2) !cstrs; true + in + let rec eq_constr' m n = + m == n || compare_head_gen eq_universes eq_sorts eq_constr' m n + in + let rec compare_leq m n = + compare_head_gen_leq eq_universes eq_sorts leq_sorts eq_constr' leq_constr' m n + and leq_constr' m n = m == n || compare_leq m n in + let res = compare_leq m n in + res, !cstrs + +let always_true _ _ = true + +let rec eq_constr_nounivs m n = + (m == n) || compare_head_gen (fun _ -> always_true) always_true eq_constr_nounivs m n + (** We only use this function over blocks! *) let tag t = Obj.tag (Obj.repr t) @@ -509,11 +644,12 @@ let constr_ord_int f t1 t2 = | App (Cast(c1,_,_),l1), _ -> f (mkApp (c1,l1)) t2 | _, App (Cast(c2, _,_),l2) -> f t1 (mkApp (c2,l2)) | App (c1,l1), App (c2,l2) -> (f =? (Array.compare f)) c1 c2 l1 l2 + | Proj (p1,c1), Proj (p2,c2) -> (con_ord =? f) p1 p2 c1 c2 | Evar (e1,l1), Evar (e2,l2) -> (Evar.compare =? (Array.compare f)) e1 e2 l1 l2 - | Const c1, Const c2 -> con_ord c1 c2 - | Ind ind1, Ind ind2 -> ind_ord ind1 ind2 - | Construct ct1, Construct ct2 -> constructor_ord ct1 ct2 + | Const (c1,u1), Const (c2,u2) -> con_ord c1 c2 + | Ind (ind1, u1), Ind (ind2, u2) -> ind_ord ind1 ind2 + | Construct (ct1,u1), Construct (ct2,u2) -> constructor_ord ct1 ct2 | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) -> ((f =? f) ==? (Array.compare f)) p1 p2 c1 c2 bl1 bl2 | Fix (ln1,(_,tl1,bl1)), Fix (ln2,(_,tl2,bl2)) -> @@ -587,12 +723,14 @@ let hasheq t1 t2 = | Lambda (n1,t1,c1), Lambda (n2,t2,c2) -> n1 == n2 && t1 == t2 && c1 == c2 | LetIn (n1,b1,t1,c1), LetIn (n2,b2,t2,c2) -> n1 == n2 && b1 == b2 && t1 == t2 && c1 == c2 + | Proj (c1,t1), Proj (c2,t2) -> c1 == c2 && t1 == t2 | App (c1,l1), App (c2,l2) -> c1 == c2 && array_eqeq l1 l2 | Evar (e1,l1), Evar (e2,l2) -> Evar.equal e1 e2 && array_eqeq l1 l2 - | Const c1, Const c2 -> c1 == c2 - | Ind (sp1,i1), Ind (sp2,i2) -> sp1 == sp2 && Int.equal i1 i2 - | Construct ((sp1,i1),j1), Construct ((sp2,i2),j2) -> - sp1 == sp2 && Int.equal i1 i2 && Int.equal j1 j2 + | Const (c1,u1), Const (c2,u2) -> c1 == c2 && Univ.Instance.eqeq u1 u2 + | Ind ((sp1,i1),u1), Ind ((sp2,i2),u2) -> + sp1 == sp2 && Int.equal i1 i2 && Univ.Instance.eqeq u1 u2 + | Construct (((sp1,i1),j1),u1), Construct (((sp2,i2),j2),u2) -> + sp1 == sp2 && Int.equal i1 i2 && Int.equal j1 j2 && Univ.Instance.eqeq u1 u2 | Case (ci1,p1,c1,bl1), Case (ci2,p2,c2,bl2) -> ci1 == ci2 && p1 == p2 && c1 == c2 && array_eqeq bl1 bl2 | Fix ((ln1, i1),(lna1,tl1,bl1)), Fix ((ln2, i2),(lna2,tl2,bl2)) -> @@ -631,6 +769,8 @@ let hash_cast_kind = function | DEFAULTcast -> 2 | REVERTcast -> 3 +let hash_instance = Univ.Instance.hcons + (* [hashcons hash_consing_functions constr] computes an hash-consed representation for [constr] using [hash_consing_functions] on leaves. *) @@ -665,12 +805,16 @@ let hashcons (sh_sort,sh_ci,sh_construct,sh_ind,sh_con,sh_na,sh_id) = | Evar (e,l) -> let l, hl = hash_term_array l in (Evar (e,l), combinesmall 8 (combine (Evar.hash e) hl)) - | Const c -> - (Const (sh_con c), combinesmall 9 (Constant.hash c)) - | Ind ind -> - (Ind (sh_ind ind), combinesmall 10 (ind_hash ind)) - | Construct c -> - (Construct (sh_construct c), combinesmall 11 (constructor_hash c)) + | Proj (p,c) -> + let c, hc = sh_rec c in + let p' = sh_con p in + (Proj (p', c), combinesmall 17 (Hashtbl.hash p')) (** FIXME *) + | Const (c,u) -> + (Const (sh_con c, hash_instance u), combinesmall 9 (Constant.hash c)) + | Ind (ind, u) -> + (Ind (sh_ind ind, hash_instance u), combinesmall 10 (ind_hash ind)) + | Construct (c, u) -> + (Construct (sh_construct c, hash_instance u), combinesmall 11 (constructor_hash c)) | Case (ci,p,c,bl) -> let p, hp = sh_rec p and c, hc = sh_rec c in @@ -742,13 +886,15 @@ let rec hash t = | App (Cast(c, _, _),l) -> hash (mkApp (c,l)) | App (c,l) -> combinesmall 7 (combine (hash_term_array l) (hash c)) + | Proj (p,c) -> + combinesmall 17 (combine (Hashtbl.hash p) (hash c)) | Evar (e,l) -> combinesmall 8 (combine (Evar.hash e) (hash_term_array l)) - | Const c -> + | Const (c, _) -> combinesmall 9 (Constant.hash c) - | Ind ind -> + | Ind (ind, _) -> combinesmall 10 (ind_hash ind) - | Construct c -> + | Construct (c, _) -> combinesmall 11 (constructor_hash c) | Case (_ , p, c, bl) -> combinesmall 12 (combine3 (hash c) (hash p) (hash_term_array bl)) @@ -799,8 +945,32 @@ module Hcaseinfo = Hashcons.Make(CaseinfoHash) let case_info_hash = CaseinfoHash.hash +module Hsorts = + Hashcons.Make( + struct + open Sorts + + type t = Sorts.t + type u = universe -> universe + let hashcons huniv = function + Prop c -> Prop c + | Type u -> Type (huniv u) + let equal s1 s2 = + s1 == s2 || + match (s1,s2) with + (Prop c1, Prop c2) -> c1 == c2 + | (Type u1, Type u2) -> u1 == u2 + |_ -> false + let hash = Hashtbl.hash + end) + +let hcons_sorts = Hashcons.simple_hcons Hsorts.generate hcons_univ let hcons_caseinfo = Hashcons.simple_hcons Hcaseinfo.generate hcons_ind +let hcons_pconstruct (c,u) = (hcons_construct c, Univ.Instance.hcons u) +let hcons_pind (i,u) = (hcons_ind i, Univ.Instance.hcons u) +let hcons_pcon (c,u) = (hcons_con c, Univ.Instance.hcons u) + let hcons = hashcons (Sorts.hcons, diff --git a/kernel/constr.mli b/kernel/constr.mli index 82a2de094..be6250257 100644 --- a/kernel/constr.mli +++ b/kernel/constr.mli @@ -8,6 +8,14 @@ open Names +(** {6 Value under universe substitution } *) +type 'a puniverses = 'a Univ.puniverses + +(** {6 Simply type aliases } *) +type pconstant = constant puniverses +type pinductive = inductive puniverses +type pconstructor = constructor puniverses + (** {6 Existential variables } *) type existential_key = Evar.t @@ -88,20 +96,26 @@ val mkLetIn : Name.t * constr * types * constr -> constr {% $(f~t_1~\dots~t_n)$ %}. *) val mkApp : constr * constr array -> constr -(** Constructs a constant - The array of terms correspond to the variables introduced in the section *) +val map_puniverses : ('a -> 'b) -> 'a puniverses -> 'b puniverses + +(** Constructs a constant *) val mkConst : constant -> constr +val mkConstU : pconstant -> constr + +(** Constructs a projection application *) +val mkProj : (constant * constr) -> constr (** Inductive types *) -(** Constructs the ith (co)inductive type of the block named kn - The array of terms correspond to the variables introduced in the section *) +(** Constructs the ith (co)inductive type of the block named kn *) val mkInd : inductive -> constr +val mkIndU : pinductive -> constr (** Constructs the jth constructor of the ith (co)inductive type of the - block named kn. The array of terms correspond to the variables - introduced in the section *) + block named kn. *) val mkConstruct : constructor -> constr +val mkConstructU : pconstructor -> constr +val mkConstructUi : pinductive * int -> constr (** Constructs a destructor of inductive type. @@ -170,12 +184,13 @@ type ('constr, 'types) kind_of_term = | Lambda of Name.t * 'types * 'constr | LetIn of Name.t * 'constr * 'types * 'constr | App of 'constr * 'constr array - | Const of constant - | Ind of inductive - | Construct of constructor + | Const of constant puniverses + | Ind of inductive puniverses + | Construct of constructor puniverses | Case of case_info * 'constr * 'constr * 'constr array | Fix of ('constr, 'types) pfixpoint | CoFix of ('constr, 'types) pcofixpoint + | Proj of constant * 'constr (** User view of [constr]. For [App], it is ensured there is at least one argument and the function is not itself an applicative @@ -187,6 +202,26 @@ val kind : constr -> (constr, types) kind_of_term and application grouping *) val equal : constr -> constr -> bool +(** [eq_constr_univs a b] [true, c] if [a] equals [b] modulo alpha, casts, + application grouping and the universe equalities in [c]. *) +val eq_constr_univs : constr Univ.check_function + +(** [leq_constr_univs a b] [true, c] if [a] is convertible to [b] modulo + alpha, casts, application grouping and the universe inequalities in [c]. *) +val leq_constr_univs : constr Univ.check_function + +(** [eq_constr_universes a b] [true, c] if [a] equals [b] modulo alpha, casts, + application grouping and the universe equalities in [c]. *) +val eq_constr_universes : constr -> constr -> bool Univ.universe_constrained + +(** [leq_constr_universes a b] [true, c] if [a] is convertible to [b] modulo + alpha, casts, application grouping and the universe inequalities in [c]. *) +val leq_constr_universes : constr -> constr -> bool Univ.universe_constrained + +(** [eq_constr_univs a b] [true, c] if [a] equals [b] modulo alpha, casts, + application grouping and ignoring universe instances. *) +val eq_constr_nounivs : constr -> constr -> bool + (** Total ordering compatible with [equal] *) val compare : constr -> constr -> int diff --git a/kernel/conv_oracle.mli b/kernel/conv_oracle.mli index cd8cd2cf7..ae501ce87 100644 --- a/kernel/conv_oracle.mli +++ b/kernel/conv_oracle.mli @@ -16,7 +16,7 @@ val empty : oracle If [oracle_order kn1 kn2] is true, then unfold kn1 first. Note: the oracle does not introduce incompleteness, it only tries to postpone unfolding of "opaque" constants. *) -val oracle_order : oracle -> bool -> 'a tableKey -> 'a tableKey -> bool +val oracle_order : oracle -> bool -> constant tableKey -> constant tableKey -> bool (** Priority for the expansion of constant in the conversion test. * Higher levels means that the expansion is less prioritary. @@ -29,14 +29,14 @@ val transparent : level (** Check whether a level is transparent *) val is_transparent : level -> bool -val get_strategy : oracle -> 'a tableKey -> level +val get_strategy : oracle -> constant tableKey -> level (** Sets the level of a constant. * Level of RelKey constant cannot be set. *) -val set_strategy : oracle -> 'a tableKey -> level -> oracle +val set_strategy : oracle -> constant tableKey -> level -> oracle (** Fold over the non-transparent levels of the oracle. Order unspecified. *) -val fold_strategy : (unit tableKey -> level -> 'a -> 'a) -> oracle -> 'a -> 'a +val fold_strategy : (constant tableKey -> level -> 'a -> 'a) -> oracle -> 'a -> 'a val get_transp_state : oracle -> transparent_state diff --git a/kernel/cooking.ml b/kernel/cooking.ml index dbe188bd4..4bae6de66 100644 --- a/kernel/cooking.ml +++ b/kernel/cooking.ml @@ -19,6 +19,7 @@ open Names open Term open Declarations open Environ +open Univ (*s Cooking the constants. *) @@ -56,27 +57,36 @@ end module RefTable = Hashtbl.Make(RefHash) +let instantiate_my_gr gr u = + match gr with + | ConstRef c -> mkConstU (c, u) + | IndRef i -> mkIndU (i, u) + | ConstructRef c -> mkConstructU (c, u) + let share cache r (cstl,knl) = try RefTable.find cache r with Not_found -> - let f,l = + let f,(u,l) = match r with | IndRef (kn,i) -> - mkInd (pop_mind kn,i), Mindmap.find kn knl + IndRef (pop_mind kn,i), Mindmap.find kn knl | ConstructRef ((kn,i),j) -> - mkConstruct ((pop_mind kn,i),j), Mindmap.find kn knl + ConstructRef ((pop_mind kn,i),j), Mindmap.find kn knl | ConstRef cst -> - mkConst (pop_con cst), Cmap.find cst cstl in - let c = mkApp (f, Array.map mkVar l) in + ConstRef (pop_con cst), Cmap.find cst cstl in + let c = (f, (u, Array.map mkVar l)) in RefTable.add cache r c; c +let share_univs cache r u l = + let r', (u', args) = share cache r l in + mkApp (instantiate_my_gr r' (Instance.append u' u), args) + let update_case_info cache ci modlist = try let ind, n = - match kind_of_term (share cache (IndRef ci.ci_ind) modlist) with - | App (f,l) -> (destInd f, Array.length l) - | Ind ind -> ind, 0 + match share cache (IndRef ci.ci_ind) modlist with + | (IndRef f,(u,l)) -> (f, Array.length l) | _ -> assert false in { ci with ci_ind = ind; ci_npar = ci.ci_npar + n } with Not_found -> @@ -86,31 +96,43 @@ let is_empty_modlist (cm, mm) = Cmap.is_empty cm && Mindmap.is_empty mm let expmod_constr cache modlist c = - let share = share cache in + let share_univs = share_univs cache in let update_case_info = update_case_info cache in let rec substrec c = match kind_of_term c with | Case (ci,p,t,br) -> map_constr substrec (mkCase (update_case_info ci modlist,p,t,br)) - | Ind ind -> + | Ind (ind,u) -> (try - share (IndRef ind) modlist + share_univs (IndRef ind) u modlist with | Not_found -> map_constr substrec c) - | Construct cstr -> + | Construct (cstr,u) -> (try - share (ConstructRef cstr) modlist + share_univs (ConstructRef cstr) u modlist with | Not_found -> map_constr substrec c) - | Const cst -> + | Const (cst,u) -> (try - share (ConstRef cst) modlist + share_univs (ConstRef cst) u modlist with | Not_found -> map_constr substrec c) + | Proj (p, c') -> + (try + let p' = share_univs (ConstRef p) Univ.Instance.empty modlist in + match kind_of_term p' with + | Const (p',_) -> mkProj (p', substrec c') + | App (f, args) -> + (match kind_of_term f with + | Const (p', _) -> mkProj (p', substrec c') + | _ -> assert false) + | _ -> assert false + with Not_found -> map_constr substrec c) + | _ -> map_constr substrec c in @@ -127,7 +149,8 @@ type recipe = { from : constant_body; info : Opaqueproof.cooking_info } type inline = bool type result = - constant_def * constant_type * Univ.constraints * inline + constant_def * constant_type * projection_body option * + bool * constant_universes * inline * Context.section_context option let on_body ml hy f = function @@ -142,15 +165,17 @@ let constr_of_def = function | Def cs -> Mod_subst.force_constr cs | OpaqueDef lc -> Opaqueproof.force_proof lc + let cook_constr { Opaqueproof.modlist ; abstract } c = let cache = RefTable.create 13 in - let hyps = Context.map_named_context (expmod_constr cache modlist) abstract in + let hyps = Context.map_named_context (expmod_constr cache modlist) (fst abstract) in abstract_constant_body (expmod_constr cache modlist c) hyps let cook_constant env { from = cb; info = { Opaqueproof.modlist; abstract } } = let cache = RefTable.create 13 in + let abstract, abs_ctx = abstract in let hyps = Context.map_named_context (expmod_constr cache modlist) abstract in - let body = on_body modlist hyps + let body = on_body modlist (hyps, abs_ctx) (fun c -> abstract_constant_body (expmod_constr cache modlist c) hyps) cb.const_body in @@ -158,18 +183,43 @@ let cook_constant env { from = cb; info = { Opaqueproof.modlist; abstract } } = Context.fold_named_context (fun (h,_,_) hyps -> List.filter (fun (id,_,_) -> not (Id.equal id h)) hyps) hyps ~init:cb.const_hyps in - let typ = match cb.const_type with - | NonPolymorphicType t -> - let typ = - abstract_constant_type (expmod_constr cache modlist t) hyps in - NonPolymorphicType typ - | PolymorphicArity (ctx,s) -> - let t = mkArity (ctx,Type s.poly_level) in - let typ = - abstract_constant_type (expmod_constr cache modlist t) hyps in - let j = make_judge (constr_of_def body) typ in - Typeops.make_polymorphic_if_constant_for_ind env j + + (* let typ = match cb.const_type with *) + (* | NonPolymorphicType t -> *) + (* let typ = *) + (* abstract_constant_type (expmod_constr cache r.d_modlist t) hyps in *) + (* NonPolymorphicType typ *) + (* | PolymorphicArity (ctx,s) -> *) + (* let t = mkArity (ctx,Type s.poly_level) in *) + (* let typ = *) + (* abstract_constant_type (expmod_constr cache r.d_modlist t) hyps in *) + (* let j = make_judge (constr_of_def body) typ in *) + (* Typeops.make_polymorphic_if_constant_for_ind env j *) + (* in *) + let typ = + abstract_constant_type (expmod_constr cache modlist cb.const_type) hyps in - (body, typ, cb.const_constraints, cb.const_inline_code, Some const_hyps) + let projection pb = + let c' = abstract_constant_body (expmod_constr cache modlist pb.proj_body) hyps in + let ((mind, _), _), n' = + try + let c' = share_univs cache (IndRef (pb.proj_ind,0)) Univ.Instance.empty modlist in + match kind_of_term c' with + | App (f,l) -> (destInd f, Array.length l) + | Ind ind -> ind, 0 + | _ -> assert false + with Not_found -> (((pb.proj_ind,0),Univ.Instance.empty), 0) + in + let ctx, ty' = decompose_prod_n (n' + pb.proj_npars + 1) typ in + { proj_ind = mind; proj_npars = pb.proj_npars + n'; proj_arg = pb.proj_arg; + proj_type = ty'; proj_body = c' } + in + let univs = Future.from_val (UContext.union abs_ctx (Future.force cb.const_universes)) in + (body, typ, Option.map projection cb.const_proj, + cb.const_polymorphic, univs, cb.const_inline_code, + Some const_hyps) + +(* let cook_constant_key = Profile.declare_profile "cook_constant" *) +(* let cook_constant = Profile.profile2 cook_constant_key cook_constant *) let expmod_constr modlist c = expmod_constr (RefTable.create 13) modlist c diff --git a/kernel/cooking.mli b/kernel/cooking.mli index 030e88829..489360af7 100644 --- a/kernel/cooking.mli +++ b/kernel/cooking.mli @@ -17,7 +17,8 @@ type recipe = { from : constant_body; info : Opaqueproof.cooking_info } type inline = bool type result = - constant_def * constant_type * Univ.constraints * inline + constant_def * constant_type * projection_body option * + bool * constant_universes * inline * Context.section_context option val cook_constant : env -> recipe -> result diff --git a/kernel/declarations.mli b/kernel/declarations.mli index 1e94e243c..f3cb41f32 100644 --- a/kernel/declarations.mli +++ b/kernel/declarations.mli @@ -18,14 +18,7 @@ type engagement = ImpredicativeSet (** {6 Representation of constants (Definition/Axiom) } *) -type polymorphic_arity = { - poly_param_levels : Univ.universe option list; - poly_level : Univ.universe; -} - -type constant_type = - | NonPolymorphicType of types - | PolymorphicArity of rel_context * polymorphic_arity +type constant_type = types (** Inlining level of parameters at functor applications. None means no inlining *) @@ -35,11 +28,24 @@ type inline = int option (** A constant can have no body (axiom/parameter), or a transparent body, or an opaque one *) +(** Projections are a particular kind of constant: + always transparent. *) + +type projection_body = { + proj_ind : mutual_inductive; + proj_npars : int; + proj_arg : int; + proj_type : types; (* Type under params *) + proj_body : constr; (* For compatibility, the match version *) +} + type constant_def = | Undef of inline | Def of constr Mod_subst.substituted | OpaqueDef of Opaqueproof.opaque +type constant_universes = Univ.universe_context Future.computation + (* some contraints are in constant_constraints, some other may be in * the OpaueDef *) type constant_body = { @@ -47,7 +53,9 @@ type constant_body = { const_body : constant_def; const_type : constant_type; const_body_code : Cemitcodes.to_patch_substituted; - const_constraints : Univ.constraints; + const_polymorphic : bool; (** Is it polymorphic or not *) + const_universes : constant_universes; + const_proj : projection_body option; const_inline_code : bool } type side_effect = @@ -71,15 +79,11 @@ type wf_paths = recarg Rtree.t v} *) -type monomorphic_inductive_arity = { - mind_user_arity : constr; +type inductive_arity = { + mind_user_arity : types; mind_sort : sorts; } -type inductive_arity = -| Monomorphic of monomorphic_inductive_arity -| Polymorphic of polymorphic_arity - type one_inductive_body = { (** {8 Primitive datas } *) @@ -87,7 +91,7 @@ type one_inductive_body = { mind_arity_ctxt : rel_context; (** Arity context of [Ii] with parameters: [forall params, Ui] *) - mind_arity : inductive_arity; (** Arity sort and original user arity if monomorphic *) + mind_arity : inductive_arity; (** Arity sort and original user arity *) mind_consnames : Id.t array; (** Names of the constructors: [cij] *) @@ -129,7 +133,9 @@ type mutual_inductive_body = { mind_packets : one_inductive_body array; (** The component of the mutual inductive block *) - mind_record : bool; (** Whether the inductive type has been declared as a record *) + mind_record : (constr * constant array) option; + (** Whether the inductive type has been declared as a record, + In that case we get its canonical eta-expansion and list of projections. *) mind_finite : bool; (** Whether the type is inductive or coinductive *) @@ -143,7 +149,9 @@ type mutual_inductive_body = { mind_params_ctxt : rel_context; (** The context of parameters (includes let-in declaration) *) - mind_constraints : Univ.constraints; (** Universes constraints enforced by the inductive declaration *) + mind_polymorphic : bool; (** Is it polymorphic or not *) + + mind_universes : Univ.universe_context; (** Local universe variables and constraints *) } diff --git a/kernel/declareops.ml b/kernel/declareops.ml index 1b67de0ea..0e4b80495 100644 --- a/kernel/declareops.ml +++ b/kernel/declareops.ml @@ -20,8 +20,9 @@ let body_of_constant cb = match cb.const_body with | Def c -> Some (force_constr c) | OpaqueDef o -> Some (Opaqueproof.force_proof o) -let constraints_of_constant cb = Univ.union_constraints cb.const_constraints - (match cb.const_body with +let constraints_of_constant cb = Univ.Constraint.union + (Univ.UContext.constraints (Future.force cb.const_universes)) + (match cb.const_body with | Undef _ -> Univ.empty_constraint | Def c -> Univ.empty_constraint | OpaqueDef o -> Opaqueproof.force_constraints o) @@ -43,36 +44,48 @@ let subst_rel_declaration sub (id,copt,t as x) = let subst_rel_context sub = List.smartmap (subst_rel_declaration sub) -let subst_const_type sub arity = match arity with - | NonPolymorphicType s -> - let s' = subst_mps sub s in - if s==s' then arity else NonPolymorphicType s' - | PolymorphicArity (ctx,s) -> - let ctx' = subst_rel_context sub ctx in - if ctx==ctx' then arity else PolymorphicArity (ctx',s) +(* let subst_const_type sub arity = match arity with *) +(* | NonPolymorphicType s -> *) +(* let s' = subst_mps sub s in *) +(* if s==s' then arity else NonPolymorphicType s' *) +(* | PolymorphicArity (ctx,s) -> *) +(* let ctx' = subst_rel_context sub ctx in *) +(* if ctx==ctx' then arity else PolymorphicArity (ctx',s) *) + +let subst_const_type sub arity = + if is_empty_subst sub then arity + else subst_mps sub arity (** No need here to check for physical equality after substitution, at least for Def due to the delayed substitution [subst_constr_subst]. *) - let subst_const_def sub def = match def with | Undef _ -> def | Def c -> Def (subst_constr sub c) | OpaqueDef o -> OpaqueDef (Opaqueproof.subst_opaque sub o) +let subst_const_proj sub pb = + { pb with proj_ind = subst_mind sub pb.proj_ind; + proj_type = subst_mps sub pb.proj_type; + proj_body = subst_const_type sub pb.proj_body } + let subst_const_body sub cb = assert (List.is_empty cb.const_hyps); (* we're outside sections *) if is_empty_subst sub then cb else let body' = subst_const_def sub cb.const_body in let type' = subst_const_type sub cb.const_type in - if body' == cb.const_body && type' == cb.const_type then cb + let proj' = Option.smartmap (subst_const_proj sub) cb.const_proj in + if body' == cb.const_body && type' == cb.const_type + && proj' == cb.const_proj then cb else { const_hyps = []; const_body = body'; const_type = type'; + const_proj = proj'; const_body_code = Cemitcodes.subst_to_patch_subst sub cb.const_body_code; - const_constraints = cb.const_constraints; + const_polymorphic = cb.const_polymorphic; + const_universes = cb.const_universes; const_inline_code = cb.const_inline_code } (** {7 Hash-consing of constants } *) @@ -89,16 +102,7 @@ let hcons_rel_decl ((n,oc,t) as d) = let hcons_rel_context l = List.smartmap hcons_rel_decl l -let hcons_polyarity ar = - { poly_param_levels = - List.smartmap (Option.smartmap Univ.hcons_univ) ar.poly_param_levels; - poly_level = Univ.hcons_univ ar.poly_level } - -let hcons_const_type = function - | NonPolymorphicType t -> - NonPolymorphicType (Term.hcons_constr t) - | PolymorphicArity (ctx,s) -> - PolymorphicArity (hcons_rel_context ctx, hcons_polyarity s) +let hcons_const_type t = Term.hcons_constr t let hcons_const_def = function | Undef inl -> Undef inl @@ -111,7 +115,11 @@ let hcons_const_body cb = { cb with const_body = hcons_const_def cb.const_body; const_type = hcons_const_type cb.const_type; - const_constraints = Univ.hcons_constraints cb.const_constraints; } + const_universes = + if Future.is_val cb.const_universes then + Future.from_val + (Univ.hcons_universe_context (Future.force cb.const_universes)) + else (* FIXME: Why not? *) cb.const_universes } (** {6 Inductive types } *) @@ -124,10 +132,10 @@ let eq_recarg r1 r2 = match r1, r2 with let subst_recarg sub r = match r with | Norec -> r | Mrec (kn,i) -> - let kn' = subst_ind sub kn in + let kn' = subst_mind sub kn in if kn==kn' then r else Mrec (kn',i) | Imbr (kn,i) -> - let kn' = subst_ind sub kn in + let kn' = subst_mind sub kn in if kn==kn' then r else Imbr (kn',i) let mk_norec = Rtree.mk_node Norec [||] @@ -156,63 +164,108 @@ let subst_wf_paths sub p = Rtree.smartmap (subst_recarg sub) p (** {7 Substitution of inductive declarations } *) -let subst_indarity sub ar = match ar with - | Monomorphic s -> - let uar' = subst_mps sub s.mind_user_arity in - if uar' == s.mind_user_arity then ar - else Monomorphic { mind_user_arity = uar'; mind_sort = s.mind_sort } - | Polymorphic _ -> ar - -let subst_mind_packet sub mip = - let { mind_nf_lc = nf; - mind_user_lc = user; - mind_arity_ctxt = ctxt; - mind_arity = ar; - mind_recargs = ra } = mip - in - let nf' = Array.smartmap (subst_mps sub) nf in - let user' = - (* maintain sharing of [mind_user_lc] and [mind_nf_lc] *) - if user==nf then nf' - else Array.smartmap (subst_mps sub) user - in - let ctxt' = subst_rel_context sub ctxt in - let ar' = subst_indarity sub ar in - let ra' = subst_wf_paths sub ra in - if nf==nf' && user==user' && ctxt==ctxt' && ar==ar' && ra==ra' - then mip - else - { mip with - mind_nf_lc = nf'; - mind_user_lc = user'; - mind_arity_ctxt = ctxt'; - mind_arity = ar'; - mind_recargs = ra' } - -let subst_mind sub mib = - assert (List.is_empty mib.mind_hyps); (* we're outside sections *) - if is_empty_subst sub then mib - else - let params = mib.mind_params_ctxt in - let params' = Context.map_rel_context (subst_mps sub) params in - let packets = mib.mind_packets in - let packets' = Array.smartmap (subst_mind_packet sub) packets in - if params==params' && packets==packets' then mib - else - { mib with - mind_params_ctxt = params'; - mind_packets = packets' } - -(** {6 Hash-consing of inductive declarations } *) - -(** Just as for constants, this hash-consing is quite partial *) - -let hcons_indarity = function - | Monomorphic a -> - Monomorphic - { mind_user_arity = Term.hcons_constr a.mind_user_arity; - mind_sort = Term.hcons_sorts a.mind_sort } - | Polymorphic a -> Polymorphic (hcons_polyarity a) +(* OLD POLYMORPHISM *) +(* let subst_indarity sub ar = match ar with *) +(* | Monomorphic s -> *) +(* let uar' = subst_mps sub s.mind_user_arity in *) +(* if uar' == s.mind_user_arity then ar *) +(* else Monomorphic { mind_user_arity = uar'; mind_sort = s.mind_sort } *) +(* | Polymorphic _ -> ar *) + +(* let subst_mind_packet sub mip = *) +(* let { mind_nf_lc = nf; *) +(* mind_user_lc = user; *) +(* mind_arity_ctxt = ctxt; *) +(* mind_arity = ar; *) +(* mind_recargs = ra } = mip *) +(* in *) +(* let nf' = Array.smartmap (subst_mps sub) nf in *) +(* let user' = *) +(* (\* maintain sharing of [mind_user_lc] and [mind_nf_lc] *\) *) +(* if user==nf then nf' *) +(* else Array.smartmap (subst_mps sub) user *) +(* in *) +(* let ctxt' = subst_rel_context sub ctxt in *) +(* let ar' = subst_indarity sub ar in *) +(* let ra' = subst_wf_paths sub ra in *) +(* if nf==nf' && user==user' && ctxt==ctxt' && ar==ar' && ra==ra' *) +(* then mip *) +(* else *) +(* { mip with *) +(* mind_nf_lc = nf'; *) +(* mind_user_lc = user'; *) +(* mind_arity_ctxt = ctxt'; *) +(* mind_arity = ar'; *) +(* mind_recargs = ra' } *) + +(* let subst_mind sub mib = *) +(* assert (List.is_empty mib.mind_hyps); (\* we're outside sections *\) *) +(* if is_empty_subst sub then mib *) +(* else *) +(* let params = mib.mind_params_ctxt in *) +(* let params' = Context.map_rel_context (subst_mps sub) params in *) +(* let packets = mib.mind_packets in *) +(* let packets' = Array.smartmap (subst_mind_packet sub) packets in *) +(* if params==params' && packets==packets' then mib *) +(* else *) +(* { mib with *) +(* mind_params_ctxt = params'; *) +(* mind_packets = packets'; *) +(* mind_native_name = ref NotLinked } *) + +(* (\** {6 Hash-consing of inductive declarations } *\) *) + +(* (\** Just as for constants, this hash-consing is quite partial *\) *) + +(* let hcons_indarity = function *) +(* | Monomorphic a -> *) +(* Monomorphic *) +(* { mind_user_arity = Term.hcons_constr a.mind_user_arity; *) +(* mind_sort = Term.hcons_sorts a.mind_sort } *) +(* | Polymorphic a -> Polymorphic (hcons_polyarity a) *) + +(** Substitution of inductive declarations *) + +let subst_indarity sub s = + { mind_user_arity = subst_mps sub s.mind_user_arity; + mind_sort = s.mind_sort; + } + +let subst_mind_packet sub mbp = + { mind_consnames = mbp.mind_consnames; + mind_consnrealdecls = mbp.mind_consnrealdecls; + mind_consnrealargs = mbp.mind_consnrealargs; + mind_typename = mbp.mind_typename; + mind_nf_lc = Array.smartmap (subst_mps sub) mbp.mind_nf_lc; + mind_arity_ctxt = subst_rel_context sub mbp.mind_arity_ctxt; + mind_arity = subst_indarity sub mbp.mind_arity; + mind_user_lc = Array.smartmap (subst_mps sub) mbp.mind_user_lc; + mind_nrealargs = mbp.mind_nrealargs; + mind_nrealargs_ctxt = mbp.mind_nrealargs_ctxt; + mind_kelim = mbp.mind_kelim; + mind_recargs = subst_wf_paths sub mbp.mind_recargs (*wf_paths*); + mind_nb_constant = mbp.mind_nb_constant; + mind_nb_args = mbp.mind_nb_args; + mind_reloc_tbl = mbp.mind_reloc_tbl } + +let subst_mind_body sub mib = + { mind_record = mib.mind_record ; + mind_finite = mib.mind_finite ; + mind_ntypes = mib.mind_ntypes ; + mind_hyps = (match mib.mind_hyps with [] -> [] | _ -> assert false); + mind_nparams = mib.mind_nparams; + mind_nparams_rec = mib.mind_nparams_rec; + mind_params_ctxt = + Context.map_rel_context (subst_mps sub) mib.mind_params_ctxt; + mind_packets = Array.smartmap (subst_mind_packet sub) mib.mind_packets ; + mind_polymorphic = mib.mind_polymorphic; + mind_universes = mib.mind_universes } + +(** Hash-consing of inductive declarations *) + +let hcons_indarity a = + { mind_user_arity = Term.hcons_constr a.mind_user_arity; + mind_sort = Term.hcons_sorts a.mind_sort } let hcons_mind_packet oib = let user = Array.smartmap Term.hcons_types oib.mind_user_lc in @@ -231,11 +284,12 @@ let hcons_mind mib = { mib with mind_packets = Array.smartmap hcons_mind_packet mib.mind_packets; mind_params_ctxt = hcons_rel_context mib.mind_params_ctxt; - mind_constraints = Univ.hcons_constraints mib.mind_constraints } + mind_universes = Univ.hcons_universe_context mib.mind_universes } (** {6 Stm machinery } *) let join_constant_body cb = + ignore(Future.join cb.const_universes); match cb.const_body with | OpaqueDef o -> Opaqueproof.join_opaque o | _ -> () diff --git a/kernel/declareops.mli b/kernel/declareops.mli index 800b167ab..0c5f3584e 100644 --- a/kernel/declareops.mli +++ b/kernel/declareops.mli @@ -57,7 +57,7 @@ val recarg_length : wf_paths -> int -> int val subst_wf_paths : substitution -> wf_paths -> wf_paths -val subst_mind : substitution -> mutual_inductive_body -> mutual_inductive_body +val subst_mind_body : substitution -> mutual_inductive_body -> mutual_inductive_body val join_constant_body : constant_body -> unit diff --git a/kernel/entries.mli b/kernel/entries.mli index 73efc7372..24e029bc0 100644 --- a/kernel/entries.mli +++ b/kernel/entries.mli @@ -44,12 +44,16 @@ type mutual_inductive_entry = { mind_entry_record : bool; mind_entry_finite : bool; mind_entry_params : (Id.t * local_entry) list; - mind_entry_inds : one_inductive_entry list } + mind_entry_inds : one_inductive_entry list; + mind_entry_polymorphic : bool; + mind_entry_universes : Univ.universe_context } (** {6 Constants (Definition/Axiom) } *) type proof_output = constr * Declareops.side_effects type const_entry_body = proof_output Future.computation +type projection = mutual_inductive * int * int * types + type definition_entry = { const_entry_body : const_entry_body; (* List of sectoin variables *) @@ -57,12 +61,16 @@ type definition_entry = { (* State id on which the completion of type checking is reported *) const_entry_feedback : Stateid.t option; const_entry_type : types option; + const_entry_polymorphic : bool; + const_entry_universes : Univ.universe_context; + const_entry_proj : projection option; const_entry_opaque : bool; const_entry_inline_code : bool } type inline = int option (* inlining level, None for no inlining *) -type parameter_entry = Context.section_context option * types * inline +type parameter_entry = + Context.section_context option * bool * types Univ.in_universe_context * inline type constant_entry = | DefinitionEntry of definition_entry diff --git a/kernel/environ.ml b/kernel/environ.ml index d306599ad..323d6fcea 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -26,7 +26,6 @@ open Names open Term open Context open Vars -open Univ open Declarations open Pre_env @@ -46,6 +45,12 @@ let empty_named_context_val = empty_named_context_val let empty_env = empty_env let engagement env = env.env_stratification.env_engagement + +let is_impredicative_set env = + match engagement env with + | Some ImpredicativeSet -> true + | _ -> false + let universes env = env.env_stratification.env_universes let named_context env = env.env_named_context let named_context_val env = env.env_named_context,env.env_named_vals @@ -160,6 +165,30 @@ let fold_named_context f env ~init = let fold_named_context_reverse f ~init env = Context.fold_named_context_reverse f ~init:init (named_context env) + +(* Universe constraints *) + +let add_constraints c env = + if Univ.Constraint.is_empty c then + env + else + let s = env.env_stratification in + { env with env_stratification = + { s with env_universes = Univ.merge_constraints c s.env_universes } } + +let check_constraints c env = + Univ.check_constraints c env.env_stratification.env_universes + +let set_engagement c env = (* Unsafe *) + { env with env_stratification = + { env.env_stratification with env_engagement = Some c } } + +let push_constraints_to_env (_,univs) env = + add_constraints univs env + +let push_context ctx env = add_constraints (Univ.UContext.constraints ctx) env +let push_context_set ctx env = add_constraints (Univ.ContextSet.constraints ctx) env + (* Global constants *) let lookup_constant = lookup_constant @@ -177,30 +206,113 @@ let add_constant_key kn cb linkinfo env = let add_constant kn cb env = add_constant_key kn cb (no_link_info ()) env +let universes_of cb = + Future.force cb.const_universes + +let universes_and_subst_of cb u = + let univs = universes_of cb in + let subst = Univ.make_universe_subst u univs in + subst, Univ.instantiate_univ_context subst univs + (* constant_type gives the type of a constant *) -let constant_type env kn = +let constant_type env (kn,u) = let cb = lookup_constant kn env in - cb.const_type + if cb.const_polymorphic then + let subst, csts = universes_and_subst_of cb u in + (subst_univs_constr subst cb.const_type, csts) + else cb.const_type, Univ.Constraint.empty -type const_evaluation_result = NoBody | Opaque +let constant_type_in_ctx env kn = + let cb = lookup_constant kn env in + cb.const_type, Future.force cb.const_universes + +let constant_context env kn = + let cb = lookup_constant kn env in + if cb.const_polymorphic then Future.force cb.const_universes + else Univ.UContext.empty + +type const_evaluation_result = NoBody | Opaque | IsProj exception NotEvaluableConst of const_evaluation_result -let constant_value env kn = +let constant_value env (kn,u) = + let cb = lookup_constant kn env in + if cb.const_proj = None then + match cb.const_body with + | Def l_body -> + if cb.const_polymorphic then + let subst, csts = universes_and_subst_of cb u in + (subst_univs_constr subst (Mod_subst.force_constr l_body), csts) + else Mod_subst.force_constr l_body, Univ.Constraint.empty + | OpaqueDef _ -> raise (NotEvaluableConst Opaque) + | Undef _ -> raise (NotEvaluableConst NoBody) + else raise (NotEvaluableConst IsProj) + +let constant_opt_value env cst = + try Some (constant_value env cst) + with NotEvaluableConst _ -> None + +let constant_value_and_type env (kn, u) = + let cb = lookup_constant kn env in + if cb.const_polymorphic then + let subst, cst = universes_and_subst_of cb u in + let b' = match cb.const_body with + | Def l_body -> Some (subst_univs_constr subst (Mod_subst.force_constr l_body)) + | OpaqueDef _ -> None + | Undef _ -> None + in b', subst_univs_constr subst cb.const_type, cst + else + let b' = match cb.const_body with + | Def l_body -> Some (Mod_subst.force_constr l_body) + | OpaqueDef _ -> None + | Undef _ -> None + in b', cb.const_type, Univ.Constraint.empty + +(* These functions should be called under the invariant that [env] + already contains the constraints corresponding to the constant + application. *) + +(* constant_type gives the type of a constant *) +let constant_type_in env (kn,u) = + let cb = lookup_constant kn env in + if cb.const_polymorphic then + let subst = Univ.make_universe_subst u (Future.force cb.const_universes) in + subst_univs_constr subst cb.const_type + else cb.const_type + +let constant_value_in env (kn,u) = let cb = lookup_constant kn env in match cb.const_body with - | Def l_body -> Mod_subst.force_constr l_body + | Def l_body -> + let b = Mod_subst.force_constr l_body in + if cb.const_polymorphic then + let subst = Univ.make_universe_subst u (Future.force cb.const_universes) in + subst_univs_constr subst b + else b | OpaqueDef _ -> raise (NotEvaluableConst Opaque) | Undef _ -> raise (NotEvaluableConst NoBody) -let constant_opt_value env cst = - try Some (constant_value env cst) +let constant_opt_value_in env cst = + try Some (constant_value_in env cst) with NotEvaluableConst _ -> None (* A global const is evaluable if it is defined and not opaque *) -let evaluable_constant cst env = - try let _ = constant_value env cst in true - with NotEvaluableConst _ -> false +let evaluable_constant kn env = + let cb = lookup_constant kn env in + match cb.const_body with + | Def _ -> true + | OpaqueDef _ -> false + | Undef _ -> false + +let lookup_projection cst env = + match (lookup_constant cst env).const_proj with + | Some pb -> pb + | None -> anomaly (Pp.str "lookup_projection: constant is not a projection") + +let is_projection cst env = + match (lookup_constant cst env).const_proj with + | Some _ -> true + | None -> false (* Mutual Inductives *) let lookup_mind = lookup_mind @@ -215,21 +327,10 @@ let add_mind_key kn mind_key env = let add_mind kn mib env = let li = no_link_info () in add_mind_key kn (mib, li) env -(* Universe constraints *) - -let add_constraints c env = - if is_empty_constraint c then - env - else - let s = env.env_stratification in - { env with env_stratification = - { s with env_universes = merge_constraints c s.env_universes } } +(* Lookup of section variables *) -let set_engagement c env = (* Unsafe *) - { env with env_stratification = - { env.env_stratification with env_engagement = Some c } } +let constant_body_hyps cb = cb.const_hyps -(* Lookup of section variables *) let lookup_constant_variables c env = let cmap = lookup_constant c env in Context.vars_of_named_context cmap.const_hyps @@ -246,9 +347,10 @@ let lookup_constructor_variables (ind,_) env = let vars_of_global env constr = match kind_of_term constr with Var id -> Id.Set.singleton id - | Const kn -> lookup_constant_variables kn env - | Ind ind -> lookup_inductive_variables ind env - | Construct cstr -> lookup_constructor_variables cstr env + | Const (kn, _) -> lookup_constant_variables kn env + | Ind (ind, _) -> lookup_inductive_variables ind env + | Construct (cstr, _) -> lookup_constructor_variables cstr env + (** FIXME: is Proj missing? *) | _ -> raise Not_found let global_vars_set env constr = @@ -423,7 +525,7 @@ let unregister env field = is abstract, and that the only function which add elements to the retroknowledge is Environ.register which enforces this shape *) (match kind_of_term (retroknowledge find env field) with - | Ind i31t -> let i31c = mkConstruct (i31t, 1) in + | Ind i31t -> let i31c = mkConstructUi (i31t, 1) in {env with retroknowledge = remove (retroknowledge clear_info env i31c) field} | _ -> assert false) @@ -487,7 +589,7 @@ let register = let add_int31_before_match rk grp v = let rk = add_vm_before_match_info rk v Cbytegen.int31_escape_before_match in match kind_of_term (Retroknowledge.find rk (KInt31 (grp,Int31Bits))) with - | Ind i31bit_type -> + | Ind (i31bit_type,_) -> add_native_before_match_info rk v (Nativelambda.before_match_int31 i31bit_type) | _ -> anomaly ~label:"Environ.register" (Pp.str "Int31Bits should be an inductive type") @@ -498,13 +600,13 @@ fun env field value -> operators to the reactive retroknowledge. *) let add_int31_binop_from_const op prim = match kind_of_term value with - | Const kn -> retroknowledge add_int31_op env value 2 + | Const (kn,_) -> retroknowledge add_int31_op env value 2 op prim kn | _ -> anomaly ~label:"Environ.register" (Pp.str "should be a constant") in let add_int31_unop_from_const op prim = match kind_of_term value with - | Const kn -> retroknowledge add_int31_op env value 1 + | Const (kn,_) -> retroknowledge add_int31_op env value 1 op prim kn | _ -> anomaly ~label:"Environ.register" (Pp.str "should be a constant") in @@ -516,9 +618,9 @@ fun env field value -> match field with | KInt31 (grp, Int31Type) -> (match kind_of_term (Retroknowledge.find rk (KInt31 (grp,Int31Bits))) with - | Ind i31bit_type -> + | Ind (i31bit_type,_) -> (match kind_of_term value with - | Ind i31t -> + | Ind (i31t,_) -> Retroknowledge.add_vm_decompile_constant_info rk value (constr_of_int31 i31t i31bit_type) | _ -> anomaly ~label:"Environ.register" (Pp.str "should be an inductive type")) @@ -530,7 +632,7 @@ fun env field value -> match field with | KInt31 (grp, Int31Type) -> let i31c = match kind_of_term value with - | Ind i31t -> mkConstruct (i31t, 1) + | Ind i31t -> mkConstructUi (i31t, 1) | _ -> anomaly ~label:"Environ.register" (Pp.str "should be an inductive type") in add_int31_decompilation_from_type @@ -554,7 +656,7 @@ fun env field value -> Primitives.Int31mulc | KInt31 (_, Int31Div21) -> (* this is a ternary operation *) (match kind_of_term value with - | Const kn -> + | Const (kn,u) -> retroknowledge add_int31_op env value 3 Cbytecodes.Kdiv21int31 Primitives.Int31div21 kn | _ -> anomaly ~label:"Environ.register" (Pp.str "should be a constant")) @@ -562,7 +664,7 @@ fun env field value -> Primitives.Int31div | KInt31 (_, Int31AddMulDiv) -> (* this is a ternary operation *) (match kind_of_term value with - | Const kn -> + | Const (kn,u) -> retroknowledge add_int31_op env value 3 Cbytecodes.Kaddmuldivint31 Primitives.Int31addmuldiv kn | _ -> anomaly ~label:"Environ.register" (Pp.str "should be a constant")) diff --git a/kernel/environ.mli b/kernel/environ.mli index 652cd59bf..fb5d79718 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -10,6 +10,7 @@ open Names open Term open Context open Declarations +open Univ (** Unsafe environments. We define here a datatype for environments. Since typing is not yet defined, it is not possible to check the @@ -47,6 +48,7 @@ val named_context_val : env -> named_context_val val engagement : env -> engagement option +val is_impredicative_set : env -> bool (** is the local context empty *) val empty_context : env -> bool @@ -125,17 +127,36 @@ val add_constant_key : constant -> constant_body -> Pre_env.link_info ref -> val lookup_constant : constant -> env -> constant_body val evaluable_constant : constant -> env -> bool +val lookup_projection : Names.projection -> env -> projection_body +val is_projection : constant -> env -> bool + (** {6 ... } *) (** [constant_value env c] raises [NotEvaluableConst Opaque] if [c] is opaque and [NotEvaluableConst NoBody] if it has no - body and [Not_found] if it does not exist in [env] *) + body and [NotEvaluableConst IsProj] if [c] is a projection + and [Not_found] if it does not exist in [env] *) -type const_evaluation_result = NoBody | Opaque +type const_evaluation_result = NoBody | Opaque | IsProj exception NotEvaluableConst of const_evaluation_result -val constant_value : env -> constant -> constr -val constant_type : env -> constant -> constant_type -val constant_opt_value : env -> constant -> constr option +val constant_value : env -> constant puniverses -> constr constrained +val constant_type : env -> constant puniverses -> types constrained +val constant_type_in_ctx : env -> constant -> types Univ.in_universe_context + +val constant_opt_value : env -> constant puniverses -> (constr * Univ.constraints) option +val constant_value_and_type : env -> constant puniverses -> + types option * constr * Univ.constraints +(** The universe context associated to the constant, empty if not + polymorphic *) +val constant_context : env -> constant -> Univ.universe_context + +(* These functions should be called under the invariant that [env] + already contains the constraints corresponding to the constant + application. *) +val constant_value_in : env -> constant puniverses -> constr +val constant_type_in : env -> constant puniverses -> types +val constant_opt_value_in : env -> constant puniverses -> constr option + (** {5 Inductive types } *) val add_mind_key : mutual_inductive -> Pre_env.mind_key -> env -> env @@ -157,8 +178,17 @@ val lookup_modtype : module_path -> env -> module_type_body (** {5 Universe constraints } *) +(** Add universe constraints to the environment. + @raises UniverseInconsistency +*) val add_constraints : Univ.constraints -> env -> env +(** Check constraints are satifiable in the environment. *) +val check_constraints : Univ.constraints -> env -> bool +val push_context : Univ.universe_context -> env -> env +val push_context_set : Univ.universe_context_set -> env -> env +val push_constraints_to_env : 'a Univ.constrained -> env -> env + val set_engagement : engagement -> env -> env (** {6 Sets of referred section variables } diff --git a/kernel/fast_typeops.ml b/kernel/fast_typeops.ml new file mode 100644 index 000000000..b441e02a3 --- /dev/null +++ b/kernel/fast_typeops.ml @@ -0,0 +1,475 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Errors +open Util +open Names +open Univ +open Term +open Vars +open Context +open Declarations +open Environ +open Entries +open Reduction +open Inductive +open Type_errors + +let conv_leq l2r env x y = default_conv CUMUL ~l2r env x y + +let conv_leq_vecti env v1 v2 = + Array.fold_left2_i + (fun i _ t1 t2 -> + try conv_leq false env t1 t2 + with NotConvertible -> raise (NotConvertibleVect i)) + () + v1 + v2 + +let check_constraints cst env = + if Environ.check_constraints cst env then () + else error_unsatisfied_constraints env cst + +(* This should be a type (a priori without intension to be an assumption) *) +let type_judgment env c t = + match kind_of_term(whd_betadeltaiota env t) with + | Sort s -> {utj_val = c; utj_type = s } + | _ -> error_not_type env (make_judge c t) + +let check_type env c t = + match kind_of_term(whd_betadeltaiota env t) with + | Sort s -> s + | _ -> error_not_type env (make_judge c t) + +(* This should be a type intended to be assumed. The error message is *) +(* not as useful as for [type_judgment]. *) +let assumption_of_judgment env t ty = + try let _ = check_type env t ty in t + with TypeError _ -> + error_assumption env (make_judge t ty) + +(************************************************) +(* Incremental typing rules: builds a typing judgement given the *) +(* judgements for the subterms. *) + +(*s Type of sorts *) + +(* Prop and Set *) + +let judge_of_prop = mkSort type1_sort +let judge_of_set = judge_of_prop + +let judge_of_prop_contents _ = judge_of_prop + +(* Type of Type(i). *) + +let judge_of_type u = + let uu = Universe.super u in + mkType uu + +(*s Type of a de Bruijn index. *) + +let judge_of_relative env n = + try + let (_,_,typ) = lookup_rel n env in + lift n typ + with Not_found -> + error_unbound_rel env n + +(* Type of variables *) +let judge_of_variable env id = + try named_type id env + with Not_found -> + error_unbound_var env id + +(* Management of context of variables. *) + +(* Checks if a context of variables can be instantiated by the + variables of the current env *) +(* TODO: check order? *) +let check_hyps_inclusion env f c sign = + Context.fold_named_context + (fun (id,_,ty1) () -> + try + let ty2 = named_type id env in + if not (eq_constr ty2 ty1) then raise Exit + with Not_found | Exit -> + error_reference_variables env id (f c)) + sign + ~init:() + +(* Instantiation of terms on real arguments. *) + +(* Make a type polymorphic if an arity *) + +(* Type of constants *) + +let type_of_constant env cst = constant_type env cst +let type_of_constant_in env cst = constant_type_in env cst +let type_of_constant_knowing_parameters env t _ = t + +let judge_of_constant env (kn,u as cst) = + let cb = lookup_constant kn env in + let () = check_hyps_inclusion env mkConstU cst cb.const_hyps in + let ty, cu = type_of_constant env cst in + let () = check_constraints cu env in + ty + +let type_of_projection env (cst,u) = + let cb = lookup_constant cst env in + match cb.const_proj with + | Some pb -> + if cb.const_polymorphic then + let mib,_ = lookup_mind_specif env (pb.proj_ind,0) in + let subst = make_inductive_subst mib u in + Vars.subst_univs_constr subst pb.proj_type + else pb.proj_type + | None -> raise (Invalid_argument "type_of_projection: not a projection") + + +(* Type of a lambda-abstraction. *) + +(* [judge_of_abstraction env name var j] implements the rule + + env, name:typ |- j.uj_val:j.uj_type env, |- (name:typ)j.uj_type : s + ----------------------------------------------------------------------- + env |- [name:typ]j.uj_val : (name:typ)j.uj_type + + Since all products are defined in the Calculus of Inductive Constructions + and no upper constraint exists on the sort $s$, we don't need to compute $s$ +*) + +let judge_of_abstraction env name var ty = + mkProd (name, var, ty) + +(* Type of let-in. *) + +let judge_of_letin env name defj typj j = + subst1 defj j + +(* Type of an application. *) + +let make_judgev c t = + Array.map2 make_judge c t + +let judge_of_apply env func funt argsv argstv = + let len = Array.length argsv in + let rec apply_rec i typ = + if Int.equal i len then typ + else + (match kind_of_term (whd_betadeltaiota env typ) with + | Prod (_,c1,c2) -> + let arg = argsv.(i) and argt = argstv.(i) in + (try + let () = conv_leq false env argt c1 in + apply_rec (i+1) (subst1 arg c2) + with NotConvertible -> + error_cant_apply_bad_type env + (i+1,c1,argt) + (make_judge func funt) + (make_judgev argsv argstv)) + + | _ -> + error_cant_apply_not_functional env + (make_judge func funt) + (make_judgev argsv argstv)) + in apply_rec 0 funt + +(* Type of product *) + +let sort_of_product env domsort rangsort = + match (domsort, rangsort) with + (* Product rule (s,Prop,Prop) *) + | (_, Prop Null) -> rangsort + (* Product rule (Prop/Set,Set,Set) *) + | (Prop _, Prop Pos) -> rangsort + (* Product rule (Type,Set,?) *) + | (Type u1, Prop Pos) -> + begin match engagement env with + | Some ImpredicativeSet -> + (* Rule is (Type,Set,Set) in the Set-impredicative calculus *) + rangsort + | _ -> + (* Rule is (Type_i,Set,Type_i) in the Set-predicative calculus *) + Type (Universe.sup Universe.type0 u1) + end + (* Product rule (Prop,Type_i,Type_i) *) + | (Prop Pos, Type u2) -> Type (Universe.sup Universe.type0 u2) + (* Product rule (Prop,Type_i,Type_i) *) + | (Prop Null, Type _) -> rangsort + (* Product rule (Type_i,Type_i,Type_i) *) + | (Type u1, Type u2) -> Type (Universe.sup u1 u2) + +(* [judge_of_product env name (typ1,s1) (typ2,s2)] implements the rule + + env |- typ1:s1 env, name:typ1 |- typ2 : s2 + ------------------------------------------------------------------------- + s' >= (s1,s2), env |- (name:typ)j.uj_val : s' + + where j.uj_type is convertible to a sort s2 +*) +let judge_of_product env name s1 s2 = + let s = sort_of_product env s1 s2 in + mkSort s + +(* Type of a type cast *) + +(* [judge_of_cast env (c,typ1) (typ2,s)] implements the rule + + env |- c:typ1 env |- typ2:s env |- typ1 <= typ2 + --------------------------------------------------------------------- + env |- c:typ2 +*) + +let judge_of_cast env c ct k expected_type = + try + match k with + | VMcast -> + vm_conv CUMUL env ct expected_type + | DEFAULTcast -> + default_conv ~l2r:false CUMUL env ct expected_type + | REVERTcast -> + default_conv ~l2r:true CUMUL env ct expected_type + | NATIVEcast -> + let sigma = Nativelambda.empty_evars in + native_conv CUMUL sigma env ct expected_type + with NotConvertible -> + error_actual_type env (make_judge c ct) expected_type + +(* Inductive types. *) + +(* The type is parametric over the uniform parameters whose conclusion + is in Type; to enforce the internal constraints between the + parameters and the instances of Type occurring in the type of the + constructors, we use the level variables _statically_ assigned to + the conclusions of the parameters as mediators: e.g. if a parameter + has conclusion Type(alpha), static constraints of the form alpha<=v + exist between alpha and the Type's occurring in the constructor + types; when the parameters is finally instantiated by a term of + conclusion Type(u), then the constraints u<=alpha is computed in + the App case of execute; from this constraints, the expected + dynamic constraints of the form u<=v are enforced *) + +(* let judge_of_inductive_knowing_parameters env ind jl = *) +(* let c = mkInd ind in *) +(* let (mib,mip) = lookup_mind_specif env ind in *) +(* check_args env c mib.mind_hyps; *) +(* let paramstyp = Array.map (fun j -> j.uj_type) jl in *) +(* let t = in *) +(* make_judge c t *) + +let judge_of_inductive env (ind,u as indu) = + let (mib,mip) = lookup_mind_specif env ind in + check_hyps_inclusion env mkIndU indu mib.mind_hyps; + let t,cst = Inductive.constrained_type_of_inductive env ((mib,mip),u) in + check_constraints cst env; + t + +(* Constructors. *) + +let judge_of_constructor env (c,u as cu) = + let _ = + let ((kn,_),_) = c in + let mib = lookup_mind kn env in + check_hyps_inclusion env mkConstructU cu mib.mind_hyps in + let specif = lookup_mind_specif env (inductive_of_constructor c) in + let t,cst = constrained_type_of_constructor cu specif in + let () = check_constraints cst env in + t + +(* Case. *) + +let check_branch_types env (ind,u) c ct lft explft = + try conv_leq_vecti env lft explft + with + NotConvertibleVect i -> + error_ill_formed_branch env c ((ind,i+1),u) lft.(i) explft.(i) + | Invalid_argument _ -> + error_number_branches env (make_judge c ct) (Array.length explft) + +let judge_of_case env ci p pt c ct lf lft = + let (pind, _ as indspec) = + try find_rectype env ct + with Not_found -> error_case_not_inductive env (make_judge c ct) in + let _ = check_case_info env pind ci in + let (bty,rslty) = + type_case_branches env indspec (make_judge p pt) c in + let () = check_branch_types env pind c ct lft bty in + rslty + +let judge_of_projection env p c ct = + let pb = lookup_projection p env in + let (ind,u), args = + try find_rectype env ct + with Not_found -> error_case_not_inductive env (make_judge c ct) + in + assert(eq_mind pb.proj_ind (fst ind)); + let usubst = make_inductive_subst (fst (lookup_mind_specif env ind)) u in + let ty = Vars.subst_univs_constr usubst pb.Declarations.proj_type in + substl (c :: List.rev args) ty + + +(* Fixpoints. *) + +(* Checks the type of a general (co)fixpoint, i.e. without checking *) +(* the specific guard condition. *) + +let type_fixpoint env lna lar vdef vdeft = + let lt = Array.length vdeft in + assert (Int.equal (Array.length lar) lt); + try + conv_leq_vecti env vdeft (Array.map (fun ty -> lift lt ty) lar) + with NotConvertibleVect i -> + error_ill_typed_rec_body env i lna (make_judgev vdef vdeft) lar + +(************************************************************************) +(************************************************************************) + +(* The typing machine. *) + (* ATTENTION : faudra faire le typage du contexte des Const, + Ind et Constructsi un jour cela devient des constructions + arbitraires et non plus des variables *) +let rec execute env cstr = + match kind_of_term cstr with + (* Atomic terms *) + | Sort (Prop c) -> + judge_of_prop_contents c + + | Sort (Type u) -> + judge_of_type u + + | Rel n -> + judge_of_relative env n + + | Var id -> + judge_of_variable env id + + | Const c -> + judge_of_constant env c + + | Proj (p, c) -> + let ct = execute env c in + judge_of_projection env p c ct + + (* Lambda calculus operators *) + | App (f,args) -> + let argst = execute_array env args in + let ft = execute env f in + judge_of_apply env f ft args argst + + | Lambda (name,c1,c2) -> + let _ = execute_is_type env c1 in + let env1 = push_rel (name,None,c1) env in + let c2t = execute env1 c2 in + judge_of_abstraction env name c1 c2t + + | Prod (name,c1,c2) -> + let vars = execute_is_type env c1 in + let env1 = push_rel (name,None,c1) env in + let vars' = execute_is_type env1 c2 in + judge_of_product env name vars vars' + + | LetIn (name,c1,c2,c3) -> + let c1t = execute env c1 in + let _c2s = execute_is_type env c2 in + let _ = judge_of_cast env c1 c1t DEFAULTcast c2 in + let env1 = push_rel (name,Some c1,c2) env in + let c3t = execute env1 c3 in + subst1 c1 c3t + + | Cast (c,k,t) -> + let ct = execute env c in + let _ts = execute_type env t in + let _ = judge_of_cast env c ct k t in + t + + (* Inductive types *) + | Ind ind -> + judge_of_inductive env ind + + | Construct c -> + judge_of_constructor env c + + | Case (ci,p,c,lf) -> + let ct = execute env c in + let pt = execute env p in + let lft = execute_array env lf in + judge_of_case env ci p pt c ct lf lft + + | Fix ((vn,i as vni),recdef) -> + let (fix_ty,recdef') = execute_recdef env recdef i in + let fix = (vni,recdef') in + check_fix env fix; fix_ty + + | CoFix (i,recdef) -> + let (fix_ty,recdef') = execute_recdef env recdef i in + let cofix = (i,recdef') in + check_cofix env cofix; fix_ty + + (* Partial proofs: unsupported by the kernel *) + | Meta _ -> + anomaly (Pp.str "the kernel does not support metavariables") + + | Evar _ -> + anomaly (Pp.str "the kernel does not support existential variables") + +and execute_is_type env constr = + let t = execute env constr in + check_type env constr t + +and execute_type env constr = + let t = execute env constr in + type_judgment env constr t + +and execute_recdef env (names,lar,vdef) i = + let lart = execute_array env lar in + let lara = Array.map2 (assumption_of_judgment env) lar lart in + let env1 = push_rec_types (names,lara,vdef) env in + let vdeft = execute_array env1 vdef in + let () = type_fixpoint env1 names lara vdef vdeft in + (lara.(i),(names,lara,vdef)) + +and execute_array env = Array.map (execute env) + +(* Derived functions *) +let infer env constr = + let t = execute env constr in + make_judge constr t + +(* let infer_key = Profile.declare_profile "Fast_infer" *) +(* let infer = Profile.profile2 infer_key infer *) + +let infer_type env constr = + execute_type env constr + +let infer_v env cv = + let jv = execute_array env cv in + make_judgev cv jv + +(* Typing of several terms. *) + +let infer_local_decl env id = function + | LocalDef c -> + let t = execute env c in + (Name id, Some c, t) + | LocalAssum c -> + let t = execute env c in + (Name id, None, assumption_of_judgment env c t) + +let infer_local_decls env decls = + let rec inferec env = function + | (id, d) :: l -> + let (env, l) = inferec env l in + let d = infer_local_decl env id d in + (push_rel d env, add_rel_decl d l) + | [] -> (env, empty_rel_context) in + inferec env decls + +(* Exported typing functions *) + +let typing env c = infer env c diff --git a/kernel/fast_typeops.mli b/kernel/fast_typeops.mli new file mode 100644 index 000000000..7ff5577cb --- /dev/null +++ b/kernel/fast_typeops.mli @@ -0,0 +1,28 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Names +open Univ +open Term +open Context +open Environ +open Entries +open Declarations + +(** {6 Typing functions (not yet tagged as safe) } + + They return unsafe judgments that are "in context" of a set of + (local) universe variables (the ones that appear in the term) + and associated constraints. In case of polymorphic definitions, + these variables and constraints will be generalized. + *) + + +val infer : env -> constr -> unsafe_judgment +val infer_v : env -> constr array -> unsafe_judgment array +val infer_type : env -> types -> unsafe_type_judgment diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index 2defb66f4..0ac6a4e4a 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -20,6 +20,15 @@ open Environ open Reduction open Typeops open Entries +open Pp + +(* Tell if indices (aka real arguments) contribute to size of inductive type *) +(* If yes, this is compatible with the univalent model *) + +let indices_matter = ref false + +let enforce_indices_matter () = indices_matter := true +let is_indices_matter () = !indices_matter (* Same as noccur_between but may perform reductions. Could be refined more... *) @@ -107,26 +116,22 @@ let is_logic_constr infos = List.for_all (fun (logic,small) -> logic) infos *) let is_unit constrsinfos = match constrsinfos with (* One info = One constructor *) - | [constrinfos] -> is_logic_constr constrinfos + | [level] -> is_type0m_univ level | [] -> (* type without constructors *) true | _ -> false -let rec infos_and_sort env t = - let t = whd_betadeltaiota env t in - match kind_of_term t with - | Prod (name,c1,c2) -> - let (varj,_) = infer_type env c1 in +let infos_and_sort env ctx t = + let rec aux env ctx t max = + let t = whd_betadeltaiota env t in + match kind_of_term t with + | Prod (name,c1,c2) -> + let varj = infer_type env c1 in let env1 = Environ.push_rel (name,None,varj.utj_val) env in - let logic = is_logic_type varj in - let small = Term.is_small varj.utj_type in - (logic,small) :: (infos_and_sort env1 c2) - | _ when is_constructor_head t -> [] - | _ -> (* don't fail if not positive, it is tested later *) [] - -let small_unit constrsinfos = - let issmall = List.for_all is_small constrsinfos - and isunit = is_unit constrsinfos in - issmall, isunit + let max = Universe.sup max (univ_of_sort varj.utj_type) in + aux env1 ctx c2 max + | _ when is_constructor_head t -> max + | _ -> (* don't fail if not positive, it is tested later *) max + in aux env ctx t Universe.type0m (* Computing the levels of polymorphic inductive types @@ -148,40 +153,52 @@ let small_unit constrsinfos = w1,w2,w3 <= u3 *) -let extract_level (_,_,_,lc,lev) = +let extract_level (_,_,lc,(_,lev)) = (* Enforce that the level is not in Prop if more than one constructor *) - if Array.length lc >= 2 then sup type0_univ lev else lev + (* if Array.length lc >= 2 then sup type0_univ lev else lev *) + lev let inductive_levels arities inds = - let levels = Array.map pi3 arities in let cstrs_levels = Array.map extract_level inds in (* Take the transitive closure of the system of constructors *) (* level constraints and remove the recursive dependencies *) - solve_constraints_system levels cstrs_levels + cstrs_levels (* This (re)computes informations relevant to extraction and the sort of an arity or type constructor; we do not to recompute universes constraints *) -let constraint_list_union = - List.fold_left union_constraints empty_constraint +let context_set_list_union = + List.fold_left ContextSet.union ContextSet.empty -let infer_constructor_packet env_ar_par params lc = +let infer_constructor_packet env_ar_par ctx params lc = (* type-check the constructors *) - let jlc,cstl = List.split (List.map (infer_type env_ar_par) lc) in - let cst = constraint_list_union cstl in + let jlc = List.map (infer_type env_ar_par) lc in let jlc = Array.of_list jlc in (* generalize the constructor over the parameters *) let lc'' = Array.map (fun j -> it_mkProd_or_LetIn j.utj_val params) jlc in - (* compute the max of the sorts of the products of the constructor type *) - let level = max_inductive_sort (Array.map (fun j -> j.utj_type) jlc) in - (* compute *) - let info = small_unit (List.map (infos_and_sort env_ar_par) lc) in - - (info,lc'',level,cst) + (* compute the max of the sorts of the products of the constructors types *) + let levels = List.map (infos_and_sort env_ar_par ctx) lc in + let level = List.fold_left (fun max l -> Universe.sup max l) Universe.type0m levels in + (lc'',(is_unit levels,level)) + +(* If indices matter *) +let cumulate_arity_large_levels env sign = + fst (List.fold_right + (fun (_,_,t as d) (lev,env) -> + let tj = infer_type env t in + let u = univ_of_sort tj.utj_type in + (Universe.sup u lev, push_rel d env)) + sign (Universe.type0m,env)) + +let is_impredicative env u = + is_type0m_univ u || (is_type0_univ u && engagement env = Some ImpredicativeSet) (* Type-check an inductive definition. Does not check positivity conditions. *) -let typecheck_inductive env mie = +(* TODO check that we don't overgeneralize construcors/inductive arities with + universes that are absent from them. Is it possible? +*) +let typecheck_inductive env ctx mie = let () = match mie.mind_entry_inds with | [] -> anomaly (Pp.str "empty inductive types declaration") | _ -> () @@ -189,116 +206,103 @@ let typecheck_inductive env mie = (* Check unicity of names *) mind_check_names mie; (* Params are typed-checked here *) - let env_params, params, cst1 = infer_local_decls env mie.mind_entry_params in + let env' = push_context ctx env in + let (env_params, params) = infer_local_decls env' mie.mind_entry_params in (* We first type arity of each inductive definition *) (* This allows to build the environment of arities and to share *) (* the set of constraints *) - let cst, env_arities, rev_arity_list = + let env_arities, rev_arity_list = List.fold_left - (fun (cst,env_ar,l) ind -> + (fun (env_ar,l) ind -> (* Arities (without params) are typed-checked here *) - let arity, cst2 = infer_type env_params ind.mind_entry_arity in + let arity = + if isArity ind.mind_entry_arity then + let (ctx,s) = destArity ind.mind_entry_arity in + match s with + | Type u when Univ.universe_level u = None -> + (** We have an algebraic universe as the conclusion of the arity, + typecheck the dummy Î ctx, Prop and do a special case for the conclusion. + *) + let proparity = infer_type env_params (mkArity (ctx, prop_sort)) in + let (cctx, _) = destArity proparity.utj_val in + (* Any universe is well-formed, we don't need to check [s] here *) + mkArity (cctx, s) + | _ -> let arity = infer_type env_params ind.mind_entry_arity in + arity.utj_val + else let arity = infer_type env_params ind.mind_entry_arity in + arity.utj_val + in + let (sign, deflev) = dest_arity env_params arity in + let inflev = + (* The level of the inductive includes levels of indices if + in indices_matter mode *) + if !indices_matter + then Some (cumulate_arity_large_levels env_params sign) + else None + in (* We do not need to generate the universe of full_arity; if later, after the validation of the inductive definition, full_arity is used as argument or subject to cast, an upper universe will be generated *) - let full_arity = it_mkProd_or_LetIn arity.utj_val params in - let cst = union_constraints cst cst2 in + let full_arity = it_mkProd_or_LetIn arity params in let id = ind.mind_entry_typename in let env_ar' = - push_rel (Name id, None, full_arity) - (add_constraints cst2 env_ar) in - let lev = - (* Decide that if the conclusion is not explicitly Type *) - (* then the inductive type is not polymorphic *) - match kind_of_term ((strip_prod_assum arity.utj_val)) with - | Sort (Type u) -> Some u - | _ -> None in - (cst,env_ar',(id,full_arity,lev)::l)) - (cst1,env,[]) + push_rel (Name id, None, full_arity) env_ar in + (* (add_constraints cst2 env_ar) in *) + (env_ar', (id,full_arity,sign @ params,deflev,inflev)::l)) + (env',[]) mie.mind_entry_inds in let arity_list = List.rev rev_arity_list in (* builds the typing context "Gamma, I1:A1, ... In:An, params" *) - let env_ar_par = - push_rel_context params (add_constraints cst1 env_arities) in + let env_ar_par = push_rel_context params env_arities in (* Now, we type the constructors (without params) *) - let inds,cst = + let inds = List.fold_right2 - (fun ind arity_data (inds,cst) -> - let (info,lc',cstrs_univ,cst') = - infer_constructor_packet env_ar_par params ind.mind_entry_lc in + (fun ind arity_data inds -> + let (lc',cstrs_univ) = + infer_constructor_packet env_ar_par ContextSet.empty + params ind.mind_entry_lc in let consnames = ind.mind_entry_consnames in - let ind' = (arity_data,consnames,info,lc',cstrs_univ) in - (ind'::inds, union_constraints cst cst')) + let ind' = (arity_data,consnames,lc',cstrs_univ) in + ind'::inds) mie.mind_entry_inds arity_list - ([],cst) in + ([]) in let inds = Array.of_list inds in - let arities = Array.of_list arity_list in - let has_some_univ u = function - | Some v when Universe.equal u v -> true - | _ -> false - in - let remove_some_univ u = function - | Some v when Universe.equal u v -> None - | x -> x - in - let fold l (_, b, p) = match b with - | None -> - (* Parameter contributes to polymorphism only if explicit Type *) - let c = strip_prod_assum p in - (* Add Type levels to the ordered list of parameters contributing to *) - (* polymorphism unless there is aliasing (i.e. non distinct levels) *) - begin match kind_of_term c with - | Sort (Type u) -> - if List.exists (has_some_univ u) l then - None :: List.map (remove_some_univ u) l - else - Some u :: l - | _ -> - None :: l - end - | _ -> l - in - let param_ccls = List.fold_left fold [] params in (* Compute/check the sorts of the inductive types *) - let ind_min_levels = inductive_levels arities inds in - let inds, cst = - Array.fold_map2' (fun ((id,full_arity,ar_level),cn,info,lc,_) lev cst -> - let sign, s = - try dest_arity env full_arity - with NotArity -> raise (InductiveError (NotAnArity (env, full_arity))) + + let inds = + Array.map (fun ((id,full_arity,sign,def_level,inf_level),cn,lc,(is_unit,clev)) -> + let defu = Term.univ_of_sort def_level in + let infu = + (** Inferred level, with parameters and constructors. *) + match inf_level with + | Some alev -> Universe.sup clev alev + | None -> clev + in + let is_natural = + check_leq (universes env') infu defu && + not (is_type0m_univ defu && not is_unit) in - let status,cst = match s with - | Type u when ar_level != None (* Explicitly polymorphic *) - && no_upper_constraints u cst -> - (* The polymorphic level is a function of the level of the *) - (* conclusions of the parameters *) - (* We enforce [u >= lev] in case [lev] has a strict upper *) - (* constraints over [u] *) - Inr (param_ccls, lev), enforce_leq lev u cst - | Type u (* Not an explicit occurrence of Type *) -> - Inl (info,full_arity,s), enforce_leq lev u cst - | Prop Pos when - begin match engagement env with - | Some ImpredicativeSet -> false - | _ -> true - end -> - (* Predicative set: check that the content is indeed predicative *) - if not (is_type0m_univ lev) && not (is_type0_univ lev) then - raise (InductiveError LargeNonPropInductiveNotInType); - Inl (info,full_arity,s), cst - | Prop _ -> - Inl (info,full_arity,s), cst in - (id,cn,lc,(sign,status)),cst) - inds ind_min_levels cst in - - (env_arities, params, inds, cst) + let _ = + (** Impredicative sort, always allow *) + if is_impredicative env defu then () + else (** Predicative case: the inferred level must be lower or equal to the + declared level. *) + if not is_natural then + anomaly ~label:"check_inductive" + (Pp.str"Incorrect universe " ++ + Universe.pr defu ++ Pp.str " declared for inductive type, inferred level is " + ++ Universe.pr infu) + in + (id,cn,lc,(sign,(not is_natural,full_arity,defu)))) + inds + in (env_arities, params, inds) (************************************************************************) (************************************************************************) @@ -387,7 +391,7 @@ if Int.equal nmr 0 then 0 else in find 0 (n-1) (lpar,List.rev hyps) let lambda_implicit_lift n a = - let level = UniverseLevel.make (DirPath.make [Id.of_string "implicit"]) 0 in + let level = Level.make (DirPath.make [Id.of_string "implicit"]) 0 in let implicit_sort = mkType (Universe.make level) in let lambda_implicit a = mkLambda (Anonymous, implicit_sort, a) in iterate lambda_implicit n (lift n a) @@ -413,12 +417,13 @@ let abstract_mind_lc env ntyps npars lc = let ienv_push_var (env, n, ntypes, lra) (x,a,ra) = (push_rel (x,None,a) env, n+1, ntypes, (Norec,ra)::lra) -let ienv_push_inductive (env, n, ntypes, ra_env) (mi,lpar) = +let ienv_push_inductive (env, n, ntypes, ra_env) ((mi,u),lpar) = let auxntyp = 1 in - let specif = lookup_mind_specif env mi in + let specif = (lookup_mind_specif env mi, u) in + let ty = type_of_inductive env specif in let env' = push_rel (Anonymous,None, - hnf_prod_applist env (type_of_inductive env specif) lpar) env in + hnf_prod_applist env ty lpar) env in let ra_env' = (Imbr mi,(Rtree.mk_rec_calls 1).(0)) :: List.map (fun (r,t) -> (r,Rtree.lift 1 t)) ra_env in @@ -476,7 +481,7 @@ let check_positivity_one (env,_,ntypes,_ as ienv) hyps (_,i as ind) nargs lcname else failwith_non_pos_list n ntypes (x::largs) (* accesses to the environment are not factorised, but is it worth? *) - and check_positive_nested (env,n,ntypes,ra_env as ienv) nmr (mi, largs) = + and check_positive_nested (env,n,ntypes,ra_env as ienv) nmr ((mi,u), largs) = let (mib,mip) = lookup_mind_specif env mi in let auxnpar = mib.mind_nparams_rec in let nonrecpar = mib.mind_nparams - auxnpar in @@ -495,7 +500,7 @@ let check_positivity_one (env,_,ntypes,_ as ienv) hyps (_,i as ind) nargs lcname let auxlcvect = abstract_mind_lc env auxntyp auxnpar mip.mind_nf_lc in (* Extends the environment with a variable corresponding to the inductive def *) - let (env',_,_,_ as ienv') = ienv_push_inductive ienv (mi,lpar) in + let (env',_,_,_ as ienv') = ienv_push_inductive ienv ((mi,u),lpar) in (* Parameters expressed in env' *) let lpar' = List.map (lift auxntyp) lpar in let irecargs_nmr = @@ -586,40 +591,72 @@ let all_sorts = [InProp;InSet;InType] let small_sorts = [InProp;InSet] let logical_sorts = [InProp] -let allowed_sorts issmall isunit s = - match family_of_sort s with - (* Type: all elimination allowed *) - | InType -> all_sorts - - (* Small Set is predicative: all elimination allowed *) - | InSet when issmall -> all_sorts - - (* Large Set is necessarily impredicative: forbids large elimination *) - | InSet -> small_sorts - - (* Unitary/empty Prop: elimination to all sorts are realizable *) - (* unless the type is large. If it is large, forbids large elimination *) - (* which otherwise allows to simulate the inconsistent system Type:Type *) - | InProp when isunit -> if issmall then all_sorts else small_sorts - - (* Other propositions: elimination only to Prop *) - | InProp -> logical_sorts +let allowed_sorts is_smashed s = + if not is_smashed + then (** Naturally in the defined sort. + If [s] is Prop, it must be small and unitary. + Unsmashed, predicative Type and Set: all elimination allowed + as well. *) + all_sorts + else + match family_of_sort s with + (* Type: all elimination allowed: above and below *) + | InType -> all_sorts + (* Smashed Set is necessarily impredicative: forbids large elimination *) + | InSet -> small_sorts + (* Smashed to Prop, no informative eliminations allowed *) + | InProp -> logical_sorts + +(* Previous comment: *) +(* Unitary/empty Prop: elimination to all sorts are realizable *) +(* unless the type is large. If it is large, forbids large elimination *) +(* which otherwise allows to simulate the inconsistent system Type:Type. *) +(* -> this is now handled by is_smashed: *) +(* - all_sorts in case of small, unitary Prop (not smashed) *) +(* - logical_sorts in case of large, unitary Prop (smashed) *) let fold_inductive_blocks f = - let concl = function - | Inr _ -> mkSet (* dummy *) - | Inl (_,ar,_) -> ar - in - Array.fold_left (fun acc (_,_,lc,(arsign,ar)) -> - f (Array.fold_left f acc lc) (it_mkProd_or_LetIn (concl ar) arsign)) + Array.fold_left (fun acc (_,_,lc,(arsign,ar)) -> + f (Array.fold_left f acc lc) (it_mkProd_or_LetIn (pi2 ar) arsign)) let used_section_variables env inds = let ids = fold_inductive_blocks (fun l c -> Id.Set.union (Environ.global_vars_set env c) l) Id.Set.empty inds in keep_hyps env ids - -let build_inductive env env_ar params isrecord isfinite inds nmr recargs cst = +let lift_decl n d = + map_rel_declaration (lift n) d + +let rel_vect n m = Array.init m (fun i -> mkRel(n+m-i)) +let rel_list n m = Array.to_list (rel_vect n m) +let rel_appvect n m = rel_vect n (List.length m) + +exception UndefinableExpansion + +(** From a rel context describing the constructor arguments, + build an expansion function. + The term built is expecting to be substituted first by + a substitution of the form [params, x : ind params] *) +let compute_expansion ((kn, _ as ind), u) params ctx = + let mp, dp, l = repr_mind kn in + let make_proj id = Constant.make1 (KerName.make mp dp (Label.of_id id)) in + let rec projections acc (na, b, t) = + match b with + | Some c -> acc + | None -> + match na with + | Name id -> make_proj id :: acc + | Anonymous -> raise UndefinableExpansion + in + let projs = List.fold_left projections [] ctx in + let projarr = Array.of_list projs in + let exp = + mkApp (mkConstructU ((ind, 1),u), + Array.append (rel_appvect 1 params) + (Array.map (fun p -> mkProj (p, mkRel 1)) projarr)) + in exp, projarr + +let build_inductive env p ctx env_ar params kn isrecord isfinite inds nmr recargs = let ntypes = Array.length inds in (* Compute the set of used section variables *) let hyps = used_section_variables env inds in @@ -637,18 +674,13 @@ let build_inductive env env_ar params isrecord isfinite inds nmr recargs cst = Array.map (fun (d,_) -> rel_context_nhyps d - rel_context_nhyps params) splayed_lc in (* Elimination sorts *) - let arkind,kelim = match ar_kind with - | Inr (param_levels,lev) -> - Polymorphic { - poly_param_levels = param_levels; - poly_level = lev; - }, all_sorts - | Inl ((issmall,isunit),ar,s) -> - let kelim = allowed_sorts issmall isunit s in - Monomorphic { - mind_user_arity = ar; - mind_sort = s; - }, kelim in + let arkind,kelim = + let (info,ar,defs) = ar_kind in + let s = sort_of_univ defs in + let kelim = allowed_sorts info s in + { mind_user_arity = ar; + mind_sort = s; + }, kelim in (* Assigning VM tags to constructors *) let nconst, nblock = ref 0, ref 0 in let transf num = @@ -681,6 +713,19 @@ let build_inductive env env_ar params isrecord isfinite inds nmr recargs cst = mind_reloc_tbl = rtbl; } in let packets = Array.map2 build_one_packet inds recargs in + let isrecord = + let pkt = packets.(0) in + if isrecord (* || (Array.length pkt.mind_consnames = 1 && *) + (* inductive_sort_family pkt <> InProp) *) then + let rctx, _ = decompose_prod_assum pkt.mind_nf_lc.(0) in + let u = if p then Univ.UContext.instance ctx else Univ.Instance.empty in + try + let exp = compute_expansion ((kn, 0), u) params + (List.firstn pkt.mind_consnrealdecls.(0) rctx) + in Some exp + with UndefinableExpansion -> None + else None + in (* Build the mutual inductive *) { mind_record = isrecord; mind_ntypes = ntypes; @@ -690,7 +735,8 @@ let build_inductive env env_ar params isrecord isfinite inds nmr recargs cst = mind_nparams_rec = nmr; mind_params_ctxt = params; mind_packets = packets; - mind_constraints = cst + mind_polymorphic = p; + mind_universes = ctx; } (************************************************************************) @@ -698,9 +744,14 @@ let build_inductive env env_ar params isrecord isfinite inds nmr recargs cst = let check_inductive env kn mie = (* First type-check the inductive definition *) - let (env_ar, params, inds, cst) = typecheck_inductive env mie in + let env = push_context mie.mind_entry_universes env in + let (env_ar, params, inds) = + typecheck_inductive env mie.mind_entry_universes mie + in (* Then check positivity conditions *) let (nmr,recargs) = check_positivity kn env_ar params inds in (* Build the inductive packets *) - build_inductive env env_ar params mie.mind_entry_record mie.mind_entry_finite - inds nmr recargs cst + build_inductive env mie.mind_entry_polymorphic + mie.mind_entry_universes + env_ar params kn mie.mind_entry_record mie.mind_entry_finite + inds nmr recargs diff --git a/kernel/indtypes.mli b/kernel/indtypes.mli index 016a1a5b5..8730a3045 100644 --- a/kernel/indtypes.mli +++ b/kernel/indtypes.mli @@ -34,5 +34,12 @@ exception InductiveError of inductive_error (** The following function does checks on inductive declarations. *) -val check_inductive : - env -> mutual_inductive -> mutual_inductive_entry -> mutual_inductive_body +val check_inductive : env -> mutual_inductive -> mutual_inductive_entry -> mutual_inductive_body + +(** The following enforces a system compatible with the univalent model *) + +val enforce_indices_matter : unit -> unit +val is_indices_matter : unit -> bool + +val compute_expansion : pinductive -> + Context.rel_context -> Context.rel_context -> (constr * constant array) diff --git a/kernel/inductive.ml b/kernel/inductive.ml index 2b2caaf3b..e57b0b4ad 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -19,6 +19,9 @@ open Environ open Reduction open Type_errors +type pinductive = inductive puniverses +type pconstructor = constructor puniverses + type mind_specif = mutual_inductive_body * one_inductive_body (* raise Not_found if not an inductive type *) @@ -38,31 +41,55 @@ let find_inductive env c = let (t, l) = decompose_app (whd_betadeltaiota env c) in match kind_of_term t with | Ind ind - when (fst (lookup_mind_specif env ind)).mind_finite -> (ind, l) + when (fst (lookup_mind_specif env (out_punivs ind))).mind_finite -> (ind, l) | _ -> raise Not_found let find_coinductive env c = let (t, l) = decompose_app (whd_betadeltaiota env c) in match kind_of_term t with | Ind ind - when not (fst (lookup_mind_specif env ind)).mind_finite -> (ind, l) + when not (fst (lookup_mind_specif env (out_punivs ind))).mind_finite -> (ind, l) | _ -> raise Not_found let inductive_params (mib,_) = mib.mind_nparams +let make_inductive_subst mib u = + if mib.mind_polymorphic then + make_universe_subst u mib.mind_universes + else Univ.empty_subst + +let inductive_params_ctxt (mib,u) = + let subst = make_inductive_subst mib u in + Vars.subst_univs_context subst mib.mind_params_ctxt + +let inductive_instance mib = + if mib.mind_polymorphic then + UContext.instance mib.mind_universes + else Instance.empty + +let inductive_context mib = + if mib.mind_polymorphic then + mib.mind_universes + else UContext.empty + +let instantiate_inductive_constraints mib subst = + if mib.mind_polymorphic then + instantiate_univ_context subst mib.mind_universes + else Constraint.empty + (************************************************************************) (* Build the substitution that replaces Rels by the appropriate *) (* inductives *) -let ind_subst mind mib = +let ind_subst mind mib u = let ntypes = mib.mind_ntypes in - let make_Ik k = mkInd (mind,ntypes-k-1) in + let make_Ik k = mkIndU ((mind,ntypes-k-1),u) in List.init ntypes make_Ik (* Instantiate inductives in constructor type *) -let constructor_instantiate mind mib c = - let s = ind_subst mind mib in - substl s c +let constructor_instantiate mind u subst mib c = + let s = ind_subst mind mib u in + substl s (subst_univs_constr subst c) let instantiate_params full t args sign = let fail () = @@ -81,13 +108,16 @@ let instantiate_params full t args sign = let () = if not (List.is_empty rem_args) then fail () in substl subs ty -let full_inductive_instantiate mib params sign = +let full_inductive_instantiate mib u params sign = let dummy = prop_sort in let t = mkArity (sign,dummy) in - fst (destArity (instantiate_params true t params mib.mind_params_ctxt)) + let subst = make_inductive_subst mib u in + let ar = fst (destArity (instantiate_params true t params mib.mind_params_ctxt)) in + Vars.subst_univs_context subst ar -let full_constructor_instantiate ((mind,_),(mib,_),params) = - let inst_ind = constructor_instantiate mind mib in +let full_constructor_instantiate ((mind,_),u,(mib,_),params) = + let subst = make_inductive_subst mib u in + let inst_ind = constructor_instantiate mind u subst mib in (fun t -> instantiate_params true (inst_ind t) params mib.mind_params_ctxt) @@ -119,122 +149,85 @@ Remark: Set (predicative) is encoded as Type(0) let sort_as_univ = function | Type u -> u -| Prop Null -> type0m_univ -| Prop Pos -> type0_univ +| Prop Null -> Universe.type0m +| Prop Pos -> Universe.type0 let cons_subst u su subst = try - (u, sup su (List.assoc_f Universe.equal u subst)) :: - List.remove_assoc_f Universe.equal u subst + (u, Universe.sup su (List.assoc_f Universe.eq u subst)) :: + List.remove_assoc_f Universe.eq u subst with Not_found -> (u, su) :: subst -let actualize_decl_level env lev t = - let sign,s = dest_arity env t in - mkArity (sign,lev) - -let polymorphism_on_non_applied_parameters = false - -(* Bind expected levels of parameters to actual levels *) -(* Propagate the new levels in the signature *) -let rec make_subst env = function - | (_,Some _,_ as t)::sign, exp, args -> - let ctx,subst = make_subst env (sign, exp, args) in - t::ctx, subst - | d::sign, None::exp, args -> - let args = match args with _::args -> args | [] -> [] in - let ctx,subst = make_subst env (sign, exp, args) in - d::ctx, subst - | d::sign, Some u::exp, a::args -> - (* We recover the level of the argument, but we don't change the *) - (* level in the corresponding type in the arity; this level in the *) - (* arity is a global level which, at typing time, will be enforce *) - (* to be greater than the level of the argument; this is probably *) - (* a useless extra constraint *) - let s = sort_as_univ (snd (dest_arity env (Lazy.force a))) in - let ctx,subst = make_subst env (sign, exp, args) in - d::ctx, cons_subst u s subst - | (na,None,t as d)::sign, Some u::exp, [] -> - (* No more argument here: we instantiate the type with a fresh level *) - (* which is first propagated to the corresponding premise in the arity *) - (* (actualize_decl_level), then to the conclusion of the arity (via *) - (* the substitution) *) - let ctx,subst = make_subst env (sign, exp, []) in - if polymorphism_on_non_applied_parameters then - let s = fresh_local_univ () in - let t = actualize_decl_level env (Type s) t in - (na,None,t)::ctx, cons_subst u s subst - else - d::ctx, subst - | sign, [], _ -> - (* Uniform parameters are exhausted *) - sign,[] - | [], _, _ -> - assert false - -let instantiate_universes env ctx ar argsorts = - let args = Array.to_list argsorts in - let ctx,subst = make_subst env (ctx,ar.poly_param_levels,args) in - let level = subst_large_constraints subst ar.poly_level in - ctx, - (* Singleton type not containing types are interpretable in Prop *) - if is_type0m_univ level then prop_sort - (* Non singleton type not containing types are interpretable in Set *) - else if is_type0_univ level then set_sort - (* This is a Type with constraints *) - else Type level - exception SingletonInductiveBecomesProp of Id.t -let type_of_inductive_knowing_parameters ?(polyprop=true) env mip paramtyps = - match mip.mind_arity with - | Monomorphic s -> - s.mind_user_arity - | Polymorphic ar -> - let ctx = List.rev mip.mind_arity_ctxt in - let ctx,s = instantiate_universes env ctx ar paramtyps in - (* The Ocaml extraction cannot handle (yet?) "Prop-polymorphism", i.e. - the situation where a non-Prop singleton inductive becomes Prop - when applied to Prop params *) - if not polyprop && not (is_type0m_univ ar.poly_level) && is_prop_sort s - then raise (SingletonInductiveBecomesProp mip.mind_typename); - mkArity (List.rev ctx,s) - -(* Type of a (non applied) inductive type *) - -let type_of_inductive env (_,mip) = - type_of_inductive_knowing_parameters env mip [||] +(* Type of an inductive type *) + +let type_of_inductive_gen env ((mib,mip),u) = + let subst = make_inductive_subst mib u in + (subst_univs_constr subst mip.mind_arity.mind_user_arity, subst) + +let type_of_inductive env pind = + fst (type_of_inductive_gen env pind) + +let constrained_type_of_inductive env ((mib,mip),u as pind) = + let ty, subst = type_of_inductive_gen env pind in + let cst = instantiate_inductive_constraints mib subst in + (ty, cst) + +let type_of_inductive_knowing_parameters env ?(polyprop=false) mip args = + type_of_inductive env mip (* The max of an array of universes *) let cumulate_constructor_univ u = function | Prop Null -> u - | Prop Pos -> sup type0_univ u - | Type u' -> sup u u' + | Prop Pos -> Universe.sup Universe.type0 u + | Type u' -> Universe.sup u u' let max_inductive_sort = - Array.fold_left cumulate_constructor_univ type0m_univ + Array.fold_left cumulate_constructor_univ Universe.type0m (************************************************************************) (* Type of a constructor *) -let type_of_constructor cstr (mib,mip) = +let type_of_constructor_subst cstr u subst (mib,mip) = let ind = inductive_of_constructor cstr in let specif = mip.mind_user_lc in let i = index_of_constructor cstr in let nconstr = Array.length mip.mind_consnames in if i > nconstr then error "Not enough constructors in the type."; - constructor_instantiate (fst ind) mib specif.(i-1) + let c = constructor_instantiate (fst ind) u subst mib specif.(i-1) in + c + +let type_of_constructor_gen (cstr,u) (mib,mip as mspec) = + let subst = make_inductive_subst mib u in + type_of_constructor_subst cstr u subst mspec, subst -let arities_of_specif kn (mib,mip) = +let type_of_constructor cstru mspec = + fst (type_of_constructor_gen cstru mspec) + +let type_of_constructor_in_ctx cstr (mib,mip as mspec) = + let u = UContext.instance mib.mind_universes in + let c = type_of_constructor_gen (cstr, u) mspec in + (fst c, mib.mind_universes) + +let constrained_type_of_constructor (cstr,u as cstru) (mib,mip as ind) = + let ty, subst = type_of_constructor_gen cstru ind in + let cst = instantiate_inductive_constraints mib subst in + (ty, cst) + +let arities_of_specif (kn,u) (mib,mip) = let specif = mip.mind_nf_lc in - Array.map (constructor_instantiate kn mib) specif + let subst = make_inductive_subst mib u in + Array.map (constructor_instantiate kn u subst mib) specif let arities_of_constructors ind specif = - arities_of_specif (fst ind) specif + arities_of_specif (fst (fst ind), snd ind) specif -let type_of_constructors ind (mib,mip) = +let type_of_constructors (ind,u) (mib,mip) = let specif = mip.mind_user_lc in - Array.map (constructor_instantiate (fst ind) mib) specif + let subst = make_inductive_subst mib u in + Array.map (constructor_instantiate (fst ind) u subst mib) specif (************************************************************************) @@ -255,16 +248,14 @@ let local_rels ctxt = (* Get type of inductive, with parameters instantiated *) let inductive_sort_family mip = - match mip.mind_arity with - | Monomorphic s -> family_of_sort s.mind_sort - | Polymorphic _ -> InType + family_of_sort mip.mind_arity.mind_sort let mind_arity mip = mip.mind_arity_ctxt, inductive_sort_family mip -let get_instantiated_arity (mib,mip) params = +let get_instantiated_arity (ind,u) (mib,mip) params = let sign, s = mind_arity mip in - full_inductive_instantiate mib params sign, s + full_inductive_instantiate mib u params sign, s let elim_sorts (_,mip) = mip.mind_kelim @@ -279,7 +270,7 @@ let extended_rel_list n hyps = let build_dependent_inductive ind (_,mip) params = let realargs,_ = List.chop mip.mind_nrealargs_ctxt mip.mind_arity_ctxt in applist - (mkInd ind, + (mkIndU ind, List.map (lift mip.mind_nrealargs_ctxt) params @ extended_rel_list 0 realargs) @@ -295,15 +286,15 @@ let check_allowed_sort ksort specif = raise (LocalArity (Some(ksort,s,error_elim_explain ksort s))) let is_correct_arity env c pj ind specif params = - let arsign,_ = get_instantiated_arity specif params in - let rec srec env pt ar u = + let arsign,_ = get_instantiated_arity ind specif params in + let rec srec env pt ar = let pt' = whd_betadeltaiota env pt in match kind_of_term pt', ar with | Prod (na1,a1,t), (_,None,a1')::ar' -> - let univ = + let () = try conv env a1 a1' with NotConvertible -> raise (LocalArity None) in - srec (push_rel (na1,None,a1) env) t ar' (union_constraints u univ) + srec (push_rel (na1,None,a1) env) t ar' (* The last Prod domain is the type of the scrutinee *) | Prod (na1,a1,a2), [] -> (* whnf of t was not needed here! *) let env' = push_rel (na1,None,a1) env in @@ -311,17 +302,16 @@ let is_correct_arity env c pj ind specif params = | Sort s -> family_of_sort s | _ -> raise (LocalArity None) in let dep_ind = build_dependent_inductive ind specif params in - let univ = + let _ = try conv env a1 dep_ind with NotConvertible -> raise (LocalArity None) in - check_allowed_sort ksort specif; - union_constraints u univ + check_allowed_sort ksort specif | _, (_,Some _,_ as d)::ar' -> - srec (push_rel d env) (lift 1 pt') ar' u + srec (push_rel d env) (lift 1 pt') ar' | _ -> raise (LocalArity None) in - try srec env pj.uj_type (List.rev arsign) empty_constraint + try srec env pj.uj_type (List.rev arsign) with LocalArity kinds -> error_elim_arity env ind (elim_sorts specif) c pj kinds @@ -331,16 +321,16 @@ let is_correct_arity env c pj ind specif params = (* [p] is the predicate, [i] is the constructor number (starting from 0), and [cty] is the type of the constructor (params not instantiated) *) -let build_branches_type ind (_,mip as specif) params p = +let build_branches_type (ind,u) (_,mip as specif) params p = let build_one_branch i cty = - let typi = full_constructor_instantiate (ind,specif,params) cty in + let typi = full_constructor_instantiate (ind,u,specif,params) cty in let (args,ccl) = decompose_prod_assum typi in let nargs = rel_context_length args in let (_,allargs) = decompose_app ccl in let (lparams,vargs) = List.chop (inductive_params specif) allargs in let cargs = let cstr = ith_constructor_of_inductive ind (i+1) in - let dep_cstr = applist (mkConstruct cstr,lparams@(local_rels args)) in + let dep_cstr = applist (mkConstructU (cstr,u),lparams@(local_rels args)) in vargs @ [dep_cstr] in let base = beta_appvect (lift nargs p) (Array.of_list cargs) in it_mkProd_or_LetIn base args in @@ -348,31 +338,31 @@ let build_branches_type ind (_,mip as specif) params p = (* [p] is the predicate, [c] is the match object, [realargs] is the list of real args of the inductive type *) -let build_case_type n p c realargs = - whd_betaiota (betazeta_appvect (n+1) p (Array.of_list (realargs@[c]))) +let build_case_type env n p c realargs = + whd_betaiota env (betazeta_appvect (n+1) p (Array.of_list (realargs@[c]))) -let type_case_branches env (ind,largs) pj c = - let specif = lookup_mind_specif env ind in +let type_case_branches env (pind,largs) pj c = + let specif = lookup_mind_specif env (fst pind) in let nparams = inductive_params specif in let (params,realargs) = List.chop nparams largs in let p = pj.uj_val in - let univ = is_correct_arity env c pj ind specif params in - let lc = build_branches_type ind specif params p in - let ty = build_case_type (snd specif).mind_nrealargs_ctxt p c realargs in - (lc, ty, univ) + let () = is_correct_arity env c pj pind specif params in + let lc = build_branches_type pind specif params p in + let ty = build_case_type env (snd specif).mind_nrealargs_ctxt p c realargs in + (lc, ty) (************************************************************************) (* Checking the case annotation is relevent *) -let check_case_info env indsp ci = +let check_case_info env (indsp,u) ci = let (mib,mip) = lookup_mind_specif env indsp in if not (eq_ind indsp ci.ci_ind) || not (Int.equal mib.mind_nparams ci.ci_npar) || not (Array.equal Int.equal mip.mind_consnrealdecls ci.ci_cstr_ndecls) || not (Array.equal Int.equal mip.mind_consnrealargs ci.ci_cstr_nargs) - then raise (TypeError(env,WrongCaseInfo(indsp,ci))) + then raise (TypeError(env,WrongCaseInfo((indsp,u),ci))) (************************************************************************) (************************************************************************) @@ -450,7 +440,7 @@ type guard_env = genv : subterm_spec Lazy.t list; } -let make_renv env recarg (kn,tyi) = +let make_renv env recarg ((kn,tyi),u) = let mib = Environ.lookup_mind kn env in let mind_recvec = Array.map (fun mip -> mip.mind_recargs) mib.mind_packets in @@ -552,7 +542,6 @@ let rec subterm_specif renv stack t = let f,l = decompose_app (whd_betadeltaiota renv.env t) in match kind_of_term f with | Rel k -> subterm_var k renv - | Case (ci,p,c,lbr) -> let stack' = push_stack_closures renv l stack in if not (check_inductive_codomain renv.env p) then Not_subterm @@ -581,7 +570,7 @@ let rec subterm_specif renv stack t = with Not_found -> None in (match oind with None -> Not_subterm (* happens if fix is polymorphic *) - | Some ind -> + | Some (ind, _) -> let nbfix = Array.length typarray in let recargs = lookup_subterms renv.env ind in (* pushing the fixpoints *) @@ -668,7 +657,7 @@ let check_one_fix renv recpos def = (* if [t] does not make recursive calls, it is guarded: *) if noccur_with_meta renv.rel_min nfi t then () else - let (f,l) = decompose_app (whd_betaiotazeta t) in + let (f,l) = decompose_app (whd_betaiotazeta renv.env t) in match kind_of_term f with | Rel p -> (* Test if [p] is a fixpoint (recursive call) *) @@ -739,11 +728,11 @@ let check_one_fix renv recpos def = else check_rec_call renv' [] body) bodies - | Const kn -> + | Const (kn,u as cu) -> if evaluable_constant kn renv.env then try List.iter (check_rec_call renv []) l with (FixGuardError _ ) -> - let value = (applist(constant_value renv.env kn, l)) in + let value = (applist(constant_value_in renv.env cu, l)) in check_rec_call renv stack value else List.iter (check_rec_call renv []) l @@ -785,6 +774,8 @@ let check_one_fix renv recpos def = | (Evar _ | Meta _) -> () | (App _ | LetIn _ | Cast _) -> assert false (* beta zeta reduction *) + + | Proj (p, c) -> check_rec_call renv [] c and check_nested_fix_body renv decr recArgsDecrArg body = if Int.equal decr 0 then @@ -888,7 +879,7 @@ let check_one_cofix env nbfix def deftype = else if not(List.for_all (noccur_with_meta n nbfix) args) then raise (CoFixGuardError (env,NestedRecursiveOccurrences)) - | Construct (_,i as cstr_kn) -> + | Construct ((_,i as cstr_kn),u) -> let lra = vlra.(i-1) in let mI = inductive_of_constructor cstr_kn in let (mib,mip) = lookup_mind_specif env mI in @@ -947,7 +938,7 @@ let check_one_cofix env nbfix def deftype = | _ -> raise (CoFixGuardError (env,NotGuardedForm t)) in - let (mind, _) = codomain_is_coind env deftype in + let ((mind, _),_) = codomain_is_coind env deftype in let vlra = lookup_subterms env mind in check_rec_call env false 1 (dest_subterms vlra) def diff --git a/kernel/inductive.mli b/kernel/inductive.mli index d9841085e..c4a7452f0 100644 --- a/kernel/inductive.mli +++ b/kernel/inductive.mli @@ -7,9 +7,9 @@ (************************************************************************) open Names -open Univ open Term open Context +open Univ open Declarations open Environ @@ -21,9 +21,9 @@ open Environ only a coinductive type. They raise [Not_found] if not convertible to a recursive type. *) -val find_rectype : env -> types -> inductive * constr list -val find_inductive : env -> types -> inductive * constr list -val find_coinductive : env -> types -> inductive * constr list +val find_rectype : env -> types -> pinductive * constr list +val find_inductive : env -> types -> pinductive * constr list +val find_coinductive : env -> types -> pinductive * constr list type mind_specif = mutual_inductive_body * one_inductive_body @@ -33,23 +33,38 @@ type mind_specif = mutual_inductive_body * one_inductive_body val lookup_mind_specif : env -> inductive -> mind_specif (** {6 Functions to build standard types related to inductive } *) -val ind_subst : mutual_inductive -> mutual_inductive_body -> constr list +val ind_subst : mutual_inductive -> mutual_inductive_body -> universe_instance -> constr list + +val make_inductive_subst : mutual_inductive_body -> universe_instance -> universe_subst + +val inductive_instance : mutual_inductive_body -> universe_instance +val inductive_context : mutual_inductive_body -> universe_context +val inductive_params_ctxt : mutual_inductive_body puniverses -> rel_context + +val instantiate_inductive_constraints : mutual_inductive_body -> universe_subst -> constraints -val type_of_inductive : env -> mind_specif -> types +val constrained_type_of_inductive : env -> mind_specif puniverses -> types constrained + +val type_of_inductive : env -> mind_specif puniverses -> types + +val type_of_inductive_knowing_parameters : env -> ?polyprop:bool -> mind_specif puniverses -> types Lazy.t array -> types val elim_sorts : mind_specif -> sorts_family list (** Return type as quoted by the user *) -val type_of_constructor : constructor -> mind_specif -> types + +val constrained_type_of_constructor : pconstructor -> mind_specif -> types constrained +val type_of_constructor : pconstructor -> mind_specif -> types +val type_of_constructor_in_ctx : constructor -> mind_specif -> types in_universe_context (** Return constructor types in normal form *) -val arities_of_constructors : inductive -> mind_specif -> types array +val arities_of_constructors : pinductive -> mind_specif -> types array (** Return constructor types in user form *) -val type_of_constructors : inductive -> mind_specif -> types array +val type_of_constructors : pinductive -> mind_specif -> types array (** Transforms inductive specification into types (in nf) *) -val arities_of_specif : mutual_inductive -> mind_specif -> types array +val arities_of_specif : mutual_inductive puniverses -> mind_specif -> types array val inductive_params : mind_specif -> int @@ -61,11 +76,11 @@ val inductive_params : mind_specif -> int the universe constraints generated. *) val type_case_branches : - env -> inductive * constr list -> unsafe_judgment -> constr - -> types array * types * constraints + env -> pinductive * constr list -> unsafe_judgment -> constr + -> types array * types val build_branches_type : - inductive -> mutual_inductive_body * one_inductive_body -> + pinductive -> mutual_inductive_body * one_inductive_body -> constr list -> constr -> types array (** Return the arity of an inductive type *) @@ -75,7 +90,7 @@ val inductive_sort_family : one_inductive_body -> sorts_family (** Check a [case_info] actually correspond to a Case expression on the given inductive type. *) -val check_case_info : env -> inductive -> case_info -> unit +val check_case_info : env -> pinductive -> case_info -> unit (** {6 Guard conditions for fix and cofix-points. } *) val check_fix : env -> fixpoint -> unit @@ -92,14 +107,8 @@ val check_cofix : env -> cofixpoint -> unit exception SingletonInductiveBecomesProp of Id.t -val type_of_inductive_knowing_parameters : ?polyprop:bool -> - env -> one_inductive_body -> types Lazy.t array -> types - val max_inductive_sort : sorts array -> universe -val instantiate_universes : env -> rel_context -> - polymorphic_arity -> types Lazy.t array -> rel_context * sorts - (** {6 Debug} *) type size = Large | Strict diff --git a/kernel/kernel.mllib b/kernel/kernel.mllib index 0d0adf9a7..29fe887d7 100644 --- a/kernel/kernel.mllib +++ b/kernel/kernel.mllib @@ -32,6 +32,7 @@ Type_errors Modops Inductive Typeops +Fast_typeops Indtypes Cooking Term_typing @@ -39,7 +40,6 @@ Subtyping Mod_typing Nativelibrary Safe_typing - Vm Csymtable Vconv diff --git a/kernel/mod_subst.ml b/kernel/mod_subst.ml index 9589c0656..cfe46152e 100644 --- a/kernel/mod_subst.ml +++ b/kernel/mod_subst.ml @@ -271,7 +271,7 @@ let progress f x ~orelse = let y = f x in if y != x then y else orelse -let subst_ind sub mind = +let subst_mind sub mind = let mpu,dir,l = MutInd.repr3 mind in let mpc = KerName.modpath (MutInd.canonical mind) in try @@ -284,7 +284,14 @@ let subst_ind sub mind = MutInd.make knu knc' with No_subst -> mind -let subst_con0 sub cst = +let subst_ind sub (ind,i as indi) = + let ind' = subst_mind sub ind in + if ind' == ind then indi else ind',i + +let subst_pind sub (ind,u) = + (subst_ind sub ind, u) + +let subst_con0 sub (cst,u) = let mpu,dir,l = Constant.repr3 cst in let mpc = KerName.modpath (Constant.canonical cst) in let mpu,mpc,resolve,user = subst_dual_mp sub mpu mpc in @@ -299,11 +306,28 @@ let subst_con0 sub cst = progress (kn_of_delta resolve) (if user then knu else knc) ~orelse:knc in let cst' = Constant.make knu knc' in - cst', mkConst cst' + cst', mkConstU (cst',u) let subst_con sub cst = try subst_con0 sub cst - with No_subst -> cst, mkConst cst + with No_subst -> fst cst, mkConstU cst + +let subst_con_kn sub con = + subst_con sub (con,Univ.Instance.empty) + +let subst_pcon sub (con,u as pcon) = + try let con', can = subst_con0 sub pcon in + con',u + with No_subst -> pcon + +let subst_pcon_term sub (con,u as pcon) = + try let con', can = subst_con0 sub pcon in + (con',u), can + with No_subst -> pcon, mkConstU pcon + +let subst_constant sub con = + try fst (subst_con0 sub (con,Univ.Instance.empty)) + with No_subst -> con (* Here the semantics is completely unclear. What does "Hint Unfold t" means when "t" is a parameter? @@ -312,18 +336,25 @@ let subst_con sub cst = interpretation (i.e. an evaluable reference is never expanded). *) let subst_evaluable_reference subst = function | EvalVarRef id -> EvalVarRef id - | EvalConstRef kn -> EvalConstRef (fst (subst_con subst kn)) + | EvalConstRef kn -> EvalConstRef (subst_constant subst kn) let rec map_kn f f' c = let func = map_kn f f' in match kind_of_term c with | Const kn -> (try snd (f' kn) with No_subst -> c) - | Ind (kn,i) -> + | Proj (kn,t) -> + let kn' = try fst (f' (kn,Univ.Instance.empty)) + with No_subst -> kn + in + let t' = func t in + if kn' == kn && t' == t then c + else mkProj (kn', t') + | Ind ((kn,i),u) -> let kn' = f kn in - if kn'==kn then c else mkInd (kn',i) - | Construct ((kn,i),j) -> + if kn'==kn then c else mkIndU ((kn',i),u) + | Construct (((kn,i),j),u) -> let kn' = f kn in - if kn'==kn then c else mkConstruct ((kn',i),j) + if kn'==kn then c else mkConstructU (((kn',i),j),u) | Case (ci,p,ct,l) -> let ci_ind = let (kn,i) = ci.ci_ind in @@ -382,7 +413,7 @@ let rec map_kn f f' c = let subst_mps sub c = if is_empty_subst sub then c - else map_kn (subst_ind sub) (subst_con0 sub) c + else map_kn (subst_mind sub) (subst_con0 sub) c let rec replace_mp_in_mp mpfrom mpto mp = match mp with diff --git a/kernel/mod_subst.mli b/kernel/mod_subst.mli index 34f10b31a..5a913a906 100644 --- a/kernel/mod_subst.mli +++ b/kernel/mod_subst.mli @@ -118,15 +118,32 @@ val debug_pr_delta : delta_resolver -> Pp.std_ppcmds val subst_mp : substitution -> module_path -> module_path -val subst_ind : +val subst_mind : substitution -> mutual_inductive -> mutual_inductive +val subst_ind : + substitution -> inductive -> inductive + +val subst_pind : substitution -> pinductive -> pinductive + val subst_kn : substitution -> kernel_name -> kernel_name val subst_con : + substitution -> pconstant -> constant * constr + +val subst_pcon : + substitution -> pconstant -> pconstant + +val subst_pcon_term : + substitution -> pconstant -> pconstant * constr + +val subst_con_kn : substitution -> constant -> constant * constr +val subst_constant : + substitution -> constant -> constant + (** Here the semantics is completely unclear. What does "Hint Unfold t" means when "t" is a parameter? Does the user mean "Unfold X.t" or does she mean "Unfold y" diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml index 6c0f1b060..b20fe9671 100644 --- a/kernel/mod_typing.ml +++ b/kernel/mod_typing.ml @@ -52,7 +52,7 @@ let rec rebuild_mp mp l = | []-> mp | i::r -> rebuild_mp (MPdot(mp,Label.of_id i)) r -let (+++) = Univ.union_constraints +let (+++) = Univ.Constraint.union let rec check_with_def env struc (idl,c) mp equiv = let lab,idl = match idl with @@ -72,24 +72,31 @@ let rec check_with_def env struc (idl,c) mp equiv = (* In the spirit of subtyping.check_constant, we accept any implementations of parameters and opaques terms, as long as they have the right type *) + let env' = Environ.add_constraints + (Univ.UContext.constraints (Future.force cb.const_universes)) env' in let c',cst = match cb.const_body with | Undef _ | OpaqueDef _ -> - let j,cst1 = Typeops.infer env' c in + let j = 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 = cb.const_constraints +++ cst1 +++ cst2 in - j.uj_val, cst + let cst = Reduction.infer_conv_leq env' (Environ.universes env') + j.uj_type typ in + j.uj_val,cst | Def cs -> - let cst1 = Reduction.conv env' c (Mod_subst.force_constr cs) in - let cst = cb.const_constraints +++ cst1 in - c, cst + let cst = Reduction.infer_conv env' (Environ.universes env') c + (Mod_subst.force_constr cs) in + let cst = + if cb.const_polymorphic then cst + else (*FIXME MS: computed above *) + (Univ.UContext.constraints (Future.force cb.const_universes)) +++ cst + in + c, cst in let def = Def (Mod_subst.from_val c') in let cb' = { cb with const_body = def; - const_body_code = Cemitcodes.from_val (compile_constant_body env' def); - const_constraints = cst } + const_body_code = Cemitcodes.from_val (compile_constant_body env' def) } + (* const_universes = Future.from_val cst } *) in before@(lab,SFBconst(cb'))::after, c', cst else @@ -185,7 +192,7 @@ let rec check_with_mod env struc (idl,mp1) mp equiv = | Algebraic (NoFunctor (MEident mp0)) -> let mpnew = rebuild_mp mp0 idl in check_modpath_equiv env' mpnew mp; - before@(lab,spec)::after, equiv, Univ.empty_constraint + before@(lab,spec)::after, equiv, Univ.Constraint.empty | _ -> error_generative_module_expected lab end with @@ -229,7 +236,7 @@ let rec translate_mse env mpo inl = function let mtb = lookup_modtype mp1 env in mtb.typ_expr, mtb.typ_delta in - sign,Some (MEident mp1),reso,Univ.empty_constraint + sign,Some (MEident mp1),reso,Univ.Constraint.empty |MEapply (fe,mp1) -> translate_apply env inl (translate_mse env mpo inl fe) mp1 (mk_alg_app mpo) |MEwith(me, with_decl) -> @@ -297,7 +304,7 @@ let finalize_module env mp (sign,alg,reso,cst) restype = match restype with typ_mp = mp; typ_expr = sign; typ_expr_alg = None; - typ_constraints = Univ.empty_constraint; + typ_constraints = Univ.Constraint.empty; typ_delta = reso } in let cst' = Subtyping.check_subtypes env auto_mtb res_mtb in let impl = match alg with Some e -> Algebraic e | None -> Struct sign in @@ -322,7 +329,7 @@ let rec translate_mse_incl env mp inl = function |MEident mp1 -> let mb = strengthen_and_subst_mb (lookup_module mp1 env) mp true in let sign = clean_bounded_mod_expr mb.mod_type in - sign,None,mb.mod_delta,Univ.empty_constraint + sign,None,mb.mod_delta,Univ.Constraint.empty |MEapply (fe,arg) -> let ftrans = translate_mse_incl env mp inl fe in translate_apply env inl ftrans arg (fun _ _ -> None) diff --git a/kernel/modops.ml b/kernel/modops.ml index 6d0e919f8..093ee7024 100644 --- a/kernel/modops.ml +++ b/kernel/modops.ml @@ -210,7 +210,7 @@ and subst_structure sub do_delta sign = let cb' = subst_const_body sub cb in if cb==cb' then orig else (l,SFBconst cb') |SFBmind mib -> - let mib' = subst_mind sub mib in + let mib' = subst_mind_body sub mib in if mib==mib' then orig else (l,SFBmind mib') |SFBmodule mb -> let mb' = subst_module sub do_delta mb in @@ -460,7 +460,7 @@ and strengthen_and_subst_struct str subst mp_from mp_to alias incl reso = because reso' contains mp_to maps to reso(mp_from) *) reso', item'::rest' | (l,SFBmind mib) :: rest -> - let item' = l,SFBmind (subst_mind subst mib) in + let item' = l,SFBmind (subst_mind_body subst mib) in let reso',rest' = strengthen_and_subst_struct rest subst mp_from mp_to alias incl reso in diff --git a/kernel/names.ml b/kernel/names.ml index ef0e812ed..c76d95937 100644 --- a/kernel/names.ml +++ b/kernel/names.ml @@ -309,6 +309,11 @@ module ModPath = struct let initial = MPfile DirPath.initial + let rec dp = function + | MPfile sl -> sl + | MPbound (_,_,dp) -> dp + | MPdot (mp,l) -> dp mp + module Self_Hashcons = struct type t = module_path type u = (DirPath.t -> DirPath.t) * (MBId.t -> MBId.t) * @@ -424,7 +429,6 @@ module KerName = struct let hcons = Hashcons.simple_hcons HashKN.generate (ModPath.hcons,DirPath.hcons,String.hcons) - end module KNmap = HMap.Make(KerName) @@ -567,6 +571,7 @@ let constr_modpath (ind,_) = ind_modpath ind let ith_mutual_inductive (mind, _) i = (mind, i) let ith_constructor_of_inductive ind i = (ind, i) +let ith_constructor_of_pinductive (ind,u) i = ((ind,i),u) let inductive_of_constructor (ind, i) = ind let index_of_constructor (ind, i) = i @@ -663,8 +668,7 @@ let hcons_mind = Hashcons.simple_hcons MutInd.HashKP.generate KerName.hcons let hcons_ind = Hashcons.simple_hcons Hind.generate hcons_mind let hcons_construct = Hashcons.simple_hcons Hconstruct.generate hcons_ind - -(*******) +(*****************) type transparent_state = Id.Pred.t * Cpred.t @@ -674,25 +678,26 @@ let var_full_transparent_state = (Id.Pred.full, Cpred.empty) let cst_full_transparent_state = (Id.Pred.empty, Cpred.full) type 'a tableKey = - | ConstKey of Constant.t + | ConstKey of 'a | VarKey of Id.t - | RelKey of 'a - + | RelKey of Int.t type inv_rel_key = int (* index in the [rel_context] part of environment starting by the end, {\em inverse} of de Bruijn indice *) -type id_key = inv_rel_key tableKey +type id_key = Constant.t tableKey -let eq_id_key ik1 ik2 = +let eq_table_key f ik1 ik2 = if ik1 == ik2 then true else match ik1,ik2 with - | ConstKey c1, ConstKey c2 -> Constant.UserOrd.equal c1 c2 + | ConstKey c1, ConstKey c2 -> f c1 c2 | VarKey id1, VarKey id2 -> Id.equal id1 id2 | RelKey k1, RelKey k2 -> Int.equal k1 k2 | _ -> false +let eq_id_key = eq_table_key Constant.UserOrd.equal + let eq_con_chk = Constant.UserOrd.equal let eq_mind_chk = MutInd.UserOrd.equal let eq_ind_chk (kn1,i1) (kn2,i2) = Int.equal i1 i2 && eq_mind_chk kn1 kn2 @@ -777,6 +782,7 @@ let kn_ord = KerName.compare (** Compatibility layer for [Constant] *) type constant = Constant.t +type projection = constant let constant_of_kn = Constant.make1 let constant_of_kn_equiv = Constant.make @@ -787,6 +793,7 @@ let user_con = Constant.user let con_label = Constant.label let con_modpath = Constant.modpath let eq_constant = Constant.equal +let eq_constant_key = Constant.UserOrd.equal let con_ord = Constant.CanOrd.compare let con_user_ord = Constant.UserOrd.compare let string_of_con = Constant.to_string diff --git a/kernel/names.mli b/kernel/names.mli index db973ed3a..49a838ae5 100644 --- a/kernel/names.mli +++ b/kernel/names.mli @@ -216,6 +216,8 @@ sig val initial : t (** Name of the toplevel structure ([= MPfile initial_dir]) *) + val dp : t -> DirPath.t + end module MPset : Set.S with type elt = ModPath.t @@ -440,10 +442,11 @@ val hcons_construct : constructor -> constructor (******) type 'a tableKey = - | ConstKey of Constant.t + | ConstKey of 'a | VarKey of Id.t - | RelKey of 'a + | RelKey of Int.t +(** Sets of names *) type transparent_state = Id.Pred.t * Cpred.t val empty_transparent_state : transparent_state @@ -455,8 +458,10 @@ type inv_rel_key = int (** index in the [rel_context] part of environment starting by the end, {e inverse} of de Bruijn indice *) -type id_key = inv_rel_key tableKey +type id_key = Constant.t tableKey +val eq_table_key : ('a -> 'a -> bool) -> 'a tableKey -> 'a tableKey -> bool +val eq_constant_key : Constant.t -> Constant.t -> bool val eq_id_key : id_key -> id_key -> bool (** equalities on constant and inductive names (for the checker) *) @@ -629,6 +634,8 @@ val kn_ord : kernel_name -> kernel_name -> int type constant = Constant.t (** @deprecated Alias type *) +type projection = constant + val constant_of_kn_equiv : KerName.t -> KerName.t -> constant (** @deprecated Same as [Constant.make] *) diff --git a/kernel/nativecode.ml b/kernel/nativecode.ml index 1f6effba6..bd659a471 100644 --- a/kernel/nativecode.ml +++ b/kernel/nativecode.ml @@ -48,6 +48,7 @@ type gname = | Gind of string * inductive (* prefix, inductive name *) | Gconstruct of string * constructor (* prefix, constructor name *) | Gconstant of string * constant (* prefix, constant name *) + | Gproj of string * constant (* prefix, constant name *) | Gcase of label option * int | Gpred of label option * int | Gfixtype of label option * int @@ -95,6 +96,7 @@ let gname_hash gn = match gn with | Ginternal s -> combinesmall 9 (String.hash s) | Grel i -> combinesmall 10 (Int.hash i) | Gnamed id -> combinesmall 11 (Id.hash id) +| Gproj (s, p) -> combinesmall 12 (combine (String.hash s) (Constant.hash p)) let case_ctr = ref (-1) @@ -253,6 +255,7 @@ type primitive = | Mk_cofix of int | Mk_rel of int | Mk_var of identifier + | Mk_proj | Is_accu | Is_int | Cast_accu @@ -298,6 +301,8 @@ let eq_primitive p1 p2 = | Force_cofix, Force_cofix -> true | Mk_meta, Mk_meta -> true | Mk_evar, Mk_evar -> true + | Mk_proj, Mk_proj -> true + | _ -> false let primitive_hash = function @@ -344,6 +349,7 @@ let primitive_hash = function | Coq_primitive (prim, None) -> combinesmall 36 (Primitives.hash prim) | Coq_primitive (prim, Some (prefix,kn)) -> combinesmall 37 (combine3 (String.hash prefix) (Constant.hash kn) (Primitives.hash prim)) + | Mk_proj -> 38 type mllambda = | MLlocal of lname @@ -1002,6 +1008,7 @@ let compile_prim decl cond paux = | Lapp(f,args) -> MLapp(ml_of_lam env l f, Array.map (ml_of_lam env l) args) | Lconst (prefix,c) -> MLglobal(Gconstant (prefix,c)) + | Lproj (prefix,c) -> MLglobal(Gproj (prefix,c)) | Lprim _ -> let decl,cond,paux = extract_prim (ml_of_lam env l) t in compile_prim decl cond paux @@ -1461,6 +1468,8 @@ let string_of_gname g = Format.sprintf "%sconstruct_%s_%i_%i" prefix (string_of_mind mind) i (j-1) | Gconstant (prefix, c) -> Format.sprintf "%sconst_%s" prefix (string_of_con c) + | Gproj (prefix, c) -> + Format.sprintf "%sproj_%s" prefix (string_of_con c) | Gcase (l,i) -> Format.sprintf "case_%s_%i" (string_of_label_def l) i | Gpred (l,i) -> @@ -1518,12 +1527,12 @@ let pp_mllam fmt l = | MLif(t,l1,l2) -> Format.fprintf fmt "@[(if %a then@\n %a@\nelse@\n %a)@]" pp_mllam t pp_mllam l1 pp_mllam l2 - | MLmatch (asw, c, accu_br, br) -> - let mind,i = asw.asw_ind in - let prefix = asw.asw_prefix in - let accu = Format.sprintf "%sAccu_%s_%i" prefix (string_of_mind mind) i in - Format.fprintf fmt - "@[begin match Obj.magic (%a) with@\n| %s _ ->@\n %a@\n%aend@]" + | MLmatch (annot, c, accu_br, br) -> + let mind,i = annot.asw_ind in + let prefix = annot.asw_prefix in + let accu = Format.sprintf "%sAccu_%s_%i" prefix (string_of_mind mind) i in + Format.fprintf fmt + "@[begin match Obj.magic (%a) with@\n| %s _ ->@\n %a@\n%aend@]" pp_mllam c accu pp_mllam accu_br (pp_branches prefix) br | MLconstruct(prefix,c,args) -> @@ -1626,6 +1635,7 @@ let pp_mllam fmt l = | Mk_rel i -> Format.fprintf fmt "mk_rel_accu %i" i | Mk_var id -> Format.fprintf fmt "mk_var_accu (Names.id_of_string \"%s\")" (string_of_id id) + | Mk_proj -> Format.fprintf fmt "mk_proj_accu" | Is_accu -> Format.fprintf fmt "is_accu" | Is_int -> Format.fprintf fmt "is_int" | Cast_accu -> Format.fprintf fmt "cast_accu" @@ -1758,9 +1768,11 @@ and compile_named env sigma auxdefs id = | None -> Glet(Gnamed id, MLprimitive (Mk_var id))::auxdefs -let compile_constant env sigma prefix ~interactive con body = - match body with - | Def t -> +let compile_constant env sigma prefix ~interactive con cb = + match cb.const_proj with + | None -> + begin match cb.const_body with + | Def t -> let t = Mod_subst.force_constr t in let code = lambda_of_constr env sigma t in if !Flags.debug then Pp.msg_debug (Pp.str "Generated lambda code"); @@ -1778,11 +1790,42 @@ let compile_constant env sigma prefix ~interactive con body = in if !Flags.debug then Pp.msg_debug (Pp.str "Optimized mllambda code"); code, name - | _ -> + | _ -> + let i = push_symbol (SymbConst con) in + [Glet(Gconstant ("",con), MLapp (MLprimitive Mk_const, [|get_const_code i|]))], + if interactive then LinkedInteractive prefix + else Linked prefix + end + | Some pb -> + let mind = pb.proj_ind in + let ind = (mind,0) in + let mib = lookup_mind mind env in + let oib = mib.mind_packets.(0) in + let tbl = oib.mind_reloc_tbl in + (* Building info *) + let prefix = get_mind_prefix env mind in + let ci = { ci_ind = ind; ci_npar = mib.mind_nparams; + ci_cstr_nargs = [|0|]; + ci_cstr_ndecls = [||] (*FIXME*); + ci_pp_info = { ind_nargs = 0; style = RegularStyle } } in + let asw = { asw_ind = ind; asw_prefix = prefix; asw_ci = ci; + asw_reloc = tbl; asw_finite = true } in + let c_uid = fresh_lname Anonymous in + let _, arity = tbl.(0) in + let ci_uid = fresh_lname Anonymous in + let cargs = Array.init arity + (fun i -> if Int.equal i pb.proj_arg then Some ci_uid else None) + in let i = push_symbol (SymbConst con) in - [Glet(Gconstant ("",con), MLapp (MLprimitive Mk_const, [|get_const_code i|]))], - if interactive then LinkedInteractive prefix - else Linked prefix + let accu = MLapp (MLprimitive Cast_accu, [|MLlocal c_uid|]) in + let accu_br = MLapp (MLprimitive Mk_proj, [|get_const_code i;accu|]) in + let code = MLmatch(asw,MLlocal c_uid,accu_br,[|[((ind,1),cargs)],MLlocal ci_uid|]) in + let gn = Gproj ("",con) in + let fargs = Array.init (pb.proj_npars + 1) (fun _ -> fresh_lname Anonymous) in + let arg = fargs.(pb.proj_npars) in + Glet(Gconstant ("",con), mkMLlam fargs (MLapp (MLglobal gn, [|MLlocal + arg|]))):: + [Glet(gn, mkMLlam [|c_uid|] code)], Linked prefix let loaded_native_files = ref ([] : string list) @@ -1858,8 +1901,8 @@ let compile_mind_deps env prefix ~interactive reverse order, as well as linking information updates *) let rec compile_deps env sigma prefix ~interactive init t = match kind_of_term t with - | Ind (mind,_) -> compile_mind_deps env prefix ~interactive init mind - | Const c -> + | Ind ((mind,_),u) -> compile_mind_deps env prefix ~interactive init mind + | Const (c,u) -> let c = get_allias env c in let cb,(nameref,_) = lookup_constant_key c env in let (_, (_, const_updates)) = init in @@ -1873,12 +1916,14 @@ let rec compile_deps env sigma prefix ~interactive init t = | _ -> init in let code, name = - compile_constant env sigma prefix ~interactive c cb.const_body + compile_constant env sigma prefix ~interactive c cb in let comp_stack = code@comp_stack in let const_updates = Cmap_env.add c (nameref, name) const_updates in comp_stack, (mind_updates, const_updates) - | Construct ((mind,_),_) -> compile_mind_deps env prefix ~interactive init mind + | Construct (((mind,_),_),u) -> compile_mind_deps env prefix ~interactive init mind + | Proj (p,c) -> + compile_deps env sigma prefix ~interactive init (mkApp (mkConst p, [|c|])) | Case (ci, p, c, ac) -> let mind = fst ci.ci_ind in let init = compile_mind_deps env prefix ~interactive init mind in @@ -1888,7 +1933,7 @@ let rec compile_deps env sigma prefix ~interactive init t = let compile_constant_field env prefix con acc cb = let (gl, _) = compile_constant ~interactive:false env empty_evars prefix - con cb.const_body + con cb in gl@acc diff --git a/kernel/nativeconv.ml b/kernel/nativeconv.ml index 82786df64..766e6513c 100644 --- a/kernel/nativeconv.ml +++ b/kernel/nativeconv.ml @@ -70,7 +70,7 @@ and conv_atom pb lvl a1 a2 cu = if not (eq_constant c1 c2) then raise NotConvertible; cu | Asort s1, Asort s2 -> - sort_cmp pb s1 s2 cu + ignore(sort_cmp_universes pb s1 s2 (cu, None)); cu | Avar id1, Avar id2 -> if not (Id.equal id1 id2) then raise NotConvertible; cu @@ -131,9 +131,9 @@ let native_conv pb sigma env t1 t2 = vm_conv pb env t1 t2 end else - let env = Environ.pre_env env in + let penv = Environ.pre_env env in let ml_filename, prefix = get_ml_filename () in - let code, upds = mk_conv_code env sigma prefix t1 t2 in + let code, upds = mk_conv_code penv sigma prefix t1 t2 in match compile ml_filename code with | (0,fn) -> begin @@ -144,7 +144,7 @@ let native_conv pb sigma env t1 t2 = let time_info = Format.sprintf "Evaluation done in %.5f@." (t1 -. t0) in if !Flags.debug then Pp.msg_debug (Pp.str time_info); (* TODO change 0 when we can have deBruijn *) - conv_val pb 0 !rt1 !rt2 empty_constraint + ignore(conv_val pb 0 !rt1 !rt2 (Environ.universes env)) end | _ -> anomaly (Pp.str "Compilation failure") diff --git a/kernel/nativeinstr.mli b/kernel/nativeinstr.mli index 13d61841f..7d1bf0d19 100644 --- a/kernel/nativeinstr.mli +++ b/kernel/nativeinstr.mli @@ -29,6 +29,7 @@ and lambda = | Llet of name * lambda * lambda | Lapp of lambda * lambda array | Lconst of prefix * constant + | Lproj of prefix * constant (* prefix, projection name *) | Lprim of prefix * constant * Primitives.t * lambda array | Lcase of annot_sw * lambda * lambda * lam_branches (* annotations, term being matched, accu, branches *) diff --git a/kernel/nativelambda.ml b/kernel/nativelambda.ml index 8ea28ddff..16ca444e3 100644 --- a/kernel/nativelambda.ml +++ b/kernel/nativelambda.ml @@ -79,12 +79,12 @@ let get_const_prefix env c = | NotLinked -> "" | Linked s -> s | LinkedInteractive s -> s - + (* A generic map function *) let map_lam_with_binders g f n lam = match lam with - | Lrel _ | Lvar _ | Lconst _ | Luint _ | Lval _ | Lsort _ | Lind _ + | Lrel _ | Lvar _ | Lconst _ | Lproj _ | Luint _ | Lval _ | Lsort _ | Lind _ | Lconstruct _ | Llazy | Lforce | Lmeta _ | Levar _ -> lam | Lprod(dom,codom) -> let dom' = f n dom in @@ -183,7 +183,7 @@ let lam_subst_args subst args = let can_subst lam = match lam with - | Lrel _ | Lvar _ | Lconst _ | Lval _ | Lsort _ | Lind _ | Llam _ + | Lrel _ | Lvar _ | Lconst _ | Lproj _ | Lval _ | Lsort _ | Lind _ | Llam _ | Lconstruct _ | Lmeta _ | Levar _ -> true | _ -> false @@ -257,6 +257,7 @@ and simplify_app substf f substa args = let args = Array.append (lam_subst_args substf args') (lam_subst_args substa args) in simplify_app substf f subst_id args + (* TODO | Lproj -> simplify if the argument is known or a known global *) | _ -> mkLapp (simplify substf f) (simplify_args substa args) and simplify_args subst args = Array.smartmap (simplify subst) args @@ -290,7 +291,7 @@ let rec occurence k kind lam = if Int.equal n k then if kind then false else raise Not_found else kind - | Lvar _ | Lconst _ | Luint _ | Lval _ | Lsort _ | Lind _ + | Lvar _ | Lconst _ | Lproj _ | Luint _ | Lval _ | Lsort _ | Lind _ | Lconstruct _ | Llazy | Lforce | Lmeta _ | Levar _ -> kind | Lprod(dom, codom) -> occurence k (occurence k kind dom) codom @@ -504,7 +505,7 @@ let is_lazy prefix t = match kind_of_term t with | App (f,args) -> begin match kind_of_term f with - | Construct c -> + | Construct (c,_) -> let entry = mkInd (fst c) in (try let _ = @@ -552,7 +553,7 @@ let rec lambda_of_constr env sigma c = | Sort s -> Lsort s - | Ind ind -> + | Ind (ind,u) -> let prefix = get_mind_prefix !global_env (fst ind) in Lind (prefix, ind) @@ -584,6 +585,9 @@ let rec lambda_of_constr env sigma c = | Construct _ -> lambda_of_app env sigma c empty_args + | Proj (p, c) -> + mkLapp (Lproj (get_const_prefix !global_env p, p)) [|lambda_of_constr env sigma c|] + | Case(ci,t,a,branches) -> let (mind,i as ind) = ci.ci_ind in let mib = lookup_mind mind !global_env in @@ -642,7 +646,7 @@ let rec lambda_of_constr env sigma c = and lambda_of_app env sigma f args = match kind_of_term f with - | Const kn -> + | Const (kn,u) -> let kn = get_allias !global_env kn in let cb = lookup_constant kn !global_env in (try @@ -654,7 +658,7 @@ and lambda_of_app env sigma f args = f args with Not_found -> begin match cb.const_body with - | Def csubst -> + | Def csubst -> (* TODO optimize if f is a proj and argument is known *) if cb.const_inline_code then lambda_of_app env sigma (Mod_subst.force_constr csubst) args else @@ -669,7 +673,7 @@ and lambda_of_app env sigma f args = let prefix = get_const_prefix !global_env kn in mkLapp (Lconst (prefix, kn)) (lambda_of_args env sigma 0 args) end) - | Construct c -> + | Construct (c,u) -> let tag, nparams, arity = Renv.get_construct_info env c in let expected = nparams + arity in let nargs = Array.length args in @@ -737,7 +741,7 @@ let compile_static_int31 fc args = Luint (UintVal (Uint31.of_int (Array.fold_left (fun temp_i -> fun t -> match kind_of_term t with - | Construct (_,d) -> 2*temp_i+d-1 + | Construct ((_,d),_) -> 2*temp_i+d-1 | _ -> raise NotClosed) 0 args))) diff --git a/kernel/nativelambda.mli b/kernel/nativelambda.mli index a2763626c..33a0dacf6 100644 --- a/kernel/nativelambda.mli +++ b/kernel/nativelambda.mli @@ -12,7 +12,6 @@ open Nativevalues open Nativeinstr (** This file defines the lambda code generation phase of the native compiler *) - type evars = { evars_val : existential -> constr option; evars_typ : existential -> types; @@ -26,6 +25,8 @@ val decompose_Llam_Llet : lambda -> (Names.name * lambda option) array * lambda val is_lazy : prefix -> constr -> bool val mk_lazy : lambda -> lambda +val get_mind_prefix : env -> mutual_inductive -> string + val get_allias : env -> constant -> constant val lambda_of_constr : env -> evars -> Constr.constr -> lambda diff --git a/kernel/nativevalues.ml b/kernel/nativevalues.ml index 043f06e26..d88d5d25d 100644 --- a/kernel/nativevalues.ml +++ b/kernel/nativevalues.ml @@ -60,6 +60,7 @@ type atom = | Aprod of name * t * (t -> t) | Ameta of metavariable * t | Aevar of existential * t + | Aproj of constant * accumulator let accumulate_tag = 0 @@ -128,6 +129,9 @@ let mk_meta_accu mv ty = let mk_evar_accu ev ty = mk_accu (Aevar (ev,ty)) +let mk_proj_accu kn c = + mk_accu (Aproj (kn,c)) + let atom_of_accu (k:accumulator) = (Obj.magic (Obj.field (Obj.magic k) 2) : atom) diff --git a/kernel/nativevalues.mli b/kernel/nativevalues.mli index 4fbf493cc..32079c8d0 100644 --- a/kernel/nativevalues.mli +++ b/kernel/nativevalues.mli @@ -52,6 +52,7 @@ type atom = | Aprod of name * t * (t -> t) | Ameta of metavariable * t | Aevar of existential * t + | Aproj of constant * accumulator (* Constructors *) @@ -68,6 +69,7 @@ val mk_fix_accu : rec_pos -> int -> t array -> t array -> t val mk_cofix_accu : int -> t array -> t array -> t val mk_meta_accu : metavariable -> t val mk_evar_accu : existential -> t -> t +val mk_proj_accu : constant -> accumulator -> t val upd_cofix : t -> t -> unit val force_cofix : t -> t val mk_const : tag -> t diff --git a/kernel/opaqueproof.ml b/kernel/opaqueproof.ml index 102dcf99f..673b12b2c 100644 --- a/kernel/opaqueproof.ml +++ b/kernel/opaqueproof.ml @@ -7,11 +7,16 @@ (************************************************************************) open Names +open Univ open Term open Mod_subst -type work_list = Id.t array Cmap.t * Id.t array Mindmap.t -type cooking_info = { modlist : work_list; abstract : Context.named_context } +type work_list = (Instance.t * Id.t array) Cmap.t * + (Instance.t * Id.t array) Mindmap.t + +type cooking_info = { + modlist : work_list; + abstract : Context.named_context in_universe_context } type proofterm = (constr * Univ.constraints) Future.computation type opaque = | Indirect of substitution list * DirPath.t * int (* subst, lib, index *) @@ -94,7 +99,7 @@ let force_constraints = function | NoIndirect(_,cu) -> snd(Future.force cu) | Indirect (_,dp,i) -> match !get_univ dp i with - | None -> Univ.empty_constraint + | None -> Univ.Constraint.empty | Some u -> Future.force u let get_constraints = function diff --git a/kernel/opaqueproof.mli b/kernel/opaqueproof.mli index 957889aa9..71f491754 100644 --- a/kernel/opaqueproof.mli +++ b/kernel/opaqueproof.mli @@ -38,8 +38,12 @@ val get_constraints : opaque -> Univ.constraints Future.computation option val subst_opaque : substitution -> opaque -> opaque val iter_direct_opaque : (constr -> unit) -> opaque -> opaque -type work_list = Id.t array Cmap.t * Id.t array Mindmap.t -type cooking_info = { modlist : work_list; abstract : Context.named_context } +type work_list = (Univ.Instance.t * Id.t array) Cmap.t * + (Univ.Instance.t * Id.t array) Mindmap.t + +type cooking_info = { + modlist : work_list; + abstract : Context.named_context Univ.in_universe_context } (* The type has two caveats: 1) cook_constr is defined after diff --git a/kernel/pre_env.ml b/kernel/pre_env.ml index b655887d7..ba9f30233 100644 --- a/kernel/pre_env.ml +++ b/kernel/pre_env.ml @@ -124,7 +124,7 @@ let env_of_rel n env = let push_named_context_val d (ctxt,vals) = let id,_,_ = d in let rval = ref VKnone in - Context.add_named_decl d ctxt, (id,rval)::vals + add_named_decl d ctxt, (id,rval)::vals let push_named d env = (* if not (env.env_rel_context = []) then raise (ASSERT env.env_rel_context); diff --git a/kernel/pre_env.mli b/kernel/pre_env.mli index 964d709cf..74a5fb1ae 100644 --- a/kernel/pre_env.mli +++ b/kernel/pre_env.mli @@ -7,10 +7,10 @@ (************************************************************************) open Names -open Univ open Term open Context open Declarations +open Univ (** The type of environments. *) diff --git a/kernel/reduction.ml b/kernel/reduction.ml index 5397e42f9..63bd40681 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -26,11 +26,11 @@ open Environ open Closure open Esubst -let unfold_reference ((ids, csts), infos) k = +let conv_key k = match k with - | VarKey id when not (Id.Pred.mem id ids) -> None - | ConstKey cst when not (Cpred.mem cst csts) -> None - | _ -> unfold_reference infos k + | VarKey id -> VarKey id + | ConstKey (cst,_) -> ConstKey cst + | RelKey n -> RelKey n let rec is_empty_stack = function [] -> true @@ -58,6 +58,8 @@ let compare_stack_shape stk1 stk2 = | (_, (Zupdate _|Zshift _)::s2) -> compare_rec bal stk1 s2 | (Zapp l1::s1, _) -> compare_rec (bal+Array.length l1) s1 stk2 | (_, Zapp l2::s2) -> compare_rec (bal-Array.length l2) stk1 s2 + | (Zproj (n1,m1,p1)::s1, Zproj (n2,m2,p2)::s2) -> + Int.equal bal 0 && compare_rec 0 s1 s2 | (Zcase(c1,_,_)::s1, Zcase(c2,_,_)::s2) -> Int.equal bal 0 (* && c1.ci_ind = c2.ci_ind *) && compare_rec 0 s1 s2 | (Zfix(_,a1)::s1, Zfix(_,a2)::s2) -> @@ -67,6 +69,7 @@ let compare_stack_shape stk1 stk2 = type lft_constr_stack_elt = Zlapp of (lift * fconstr) array + | Zlproj of constant * lift | Zlfix of (lift * fconstr) * lft_constr_stack | Zlcase of case_info * lift * fconstr * fconstr array and lft_constr_stack = lft_constr_stack_elt list @@ -85,6 +88,8 @@ let pure_stack lfts stk = | (Zshift n,(l,pstk)) -> (el_shft n l, pstk) | (Zapp a, (l,pstk)) -> (l,zlapp (Array.map (fun t -> (l,t)) a) pstk) + | (Zproj (n,m,c), (l,pstk)) -> + (l, Zlproj (c,l)::pstk) | (Zfix(fx,a),(l,pstk)) -> let (lfx,pa) = pure_rec l a in (l, Zlfix((lfx,fx),pa)::pstk) @@ -96,17 +101,17 @@ let pure_stack lfts stk = (* Reduction Functions *) (****************************************************************************) -let whd_betaiota t = - whd_val (create_clos_infos betaiota empty_env) (inject t) +let whd_betaiota env t = + whd_val (create_clos_infos betaiota env) (inject t) -let nf_betaiota t = - norm_val (create_clos_infos betaiota empty_env) (inject t) +let nf_betaiota env t = + norm_val (create_clos_infos betaiota env) (inject t) -let whd_betaiotazeta x = +let whd_betaiotazeta env x = match kind_of_term x with | (Sort _|Var _|Meta _|Evar _|Const _|Ind _|Construct _| Prod _|Lambda _|Fix _|CoFix _) -> x - | _ -> whd_val (create_clos_infos betaiotazeta empty_env) (inject x) + | _ -> whd_val (create_clos_infos betaiotazeta env) (inject x) let whd_betadeltaiota env t = match kind_of_term t with @@ -143,12 +148,31 @@ let betazeta_appvect n c v = (********************************************************************) (* Conversion utility functions *) -type 'a conversion_function = env -> 'a -> 'a -> Univ.constraints -type 'a trans_conversion_function = transparent_state -> env -> 'a -> 'a -> Univ.constraints +type 'a conversion_function = env -> 'a -> 'a -> unit +type 'a trans_conversion_function = Names.transparent_state -> 'a conversion_function +type 'a universe_conversion_function = env -> Univ.universes -> 'a -> 'a -> unit +type 'a trans_universe_conversion_function = + Names.transparent_state -> 'a universe_conversion_function +type 'a infer_conversion_function = env -> Univ.universes -> 'a -> 'a -> Univ.constraints + +type conv_universes = Univ.universes * Univ.constraints option exception NotConvertible exception NotConvertibleVect of int +let convert_universes (univs,cstrs as cuniv) u u' = + if Univ.Instance.check_eq univs u u' then cuniv + else + (match cstrs with + | None -> raise NotConvertible + | Some cstrs -> (univs, Some (Univ.enforce_eq_instances u u' cstrs))) + +let conv_table_key k1 k2 cuniv = + match k1, k2 with + | ConstKey (cst, u), ConstKey (cst', u') when eq_constant_key cst cst' -> + convert_universes cuniv u u' + | _ -> raise NotConvertible + let compare_stacks f fmind lft1 stk1 lft2 stk2 cuniv = let rec cmp_rec pstk1 pstk2 cuniv = match (pstk1,pstk2) with @@ -156,6 +180,10 @@ let compare_stacks f fmind lft1 stk1 lft2 stk2 cuniv = let cu1 = cmp_rec s1 s2 cuniv in (match (z1,z2) with | (Zlapp a1,Zlapp a2) -> Array.fold_right2 f a1 a2 cu1 + | (Zlproj (c1,l1),Zlproj (c2,l2)) -> + if not (eq_constant c1 c2) then + raise NotConvertible + else cu1 | (Zlfix(fx1,a1),Zlfix(fx2,a2)) -> let cu2 = f fx1 fx2 cu1 in cmp_rec a1 a2 cu2 @@ -184,34 +212,64 @@ type conv_pb = | CUMUL let is_cumul = function CUMUL -> true | CONV -> false - -let sort_cmp pb s0 s1 cuniv = +let is_pos = function Pos -> true | Null -> false + +(* let sort_cmp env pb s0 s1 cuniv = *) +(* match (s0,s1) with *) +(* | (Prop c1, Prop c2) when is_cumul pb -> *) +(* begin match c1, c2 with *) +(* | Null, _ | _, Pos -> cuniv (\* Prop <= Set *\) *) +(* | _ -> raise NotConvertible *) +(* end *) +(* | (Prop c1, Prop c2) -> *) +(* if c1 == c2 then cuniv else raise NotConvertible *) +(* | (Prop c1, Type u) when is_cumul pb -> *) +(* enforce_leq (if is_pos c1 then Universe.type0 else Universe.type0m) u cuniv *) +(* | (Type u, Prop c) when is_cumul pb -> *) +(* enforce_leq u (if is_pos c then Universe.type0 else Universe.type0m) cuniv *) +(* | (Type u1, Type u2) -> *) +(* (match pb with *) +(* | CONV -> Univ.enforce_eq u1 u2 cuniv *) +(* | CUMUL -> enforce_leq u1 u2 cuniv) *) +(* | (_, _) -> raise NotConvertible *) + +(* let conv_sort env s0 s1 = sort_cmp CONV s0 s1 Constraint.empty *) +(* let conv_sort_leq env s0 s1 = sort_cmp CUMUL s0 s1 Constraint.empty *) + +let check_eq (univs, cstrs as cuniv) u u' = + match cstrs with + | None -> if check_eq univs u u' then cuniv else raise NotConvertible + | Some cstrs -> univs, Some (Univ.enforce_eq u u' cstrs) + +let check_leq (univs, cstrs as cuniv) u u' = + match cstrs with + | None -> if check_leq univs u u' then cuniv else raise NotConvertible + | Some cstrs -> univs, Some (Univ.enforce_leq u u' cstrs) + +let sort_cmp_universes pb s0 s1 univs = + let dir = if is_cumul pb then check_leq univs else check_eq univs in match (s0,s1) with | (Prop c1, Prop c2) when is_cumul pb -> begin match c1, c2 with - | Null, _ | _, Pos -> cuniv (* Prop <= Set *) + | Null, _ | _, Pos -> univs (* Prop <= Set *) | _ -> raise NotConvertible end - | (Prop c1, Prop c2) -> - if c1 == c2 then cuniv else raise NotConvertible - | (Prop c1, Type u) when is_cumul pb -> assert (is_univ_variable u); cuniv - | (Type u1, Type u2) -> - assert (is_univ_variable u2); - (match pb with - | CONV -> enforce_eq u1 u2 cuniv - | CUMUL -> enforce_leq u1 u2 cuniv) - | (_, _) -> raise NotConvertible + | (Prop c1, Prop c2) -> if c1 == c2 then univs else raise NotConvertible + | (Prop c1, Type u) -> dir (univ_of_sort s0) u + | (Type u, Prop c) -> dir u (univ_of_sort s1) + | (Type u1, Type u2) -> dir u1 u2 +(* let sort_cmp _ _ _ cuniv = cuniv *) -let conv_sort env s0 s1 = sort_cmp CONV s0 s1 empty_constraint - -let conv_sort_leq env s0 s1 = sort_cmp CUMUL s0 s1 empty_constraint +(* let conv_sort env s0 s1 = sort_cmp CONV s0 s1 empty_constraint *) +(* let conv_sort_leq env s0 s1 = sort_cmp CUMUL s0 s1 empty_constraint *) let rec no_arg_available = function | [] -> true | Zupdate _ :: stk -> no_arg_available stk | Zshift _ :: stk -> no_arg_available stk | Zapp v :: stk -> Int.equal (Array.length v) 0 && no_arg_available stk + | Zproj _ :: _ -> true | Zcase _ :: _ -> true | Zfix _ :: _ -> true @@ -223,6 +281,7 @@ let rec no_nth_arg_available n = function let k = Array.length v in if n >= k then no_nth_arg_available (n-k) stk else false + | Zproj _ :: _ -> true | Zcase _ :: _ -> true | Zfix _ :: _ -> true @@ -231,6 +290,7 @@ let rec no_case_available = function | Zupdate _ :: stk -> no_case_available stk | Zshift _ :: stk -> no_case_available stk | Zapp _ :: stk -> no_case_available stk + | Zproj (_,_,p) :: _ -> false | Zcase _ :: _ -> false | Zfix _ :: _ -> true @@ -241,7 +301,7 @@ let in_whnf (t,stk) = | FConstruct _ -> no_case_available stk | FCoFix _ -> no_case_available stk | FFix(((ri,n),(_,_,_)),_) -> no_nth_arg_available ri.(n) stk - | (FFlex _ | FProd _ | FEvar _ | FInd _ | FAtom _ | FRel _) -> true + | (FFlex _ | FProd _ | FEvar _ | FInd _ | FAtom _ | FRel _ | FProj _) -> true | FLOCKED -> assert false let steps = ref 0 @@ -253,6 +313,15 @@ let slave_process = | _ -> f := (fun () -> false); !f ()) in fun () -> !f () +let unfold_projection infos p c = + if RedFlags.red_set infos.i_flags (RedFlags.fCONST p) then + (match try Some (lookup_projection p (info_env infos)) with Not_found -> None with + | Some pb -> + let s = Zproj (pb.Declarations.proj_npars, pb.Declarations.proj_arg, p) in + Some (c, s) + | None -> None) + else None + (* Conversion between [lft1]term1 and [lft2]term2 *) let rec ccnv cv_pb l2r infos lft1 lft2 term1 term2 cuniv = eqappr cv_pb l2r infos (lft1, (term1,[])) (lft2, (term2,[])) cuniv @@ -266,9 +335,10 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = steps := 0; end; (* First head reduce both terms *) + let whd = whd_stack (infos_with_reds infos betaiotazeta) in let rec whd_both (t1,stk1) (t2,stk2) = - let st1' = whd_stack (snd infos) t1 stk1 in - let st2' = whd_stack (snd infos) t2 stk2 in + let st1' = whd t1 stk1 in + let st2' = whd t2 stk2 in (* Now, whd_stack on term2 might have modified st1 (due to sharing), and st1 might not be in whnf anymore. If so, we iterate ccnv. *) if in_whnf st1' then (st1',st2') else whd_both st1' st2' in @@ -284,7 +354,7 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = | (Sort s1, Sort s2) -> if not (is_empty_stack v1 && is_empty_stack v2) then anomaly (Pp.str "conversion was given ill-typed terms (Sort)"); - sort_cmp cv_pb s1 s2 cuniv + sort_cmp_universes cv_pb s1 s2 cuniv | (Meta n, Meta m) -> if Int.equal n m then convert_stacks l2r infos lft1 lft2 v1 v2 cuniv @@ -292,10 +362,10 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = | _ -> raise NotConvertible) | (FEvar ((ev1,args1),env1), FEvar ((ev2,args2),env2)) -> if Evar.equal ev1 ev2 then - let u1 = convert_stacks l2r infos lft1 lft2 v1 v2 cuniv in + let cuniv = convert_stacks l2r infos lft1 lft2 v1 v2 cuniv in convert_vect l2r infos el1 el2 (Array.map (mk_clos env1) args1) - (Array.map (mk_clos env2) args2) u1 + (Array.map (mk_clos env2) args2) cuniv else raise NotConvertible (* 2 index known to be bound to no constant *) @@ -307,28 +377,59 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = (* 2 constants, 2 local defined vars or 2 defined rels *) | (FFlex fl1, FFlex fl2) -> (try (* try first intensional equality *) - if eq_table_key fl1 fl2 - then convert_stacks l2r infos lft1 lft2 v1 v2 cuniv - else raise NotConvertible + if eq_table_key fl1 fl2 then convert_stacks l2r infos lft1 lft2 v1 v2 cuniv + else + (let cuniv = conv_table_key fl1 fl2 cuniv in + convert_stacks l2r infos lft1 lft2 v1 v2 cuniv) with NotConvertible -> (* else the oracle tells which constant is to be expanded *) let (app1,app2) = - if Conv_oracle.oracle_order (Closure.oracle_of_infos (snd infos)) l2r fl1 fl2 then + if Conv_oracle.oracle_order (Closure.oracle_of_infos infos) l2r (conv_key fl1) (conv_key fl2) then match unfold_reference infos fl1 with - | Some def1 -> ((lft1, whd_stack (snd infos) def1 v1), appr2) + | Some def1 -> ((lft1, whd def1 v1), appr2) | None -> (match unfold_reference infos fl2 with - | Some def2 -> (appr1, (lft2, whd_stack (snd infos) def2 v2)) + | Some def2 -> (appr1, (lft2, whd def2 v2)) | None -> raise NotConvertible) else match unfold_reference infos fl2 with - | Some def2 -> (appr1, (lft2, whd_stack (snd infos) def2 v2)) + | Some def2 -> (appr1, (lft2, whd def2 v2)) | None -> (match unfold_reference infos fl1 with - | Some def1 -> ((lft1, whd_stack (snd infos) def1 v1), appr2) + | Some def1 -> ((lft1, whd def1 v1), appr2) | None -> raise NotConvertible) in eqappr cv_pb l2r infos app1 app2 cuniv) + | (FProj (p1,c1), FProj (p2, c2)) -> + (* Projections: prefer unfolding to first-order unification, + which will happen naturally if the terms c1, c2 are not in constructor + form *) + (match unfold_projection infos p1 c1 with + | Some (def1,s1) -> + eqappr cv_pb l2r infos (lft1, whd def1 (s1 :: v1)) appr2 cuniv + | None -> + match unfold_projection infos p2 c2 with + | Some (def2,s2) -> + eqappr cv_pb l2r infos appr1 (lft2, whd def2 (s2 :: v2)) cuniv + | None -> + if eq_constant p1 p2 && compare_stack_shape v1 v2 then + let u1 = ccnv CONV l2r infos el1 el2 c1 c2 cuniv in + convert_stacks l2r infos lft1 lft2 v1 v2 u1 + else (* Two projections in WHNF: unfold *) + raise NotConvertible) + + | (FProj (p1,c1), t2) -> + (match unfold_projection infos p1 c1 with + | Some (def1,s1) -> + eqappr cv_pb l2r infos (lft1, whd def1 (s1 :: v1)) appr2 cuniv + | None -> raise NotConvertible) + + | (_, FProj (p2,c2)) -> + (match unfold_projection infos p2 c2 with + | Some (def2,s2) -> + eqappr cv_pb l2r infos appr1 (lft2, whd def2 (s2 :: v2)) cuniv + | None -> raise NotConvertible) + (* other constructors *) | (FLambda _, FLambda _) -> (* Inconsistency: we tolerate that v1, v2 contain shift and update but @@ -337,15 +438,15 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = anomaly (Pp.str "conversion was given ill-typed terms (FLambda)"); let (_,ty1,bd1) = destFLambda mk_clos hd1 in let (_,ty2,bd2) = destFLambda mk_clos hd2 in - let u1 = ccnv CONV l2r infos el1 el2 ty1 ty2 cuniv in - ccnv CONV l2r infos (el_lift el1) (el_lift el2) bd1 bd2 u1 + let cuniv = ccnv CONV l2r infos el1 el2 ty1 ty2 cuniv in + ccnv CONV l2r infos (el_lift el1) (el_lift el2) bd1 bd2 cuniv | (FProd (_,c1,c2), FProd (_,c'1,c'2)) -> if not (is_empty_stack v1 && is_empty_stack v2) then anomaly (Pp.str "conversion was given ill-typed terms (FProd)"); (* Luo's system *) - let u1 = ccnv CONV l2r infos el1 el2 c1 c'1 cuniv in - ccnv cv_pb l2r infos (el_lift el1) (el_lift el2) c2 c'2 u1 + let cuniv = ccnv CONV l2r infos el1 el2 c1 c'1 cuniv in + ccnv cv_pb l2r infos (el_lift el1) (el_lift el2) c2 c'2 cuniv (* Eta-expansion on the fly *) | (FLambda _, _) -> @@ -368,30 +469,63 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = (el_lift lft1, (hd1, eta_expand_stack v1)) (el_lift lft2, (bd2, [])) cuniv (* only one constant, defined var or defined rel *) - | (FFlex fl1, _) -> + | (FFlex fl1, c2) -> (match unfold_reference infos fl1 with | Some def1 -> - eqappr cv_pb l2r infos (lft1, whd_stack (snd infos) def1 v1) appr2 cuniv - | None -> raise NotConvertible) - | (_, FFlex fl2) -> + eqappr cv_pb l2r infos (lft1, whd def1 v1) appr2 cuniv + | None -> + match c2 with + | FConstruct ((ind2,j2),u2) -> + (try + let v2, v1 = + eta_expand_ind_stacks (info_env infos) ind2 hd2 v2 (snd appr1) + in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv + with Not_found -> raise NotConvertible) + | _ -> raise NotConvertible) + + | (c1, FFlex fl2) -> (match unfold_reference infos fl2 with | Some def2 -> - eqappr cv_pb l2r infos appr1 (lft2, whd_stack (snd infos) def2 v2) cuniv - | None -> raise NotConvertible) - + eqappr cv_pb l2r infos appr1 (lft2, whd def2 v2) cuniv + | None -> + match c1 with + | FConstruct ((ind1,j1),u1) -> + (try let v1, v2 = + eta_expand_ind_stacks (info_env infos) ind1 hd1 v1 (snd appr2) + in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv + with Not_found -> raise NotConvertible) + | _ -> raise NotConvertible) + (* Inductive types: MutInd MutConstruct Fix Cofix *) - | (FInd ind1, FInd ind2) -> + | (FInd (ind1,u1), FInd (ind2,u2)) -> if eq_ind ind1 ind2 then - convert_stacks l2r infos lft1 lft2 v1 v2 cuniv + (let cuniv = convert_universes cuniv u1 u2 in + convert_stacks l2r infos lft1 lft2 v1 v2 cuniv) else raise NotConvertible - | (FConstruct (ind1,j1), FConstruct (ind2,j2)) -> + | (FConstruct ((ind1,j1),u1), FConstruct ((ind2,j2),u2)) -> if Int.equal j1 j2 && eq_ind ind1 ind2 then - convert_stacks l2r infos lft1 lft2 v1 v2 cuniv + (let cuniv = convert_universes cuniv u1 u2 in + convert_stacks l2r infos lft1 lft2 v1 v2 cuniv) else raise NotConvertible + + (* Eta expansion of records *) + | (FConstruct ((ind1,j1),u1), _) -> + (try + let v1, v2 = + eta_expand_ind_stacks (info_env infos) ind1 hd1 v1 (snd appr2) + in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv + with Not_found -> raise NotConvertible) + + | (_, FConstruct ((ind2,j2),u2)) -> + (try + let v2, v1 = + eta_expand_ind_stacks (info_env infos) ind2 hd2 v2 (snd appr1) + in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv + with Not_found -> raise NotConvertible) | (FFix (((op1, i1),(_,tys1,cl1)),e1), FFix(((op2, i2),(_,tys2,cl2)),e2)) -> if Int.equal i1 i2 && Array.equal Int.equal op1 op2 @@ -401,11 +535,11 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = let fty2 = Array.map (mk_clos e2) tys2 in let fcl1 = Array.map (mk_clos (subs_liftn n e1)) cl1 in let fcl2 = Array.map (mk_clos (subs_liftn n e2)) cl2 in - let u1 = convert_vect l2r infos el1 el2 fty1 fty2 cuniv in - let u2 = + let cuniv = convert_vect l2r infos el1 el2 fty1 fty2 cuniv in + let cuniv = convert_vect l2r infos - (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 u1 in - convert_stacks l2r infos lft1 lft2 v1 v2 u2 + (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 cuniv in + convert_stacks l2r infos lft1 lft2 v1 v2 cuniv else raise NotConvertible | (FCoFix ((op1,(_,tys1,cl1)),e1), FCoFix((op2,(_,tys2,cl2)),e2)) -> @@ -416,11 +550,11 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = let fty2 = Array.map (mk_clos e2) tys2 in let fcl1 = Array.map (mk_clos (subs_liftn n e1)) cl1 in let fcl2 = Array.map (mk_clos (subs_liftn n e2)) cl2 in - let u1 = convert_vect l2r infos el1 el2 fty1 fty2 cuniv in - let u2 = + let cuniv = convert_vect l2r infos el1 el2 fty1 fty2 cuniv in + let cuniv = convert_vect l2r infos - (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 u1 in - convert_stacks l2r infos lft1 lft2 v1 v2 u2 + (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 cuniv in + convert_stacks l2r infos lft1 lft2 v1 v2 cuniv else raise NotConvertible (* Should not happen because both (hd1,v1) and (hd2,v2) are in whnf *) @@ -433,7 +567,7 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = and convert_stacks l2r infos lft1 lft2 stk1 stk2 cuniv = compare_stacks - (fun (l1,t1) (l2,t2) c -> ccnv CONV l2r infos l1 l2 t1 t2 c) + (fun (l1,t1) (l2,t2) c -> ccnv CONV l2r infos l1 l2 t1 t2 cuniv) (eq_ind) lft1 stk1 lft2 stk2 cuniv @@ -442,26 +576,45 @@ and convert_vect l2r infos lft1 lft2 v1 v2 cuniv = let lv2 = Array.length v2 in if Int.equal lv1 lv2 then - let rec fold n univ = - if n >= lv1 then univ + let rec fold n cuniv = + if n >= lv1 then cuniv else - let u1 = ccnv CONV l2r infos lft1 lft2 v1.(n) v2.(n) univ in - fold (n+1) u1 in + let cuniv = ccnv CONV l2r infos lft1 lft2 v1.(n) v2.(n) cuniv in + fold (n+1) cuniv in fold 0 cuniv else raise NotConvertible -let clos_fconv trans cv_pb l2r evars env t1 t2 = - let infos = trans, create_clos_infos ~evars betaiotazeta env in - ccnv cv_pb l2r infos el_id el_id (inject t1) (inject t2) empty_constraint +let clos_fconv trans cv_pb l2r evars env univs t1 t2 = + let reds = Closure.RedFlags.red_add_transparent betaiotazeta trans in + let infos = create_clos_infos ~evars reds env in + ccnv cv_pb l2r infos el_id el_id (inject t1) (inject t2) univs -let trans_fconv reds cv_pb l2r evars env t1 t2 = - if eq_constr t1 t2 then empty_constraint - else clos_fconv reds cv_pb l2r evars env t1 t2 +let trans_fconv_universes reds cv_pb l2r evars env univs t1 t2 = + let b = + if cv_pb = CUMUL then leq_constr_univs univs t1 t2 + else eq_constr_univs univs t1 t2 + in + if b then () + else + let _ = clos_fconv reds cv_pb l2r evars env (univs, None) t1 t2 in + () + +(* Profiling *) +(* let trans_fconv_universes_key = Profile.declare_profile "trans_fconv_universes" *) +(* let trans_fconv_universes = Profile.profile8 trans_fconv_universes_key trans_fconv_universes *) + +let trans_fconv reds cv_pb l2r evars env = + trans_fconv_universes reds cv_pb l2r evars env (universes env) let trans_conv_cmp ?(l2r=false) conv reds = trans_fconv reds conv l2r (fun _->None) let trans_conv ?(l2r=false) ?(evars=fun _->None) reds = trans_fconv reds CONV l2r evars let trans_conv_leq ?(l2r=false) ?(evars=fun _->None) reds = trans_fconv reds CUMUL l2r evars +let trans_conv_universes ?(l2r=false) ?(evars=fun _->None) reds = + trans_fconv_universes reds CONV l2r evars +let trans_conv_leq_universes ?(l2r=false) ?(evars=fun _->None) reds = + trans_fconv_universes reds CUMUL l2r evars + let fconv = trans_fconv (Id.Pred.full, Cpred.full) let conv_cmp ?(l2r=false) cv_pb = fconv cv_pb l2r (fun _->None) @@ -470,22 +623,43 @@ let conv_leq ?(l2r=false) ?(evars=fun _->None) = fconv CUMUL l2r evars let conv_leq_vecti ?(l2r=false) ?(evars=fun _->None) env v1 v2 = Array.fold_left2_i - (fun i c t1 t2 -> - let c' = - try conv_leq ~l2r ~evars env t1 t2 - with NotConvertible -> raise (NotConvertibleVect i) in - union_constraints c c') - empty_constraint + (fun i _ t1 t2 -> + try conv_leq ~l2r ~evars env t1 t2 + with NotConvertible -> raise (NotConvertibleVect i)) + () v1 v2 +let infer_conv_universes cv_pb l2r evars reds env univs t1 t2 = + let b = + if cv_pb = CUMUL then leq_constr_univs univs t1 t2 + else eq_constr_univs univs t1 t2 + in + if b then Constraint.empty + else + let (u, cstrs) = + clos_fconv reds cv_pb l2r evars env (univs, Some Constraint.empty) t1 t2 + in Option.get cstrs + +(* Profiling *) +(* let infer_conv_universes_key = Profile.declare_profile "infer_conv_universes" *) +(* let infer_conv_universes = Profile.profile8 infer_conv_universes_key infer_conv_universes *) + +let infer_conv ?(l2r=false) ?(evars=fun _ -> None) ?(ts=full_transparent_state) + env univs t1 t2 = + infer_conv_universes CONV l2r evars ts env univs t1 t2 + +let infer_conv_leq ?(l2r=false) ?(evars=fun _ -> None) ?(ts=full_transparent_state) + env univs t1 t2 = + infer_conv_universes CUMUL l2r evars ts env univs t1 t2 + (* option for conversion *) let nat_conv = ref (fun cv_pb sigma -> fconv cv_pb false (sigma.Nativelambda.evars_val)) let set_nat_conv f = nat_conv := f let native_conv cv_pb sigma env t1 t2 = - if eq_constr t1 t2 then empty_constraint + if eq_constr t1 t2 then () else begin let t1 = (it_mkLambda_or_LetIn t1 (rel_context env)) in let t2 = (it_mkLambda_or_LetIn t2 (rel_context env)) in diff --git a/kernel/reduction.mli b/kernel/reduction.mli index 7c0607cc4..b9bd41f28 100644 --- a/kernel/reduction.mli +++ b/kernel/reduction.mli @@ -13,28 +13,39 @@ open Environ (*********************************************************************** s Reduction functions *) -val whd_betaiotazeta : constr -> constr +val whd_betaiotazeta : env -> constr -> constr val whd_betadeltaiota : env -> constr -> constr val whd_betadeltaiota_nolet : env -> constr -> constr -val whd_betaiota : constr -> constr -val nf_betaiota : constr -> constr +val whd_betaiota : env -> constr -> constr +val nf_betaiota : env -> constr -> constr (*********************************************************************** s conversion functions *) exception NotConvertible exception NotConvertibleVect of int -type 'a conversion_function = env -> 'a -> 'a -> Univ.constraints -type 'a trans_conversion_function = Names.transparent_state -> env -> 'a -> 'a -> Univ.constraints + +type conv_universes = Univ.universes * Univ.constraints option + +type 'a conversion_function = env -> 'a -> 'a -> unit +type 'a trans_conversion_function = Names.transparent_state -> 'a conversion_function +type 'a universe_conversion_function = env -> Univ.universes -> 'a -> 'a -> unit +type 'a trans_universe_conversion_function = + Names.transparent_state -> 'a universe_conversion_function + +type 'a infer_conversion_function = env -> Univ.universes -> 'a -> 'a -> Univ.constraints type conv_pb = CONV | CUMUL -val sort_cmp : - conv_pb -> sorts -> sorts -> Univ.constraints -> Univ.constraints +val sort_cmp_universes : + conv_pb -> sorts -> sorts -> conv_universes -> conv_universes -val conv_sort : sorts conversion_function -val conv_sort_leq : sorts conversion_function +(* val sort_cmp : *) +(* conv_pb -> sorts -> sorts -> Univ.constraints -> Univ.constraints *) + +(* val conv_sort : sorts conversion_function *) +(* val conv_sort_leq : sorts conversion_function *) val trans_conv_cmp : ?l2r:bool -> conv_pb -> constr trans_conversion_function val trans_conv : @@ -42,6 +53,11 @@ val trans_conv : val trans_conv_leq : ?l2r:bool -> ?evars:(existential->constr option) -> types trans_conversion_function +val trans_conv_universes : + ?l2r:bool -> ?evars:(existential->constr option) -> constr trans_universe_conversion_function +val trans_conv_leq_universes : + ?l2r:bool -> ?evars:(existential->constr option) -> types trans_universe_conversion_function + val conv_cmp : ?l2r:bool -> conv_pb -> constr conversion_function val conv : ?l2r:bool -> ?evars:(existential->constr option) -> constr conversion_function @@ -50,6 +66,11 @@ val conv_leq : val conv_leq_vecti : ?l2r:bool -> ?evars:(existential->constr option) -> types array conversion_function +val infer_conv : ?l2r:bool -> ?evars:(existential->constr option) -> + ?ts:Names.transparent_state -> constr infer_conversion_function +val infer_conv_leq : ?l2r:bool -> ?evars:(existential->constr option) -> + ?ts:Names.transparent_state -> types infer_conversion_function + (** option for conversion *) val set_vm_conv : (conv_pb -> types conversion_function) -> unit val vm_conv : conv_pb -> types conversion_function diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index c89766fb9..093797fc0 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -139,7 +139,7 @@ let empty_environment = modlabels = Label.Set.empty; objlabels = Label.Set.empty; future_cst = []; - univ = Univ.empty_constraint; + univ = Univ.Constraint.empty; engagement = None; imports = []; loads = []; @@ -197,7 +197,10 @@ let add_constraints cst senv = | Now cst -> { senv with env = Environ.add_constraints cst senv.env; - univ = Univ.union_constraints cst senv.univ } + univ = Univ.Constraint.union cst senv.univ } + +let push_context_set ctx = add_constraints (Now (Univ.ContextSet.constraints ctx)) +let push_context ctx = add_constraints (Now (Univ.UContext.constraints ctx)) let is_curmod_library senv = match senv.modvariant with LIBRARY -> true | _ -> false @@ -291,22 +294,22 @@ let safe_push_named (id,_,_ as d) env = with Not_found -> () in Environ.push_named d env + let push_named_def (id,de) senv = - let (c,typ,cst) = Term_typing.translate_local_def senv.env id de in - let c,cst' = match c with - | Def c -> Mod_subst.force_constr c, Univ.empty_constraint - | OpaqueDef o -> Opaqueproof.force_proof o, Opaqueproof.force_constraints o + let c,typ,univs = Term_typing.translate_local_def senv.env id de in + let c = match c with + | Def c -> Mod_subst.force_constr c + | OpaqueDef o -> Opaqueproof.force_proof o | _ -> assert false in - let senv = add_constraints (Now cst') senv in - let senv' = add_constraints (Now cst) senv in + let senv' = push_context de.Entries.const_entry_universes senv in let env'' = safe_push_named (id,Some c,typ) senv'.env in - (Univ.union_constraints cst cst', {senv' with env=env''}) + {senv' with env=env''} -let push_named_assum (id,t) senv = - let (t,cst) = Term_typing.translate_local_assum senv.env t in - let senv' = add_constraints (Now cst) senv in +let push_named_assum ((id,t),ctx) senv = + let senv' = push_context_set ctx senv in + let t = Term_typing.translate_local_assum senv'.env t in let env'' = safe_push_named (id,None,t) senv'.env in - (cst, {senv' with env=env''}) + {senv' with env=env''} (** {6 Insertion of new declarations to current environment } *) @@ -324,20 +327,35 @@ let labels_of_mib mib = Array.iter visit_mip mib.mind_packets; get () -let constraints_of_sfb = function - | SFBmind mib -> [Now mib.mind_constraints] - | SFBmodtype mtb -> [Now mtb.typ_constraints] - | SFBmodule mb -> [Now mb.mod_constraints] - | SFBconst cb -> [Now cb.const_constraints] @ - match cb.const_body with - | (Undef _ | Def _) -> [] - | OpaqueDef lc -> - match Opaqueproof.get_constraints lc with - | None -> [] - | Some fc -> - match Future.peek_val fc with - | None -> [Later fc] - | Some c -> [Now c] +let globalize_constant_universes cb = + if cb.const_polymorphic then + Now Univ.Constraint.empty + else + (match Future.peek_val cb.const_universes with + | Some c -> Now (Univ.UContext.constraints c) + | None -> Later (Future.chain ~pure:true cb.const_universes Univ.UContext.constraints)) + +let globalize_mind_universes mb = + if mb.mind_polymorphic then + Now Univ.Constraint.empty + else + Now (Univ.UContext.constraints mb.mind_universes) + +let constraints_of_sfb sfb = + match sfb with + | SFBconst cb -> globalize_constant_universes cb + | SFBmind mib -> globalize_mind_universes mib + | SFBmodtype mtb -> Now mtb.typ_constraints + | SFBmodule mb -> Now mb.mod_constraints + +(* let add_constraints cst senv = *) +(* { senv with *) +(* env = Environ.add_constraints cst senv.env; *) +(* univ = Univ.Constraint.union cst senv.univ } *) + +(* let next_universe senv = *) +(* let univ = senv.max_univ in *) +(* univ + 1, { senv with max_univ = univ + 1 } *) (** A generic function for adding a new field in a same environment. It also performs the corresponding [add_constraints]. *) @@ -358,7 +376,8 @@ let add_field ((l,sfb) as field) gn senv = | SFBmodule _ | SFBmodtype _ -> check_modlabel l senv; (Label.Set.singleton l, Label.Set.empty) in - let senv = List.fold_right add_constraints (constraints_of_sfb sfb) senv in + let cst = constraints_of_sfb sfb in + let senv = add_constraints cst senv in let env' = match sfb, gn with | SFBconst cb, C con -> Environ.add_constant con cb senv.env | SFBmind mib, I mind -> Environ.add_mind mind mib senv.env @@ -377,7 +396,6 @@ let add_field ((l,sfb) as field) gn senv = let update_resolver f senv = { senv with modresolver = f senv.modresolver } (** Insertion of constants and parameters in environment *) - type global_declaration = | ConstantEntry of Entries.constant_entry | GlobalRecipe of Cooking.recipe @@ -548,8 +566,8 @@ let propagate_senv newdef newenv newresolver senv oldsenv = modlabels = Label.Set.add (fst newdef) oldsenv.modlabels; univ = List.fold_left (fun acc cst -> - Univ.union_constraints acc (Future.force cst)) - (Univ.union_constraints senv.univ oldsenv.univ) + Univ.Constraint.union acc (Future.force cst)) + (Univ.Constraint.union senv.univ oldsenv.univ) now_cst; future_cst = later_cst @ oldsenv.future_cst; (* engagement is propagated to the upper level *) @@ -571,7 +589,7 @@ let end_module l restype senv = let senv'= propagate_loads { senv with env = newenv; - univ = Univ.union_constraints senv.univ mb.mod_constraints} in + univ = Univ.Constraint.union senv.univ mb.mod_constraints} in let newenv = Environ.add_constraints mb.mod_constraints senv'.env in let newenv = Modops.add_module mb newenv in let newresolver = @@ -637,7 +655,7 @@ let add_include me is_module inl senv = { typ_mp = mp_sup; typ_expr = NoFunctor (List.rev senv.revstruct); typ_expr_alg = None; - typ_constraints = Univ.empty_constraint; + typ_constraints = Univ.Constraint.empty; typ_delta = senv.modresolver } in compute_sign sign mtb resolver senv in @@ -672,6 +690,10 @@ type compiled_library = { type native_library = Nativecode.global list +(** FIXME: MS: remove?*) +let current_modpath senv = senv.modpath +let current_dirpath senv = Names.ModPath.dp (current_modpath senv) + let start_library dir senv = check_initial senv; assert (not (DirPath.is_empty dir)); @@ -747,10 +769,7 @@ type judgment = Environ.unsafe_judgment let j_val j = j.Environ.uj_val let j_type j = j.Environ.uj_type -let safe_infer senv = Typeops.infer (env_of_senv senv) - -let typing senv = Typeops.typing (env_of_senv senv) - +let typing senv = Typeops.infer (env_of_senv senv) (** {6 Retroknowledge / native compiler } *) diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index d70d7d8be..ad2148ead 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -55,9 +55,9 @@ val join_safe_environment : safe_environment -> safe_environment (** Insertion of local declarations (Local or Variables) *) val push_named_assum : - Id.t * Term.types -> Univ.constraints safe_transformer + (Id.t * Term.types) Univ.in_universe_context_set -> safe_transformer0 val push_named_def : - Id.t * Entries.definition_entry -> Univ.constraints safe_transformer + Id.t * Entries.definition_entry -> safe_transformer0 (** Insertion of global axioms or definitions *) @@ -85,10 +85,19 @@ val add_modtype : (** Adding universe constraints *) -val add_constraints : Univ.constraints -> safe_transformer0 +val push_context_set : + Univ.universe_context_set -> safe_transformer0 -(** Setting the Set-impredicative engagement *) +val push_context : + Univ.universe_context -> safe_transformer0 +val add_constraints : + Univ.constraints -> safe_transformer0 + +(* (\** Generator of universes *\) *) +(* val next_universe : int safe_transformer *) + +(** Settin the strongly constructive or classical logical engagement *) val set_engagement : Declarations.engagement -> safe_transformer0 (** {6 Interactive module functions } *) @@ -113,6 +122,10 @@ val add_include : Entries.module_struct_entry -> bool -> Declarations.inline -> Mod_subst.delta_resolver safe_transformer +val current_modpath : safe_environment -> module_path + +val current_dirpath : safe_environment -> dir_path + (** {6 Libraries : loading and saving compilation units } *) type compiled_library @@ -137,12 +150,7 @@ type judgment val j_val : judgment -> Term.constr val j_type : judgment -> Term.constr -(** The safe typing of a term returns a typing judgment and some universe - constraints (to be added to the environment for the judgment to - hold). It is guaranteed that the constraints are satisfiable. - *) -val safe_infer : safe_environment -> Term.constr -> judgment * Univ.constraints - +(** The safe typing of a term returns a typing judgment. *) val typing : safe_environment -> Term.constr -> judgment (** {6 Queries } *) @@ -164,4 +172,4 @@ val register : val register_inline : constant -> safe_transformer0 val set_strategy : - safe_environment -> 'a Names.tableKey -> Conv_oracle.level -> safe_environment + safe_environment -> Names.constant Names.tableKey -> Conv_oracle.level -> safe_environment diff --git a/kernel/sorts.ml b/kernel/sorts.ml index 03f1cd265..3ebd06dd8 100644 --- a/kernel/sorts.ml +++ b/kernel/sorts.ml @@ -20,6 +20,16 @@ let prop = Prop Null let set = Prop Pos let type1 = Type type1_univ +let univ_of_sort = function + | Type u -> u + | Prop Pos -> Universe.type0 + | Prop Null -> Universe.type0m + +let sort_of_univ u = + if is_type0m_univ u then Prop Null + else if is_type0_univ u then Prop Pos + else Type u + let compare s1 s2 = if s1 == s2 then 0 else match s1, s2 with @@ -36,8 +46,16 @@ let compare s1 s2 = let equal s1 s2 = Int.equal (compare s1 s2) 0 let is_prop = function -| Prop Null -> true -| _ -> false + | Prop Null -> true + | _ -> false + +let is_set = function + | Prop Pos -> true + | _ -> false + +let is_small = function + | Prop _ -> true + | Type u -> is_small_univ u let family = function | Prop Null -> InProp @@ -56,7 +74,7 @@ let hash = function in combinesmall 1 h | Type u -> - let h = Universe.hash u in + let h = Hashtbl.hash u in (** FIXME *) combinesmall 2 h module List = struct @@ -70,14 +88,18 @@ module Hsorts = type _t = t type t = _t type u = universe -> universe + let hashcons huniv = function - | Type u -> Type (huniv u) + | Type u as c -> + let u' = huniv u in + if u' == u then c else Type u' | s -> s let equal s1 s2 = match (s1,s2) with | (Prop c1, Prop c2) -> c1 == c2 | (Type u1, Type u2) -> u1 == u2 |_ -> false - let hash = hash + + let hash = Hashtbl.hash (** FIXME *) end) let hcons = Hashcons.simple_hcons Hsorts.generate hcons_univ diff --git a/kernel/sorts.mli b/kernel/sorts.mli index 2750145f1..ff7d138d6 100644 --- a/kernel/sorts.mli +++ b/kernel/sorts.mli @@ -24,7 +24,9 @@ val equal : t -> t -> bool val compare : t -> t -> int val hash : t -> int +val is_set : t -> bool val is_prop : t -> bool +val is_small : t -> bool val family : t -> family val hcons : t -> t @@ -35,3 +37,6 @@ module List : sig val mem : family -> family list -> bool val intersect : family list -> family list -> family list end + +val univ_of_sort : t -> Univ.universe +val sort_of_univ : Univ.universe -> t diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml index af4468981..2c093939a 100644 --- a/kernel/subtyping.ml +++ b/kernel/subtyping.ml @@ -80,10 +80,8 @@ let make_labmap mp list = let check_conv_error error why cst f env a1 a2 = - try - union_constraints cst (f env a1 a2) - with - NotConvertible -> error why + try Constraint.union cst (f env (Environ.universes env) a1 a2) + with NotConvertible -> error why (* for now we do not allow reorderings *) @@ -94,10 +92,15 @@ let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2 let check_conv why cst f = check_conv_error error why cst f in let mib1 = match info1 with - | IndType ((_,0), mib) -> Declareops.subst_mind subst1 mib + | IndType ((_,0), mib) -> Declareops.subst_mind_body subst1 mib | _ -> error (InductiveFieldExpected mib2) in - let mib2 = Declareops.subst_mind subst2 mib2 in + let u = + if mib1.mind_polymorphic then + UContext.instance mib1.mind_universes + else Instance.empty + in + let mib2 = Declareops.subst_mind_body subst2 mib2 in let check_inductive_type cst name env t1 t2 = (* Due to sort-polymorphism in inductive types, the conclusions of @@ -131,7 +134,7 @@ let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2 error (NotConvertibleInductiveField name) | _ -> (s1, s2) in check_conv (NotConvertibleInductiveField name) - cst conv_leq env (mkArity (ctx1,s1)) (mkArity (ctx2,s2)) + cst infer_conv_leq env (mkArity (ctx1,s1)) (mkArity (ctx2,s2)) in let check_packet cst p1 p2 = @@ -149,18 +152,20 @@ let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2 (* nparams done *) (* params_ctxt done because part of the inductive types *) (* Don't check the sort of the type if polymorphic *) - let cst = check_inductive_type cst p2.mind_typename env (type_of_inductive env (mib1,p1)) (type_of_inductive env (mib2,p2)) - in + let ty1, cst1 = constrained_type_of_inductive env ((mib1,p1),u) in + let ty2, cst2 = constrained_type_of_inductive env ((mib2,p2),u) in + let cst = Constraint.union cst1 (Constraint.union cst2 cst) in + let cst = check_inductive_type cst p2.mind_typename env ty1 ty2 in cst in let mind = mind_of_kn kn1 in let check_cons_types i cst p1 p2 = Array.fold_left3 - (fun cst id t1 t2 -> check_conv (NotConvertibleConstructorField id) cst conv env t1 t2) + (fun cst id t1 t2 -> check_conv (NotConvertibleConstructorField id) cst infer_conv env t1 t2) cst p2.mind_consnames - (arities_of_specif mind (mib1,p1)) - (arities_of_specif mind (mib2,p2)) + (arities_of_specif (mind,u) (mib1,p1)) + (arities_of_specif (mind,u) (mib2,p2)) in let check f test why = if not (test (f mib1) (f mib2)) then error (why (f mib2)) in check (fun mib -> mib.mind_finite) (==) (fun x -> FiniteInductiveFieldExpected x); @@ -180,13 +185,13 @@ let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2 let kn2' = kn_of_delta reso2 kn2 in if KerName.equal kn2 kn2' || MutInd.equal (mind_of_delta_kn reso1 kn1) - (subst_ind subst2 (MutInd.make kn2 kn2')) + (subst_mind subst2 (MutInd.make kn2 kn2')) then () else error NotEqualInductiveAliases end; (* we check that records and their field names are preserved. *) - check (fun mib -> mib.mind_record) (==) (fun x -> RecordFieldExpected x); - if mib1.mind_record then begin + check (fun mib -> mib.mind_record <> None) (==) (fun x -> RecordFieldExpected x); + if mib1.mind_record <> None then begin let rec names_prod_letin t = match kind_of_term t with | Prod(n,_,t) -> n::(names_prod_letin t) | LetIn(n,_,_,t) -> n::(names_prod_letin t) @@ -264,17 +269,16 @@ let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 = t1,t2 else (t1,t2) in - check_conv err cst conv_leq env t1 t2 + check_conv err cst infer_conv_leq env t1 t2 in - match info1 with | Constant cb1 -> let () = assert (List.is_empty cb1.const_hyps && List.is_empty cb2.const_hyps) in let cb1 = Declareops.subst_const_body subst1 cb1 in let cb2 = Declareops.subst_const_body subst2 cb2 in (* Start by checking types*) - let typ1 = Typeops.type_of_constant_type env cb1.const_type in - let typ2 = Typeops.type_of_constant_type env cb2.const_type in + let typ1 = cb1.const_type in + let typ2 = cb2.const_type in let cst = check_type cst env typ1 typ2 in (* Now we check the bodies: - A transparent constant can only be implemented by a compatible @@ -292,7 +296,7 @@ let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 = Anyway [check_conv] will handle that afterwards. *) let c1 = Mod_subst.force_constr lc1 in let c2 = Mod_subst.force_constr lc2 in - check_conv NotConvertibleBodyField cst conv env c1 c2)) + check_conv NotConvertibleBodyField cst infer_conv env c1 c2)) | IndType ((kn,i),mind1) -> ignore (Errors.error ( "The kernel does not recognize yet that a parameter can be " ^ @@ -301,10 +305,14 @@ let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 = "name.")); let () = assert (List.is_empty mind1.mind_hyps && List.is_empty cb2.const_hyps) in if Declareops.constant_has_body cb2 then error DefinitionFieldExpected; - let arity1 = type_of_inductive env (mind1,mind1.mind_packets.(i)) in - let typ2 = Typeops.type_of_constant_type env cb2.const_type in + let u1 = inductive_instance mind1 in + let arity1,cst1 = constrained_type_of_inductive env + ((mind1,mind1.mind_packets.(i)),u1) in + let cst2 = UContext.constraints (Future.force cb2.const_universes) in + let typ2 = cb2.const_type in + let cst = Constraint.union cst (Constraint.union cst1 cst2) in let error = NotConvertibleTypeField (env, arity1, typ2) in - check_conv error cst conv_leq env arity1 typ2 + check_conv error cst infer_conv_leq env arity1 typ2 | IndConstr (((kn,i),j) as cstr,mind1) -> ignore (Errors.error ( "The kernel does not recognize yet that a parameter can be " ^ @@ -313,10 +321,13 @@ let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 = "name.")); let () = assert (List.is_empty mind1.mind_hyps && List.is_empty cb2.const_hyps) in if Declareops.constant_has_body cb2 then error DefinitionFieldExpected; - let ty1 = type_of_constructor cstr (mind1,mind1.mind_packets.(i)) in - let ty2 = Typeops.type_of_constant_type env cb2.const_type in + let u1 = inductive_instance mind1 in + let ty1,cst1 = constrained_type_of_constructor (cstr,u1) (mind1,mind1.mind_packets.(i)) in + let cst2 = UContext.constraints (Future.force cb2.const_universes) in + let ty2 = cb2.const_type in + let cst = Constraint.union cst (Constraint.union cst1 cst2) in let error = NotConvertibleTypeField (env, ty1, ty2) in - check_conv error cst conv env ty1 ty2 + check_conv error cst infer_conv env ty1 ty2 let rec check_modules cst env msb1 msb2 subst1 subst2 = let mty1 = module_type_of_module msb1 in @@ -368,7 +379,7 @@ and check_modtypes cst env mtb1 mtb2 subst1 subst2 equiv = mtb2.typ_mp list2 mtb1.typ_mp list1 subst2 subst1 mtb2.typ_delta mtb1.typ_delta in - Univ.union_constraints cst1 cst2 + Univ.Constraint.union cst1 cst2 else check_signatures cst env mtb1.typ_mp list1 mtb2.typ_mp list2 subst1 subst2 @@ -398,7 +409,7 @@ and check_modtypes cst env mtb1 mtb2 subst1 subst2 equiv = let check_subtypes env sup super = let env = add_module_type sup.typ_mp sup env in - check_modtypes empty_constraint env + check_modtypes Univ.Constraint.empty env (strengthen sup sup.typ_mp) super empty_subst (map_mp super.typ_mp sup.typ_mp sup.typ_delta) false diff --git a/kernel/term.ml b/kernel/term.ml index 24fe6d962..b85c525d1 100644 --- a/kernel/term.ml +++ b/kernel/term.ml @@ -32,7 +32,6 @@ type types = Constr.t (** Same as [constr], for documentation purposes. *) type existential_key = Constr.existential_key - type existential = Constr.existential type metavariable = Constr.metavariable @@ -54,6 +53,10 @@ type case_info = Constr.case_info = type cast_kind = Constr.cast_kind = VMcast | NATIVEcast | DEFAULTcast | REVERTcast +(********************************************************************) +(* Constructions as implemented *) +(********************************************************************) + type rec_declaration = Constr.rec_declaration type fixpoint = Constr.fixpoint type cofixpoint = Constr.cofixpoint @@ -62,6 +65,12 @@ type ('constr, 'types) prec_declaration = ('constr, 'types) Constr.prec_declaration type ('constr, 'types) pfixpoint = ('constr, 'types) Constr.pfixpoint type ('constr, 'types) pcofixpoint = ('constr, 'types) Constr.pcofixpoint +type 'a puniverses = 'a Univ.puniverses + +(** Simply type aliases *) +type pconstant = constant puniverses +type pinductive = inductive puniverses +type pconstructor = constructor puniverses type ('constr, 'types) kind_of_term = ('constr, 'types) Constr.kind_of_term = | Rel of int @@ -74,12 +83,13 @@ type ('constr, 'types) kind_of_term = ('constr, 'types) Constr.kind_of_term = | Lambda of Name.t * 'types * 'constr | LetIn of Name.t * 'constr * 'types * 'constr | App of 'constr * 'constr array - | Const of constant - | Ind of inductive - | Construct of constructor + | Const of pconstant + | Ind of pinductive + | Construct of pconstructor | Case of case_info * 'constr * 'constr * 'constr array | Fix of ('constr, 'types) pfixpoint | CoFix of ('constr, 'types) pcofixpoint + | Proj of constant * 'constr type values = Constr.values @@ -93,6 +103,8 @@ let type1_sort = Sorts.type1 let sorts_ord = Sorts.compare let is_prop_sort = Sorts.is_prop let family_of_sort = Sorts.family +let univ_of_sort = Sorts.univ_of_sort +let sort_of_univ = Sorts.sort_of_univ (** {6 Term constructors. } *) @@ -110,8 +122,13 @@ let mkLambda = Constr.mkLambda let mkLetIn = Constr.mkLetIn let mkApp = Constr.mkApp let mkConst = Constr.mkConst +let mkProj = Constr.mkProj let mkInd = Constr.mkInd let mkConstruct = Constr.mkConstruct +let mkConstU = Constr.mkConstU +let mkIndU = Constr.mkIndU +let mkConstructU = Constr.mkConstructU +let mkConstructUi = Constr.mkConstructUi let mkCase = Constr.mkCase let mkFix = Constr.mkFix let mkCoFix = Constr.mkCoFix @@ -121,9 +138,16 @@ let mkCoFix = Constr.mkCoFix (**********************************************************************) let eq_constr = Constr.equal +let eq_constr_univs = Constr.eq_constr_univs +let leq_constr_univs = Constr.leq_constr_univs +let eq_constr_universes = Constr.eq_constr_universes +let leq_constr_universes = Constr.leq_constr_universes +let eq_constr_nounivs = Constr.eq_constr_nounivs + let kind_of_term = Constr.kind let constr_ord = Constr.compare let fold_constr = Constr.fold +let map_puniverses = Constr.map_puniverses let map_constr = Constr.map let map_constr_with_binders = Constr.map_with_binders let iter_constr = Constr.iter @@ -195,9 +219,7 @@ let rec is_Type c = match kind_of_term c with | Cast (c,_,_) -> is_Type c | _ -> false -let is_small = function - | Prop _ -> true - | _ -> false +let is_small = Sorts.is_small let iskind c = isprop c || is_Type c @@ -649,6 +671,7 @@ let kind_of_type t = match kind_of_term t with | Prod (na,t,c) -> ProdType (na, t, c) | LetIn (na,b,t,c) -> LetInType (na, b, t, c) | App (c,l) -> AtomicType (c, l) - | (Rel _ | Meta _ | Var _ | Evar _ | Const _ | Case _ | Fix _ | CoFix _ | Ind _) + | (Rel _ | Meta _ | Var _ | Evar _ | Const _ + | Proj _ | Case _ | Fix _ | CoFix _ | Ind _) -> AtomicType (t,[||]) | (Lambda _ | Construct _) -> failwith "Not a type" diff --git a/kernel/term.mli b/kernel/term.mli index f2f5e8495..2d3df6e1e 100644 --- a/kernel/term.mli +++ b/kernel/term.mli @@ -24,6 +24,13 @@ type sorts = Sorts.t = type sorts_family = Sorts.family = InProp | InSet | InType +type 'a puniverses = 'a Univ.puniverses + +(** Simply type aliases *) +type pconstant = constant puniverses +type pinductive = inductive puniverses +type pconstructor = constructor puniverses + type constr = Constr.constr (** Alias types, for compatibility. *) @@ -73,12 +80,13 @@ type ('constr, 'types) kind_of_term = ('constr, 'types) Constr.kind_of_term = | Lambda of Name.t * 'types * 'constr | LetIn of Name.t * 'constr * 'types * 'constr | App of 'constr * 'constr array - | Const of constant - | Ind of inductive - | Construct of constructor + | Const of constant puniverses + | Ind of inductive puniverses + | Construct of constructor puniverses | Case of case_info * 'constr * 'constr * 'constr array | Fix of ('constr, 'types) pfixpoint | CoFix of ('constr, 'types) pcofixpoint + | Proj of constant * 'constr type values = Constr.values @@ -157,16 +165,16 @@ val decompose_app : constr -> constr * constr list val decompose_appvect : constr -> constr * constr array (** Destructs a constant *) -val destConst : constr -> constant +val destConst : constr -> constant puniverses (** Destructs an existential variable *) val destEvar : constr -> existential (** Destructs a (co)inductive type *) -val destInd : constr -> inductive +val destInd : constr -> inductive puniverses (** Destructs a constructor *) -val destConstruct : constr -> constructor +val destConstruct : constr -> constructor puniverses (** Destructs a [match c as x in I args return P with ... | Ci(...yij...) => ti | ... end] (or [let (..y1i..) := c as x in I args @@ -397,8 +405,13 @@ val mkLambda : Name.t * types * constr -> constr val mkLetIn : Name.t * constr * types * constr -> constr val mkApp : constr * constr array -> constr val mkConst : constant -> constr +val mkProj : (constant * constr) -> constr val mkInd : inductive -> constr val mkConstruct : constructor -> constr +val mkConstU : constant puniverses -> constr +val mkIndU : inductive puniverses -> constr +val mkConstructU : constructor puniverses -> constr +val mkConstructUi : (pinductive * int) -> constr val mkCase : case_info * constr * constr * constr array -> constr val mkFix : fixpoint -> constr val mkCoFix : cofixpoint -> constr @@ -408,6 +421,26 @@ val mkCoFix : cofixpoint -> constr val eq_constr : constr -> constr -> bool (** Alias for [Constr.equal] *) +(** [eq_constr_univs a b] [true, c] if [a] equals [b] modulo alpha, casts, + application grouping and the universe equalities in [c]. *) +val eq_constr_univs : constr Univ.check_function + +(** [leq_constr_univs a b] [true, c] if [a] is convertible to [b] modulo + alpha, casts, application grouping and the universe inequalities in [c]. *) +val leq_constr_univs : constr Univ.check_function + +(** [eq_constr_universes a b] [true, c] if [a] equals [b] modulo alpha, casts, + application grouping and the universe equalities in [c]. *) +val eq_constr_universes : constr -> constr -> bool Univ.universe_constrained + +(** [leq_constr_universes a b] [true, c] if [a] is convertible to [b] modulo + alpha, casts, application grouping and the universe inequalities in [c]. *) +val leq_constr_universes : constr -> constr -> bool Univ.universe_constrained + +(** [eq_constr_univs a b] [true, c] if [a] equals [b] modulo alpha, casts, + application grouping and ignoring universe instances. *) +val eq_constr_nounivs : constr -> constr -> bool + val kind_of_term : constr -> (constr, types) kind_of_term (** Alias for [Constr.kind] *) @@ -424,6 +457,10 @@ val map_constr_with_binders : ('a -> 'a) -> ('a -> constr -> constr) -> 'a -> constr -> constr (** Alias for [Constr.map_with_binders] *) +val map_puniverses : ('a -> 'b) -> 'a puniverses -> 'b puniverses +val univ_of_sort : sorts -> Univ.universe +val sort_of_univ : Univ.universe -> sorts + val iter_constr : (constr -> unit) -> constr -> unit (** Alias for [Constr.iter] *) @@ -437,6 +474,8 @@ val compare_constr : (constr -> constr -> bool) -> constr -> constr -> bool val hash_constr : constr -> int (** Alias for [Constr.hash] *) +(*********************************************************************) + val hcons_sorts : sorts -> sorts (** Alias for [Constr.hashcons_sorts] *) diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index a084504dc..9aa688fc7 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -22,29 +22,35 @@ open Declarations open Environ open Entries open Typeops +open Fast_typeops -let constrain_type env j cst1 = function - | `None -> - make_polymorphic_if_constant_for_ind env j, cst1 +let debug = false +let prerr_endline = + if debug then prerr_endline else fun _ -> () + +let constrain_type env j poly = function + | `None -> j.uj_type | `Some t -> - let (tj,cst2) = infer_type env t in - let (_,cst3) = judge_of_cast env j DEFAULTcast tj in - assert (eq_constr t tj.utj_val); - let cstrs = union_constraints (union_constraints cst1 cst2) cst3 in - NonPolymorphicType t, cstrs - | `SomeWJ (t, tj, cst2) -> - let (_,cst3) = judge_of_cast env j DEFAULTcast tj in - assert (eq_constr t tj.utj_val); - let cstrs = union_constraints (union_constraints cst1 cst2) cst3 in - NonPolymorphicType t, cstrs + let tj = infer_type env t in + let _ = judge_of_cast env j DEFAULTcast tj in + assert (eq_constr t tj.utj_val); + t + | `SomeWJ (t, tj) -> + let tj = infer_type env t in + let _ = judge_of_cast env j DEFAULTcast tj in + assert (eq_constr t tj.utj_val); + t let map_option_typ = function None -> `None | Some x -> `Some x -let translate_local_assum env t = - let (j,cst) = infer env t in - let t = Typeops.assumption_of_judgment env j in - (t,cst) - +let local_constrain_type env j = function + | None -> + j.uj_type + | Some t -> + let tj = infer_type env t in + let _ = judge_of_cast env j DEFAULTcast tj in + assert (eq_constr t tj.utj_val); + t (* Insertion of constants and parameters in environment. *) @@ -59,19 +65,19 @@ let handle_side_effects env body side_eff = if name.[i] == '.' || name.[i] == '#' then name.[i] <- '_' done; Name (id_of_string name) in let rec sub c i x = match kind_of_term x with - | Const c' when eq_constant c c' -> mkRel i + | Const (c', _) when eq_constant c c' -> mkRel i | _ -> map_constr_with_binders ((+) 1) (fun i x -> sub c i x) i x in let fix_body (c,cb) t = match cb.const_body with | Undef _ -> assert false | Def b -> let b = Mod_subst.force_constr b in - let b_ty = Typeops.type_of_constant_type env cb.const_type in + let b_ty = cb.const_type in let t = sub c 1 (Vars.lift 1 t) in mkLetIn (cname c, b, b_ty, t) | OpaqueDef b -> let b = Opaqueproof.force_proof b in - let b_ty = Typeops.type_of_constant_type env cb.const_type in + let b_ty = cb.const_type in let t = sub c 1 (Vars.lift 1 t) in mkApp (mkLambda (cname c, b_ty, t), [|b|]) in List.fold_right fix_body cbl t @@ -86,46 +92,50 @@ let hcons_j j = let feedback_completion_typecheck = Option.iter (fun state_id -> Pp.feedback ~state_id Interface.Complete) -let infer_declaration env dcl = +let infer_declaration env kn dcl = match dcl with - | ParameterEntry (ctx,t,nl) -> - let j, cst = infer env t in + | ParameterEntry (ctx,poly,(t,uctx),nl) -> + let env = push_context uctx env in + let j = infer env t in let t = hcons_constr (Typeops.assumption_of_judgment env j) in - Undef nl, NonPolymorphicType t, cst, false, ctx + Undef nl, t, None, poly, Future.from_val uctx, false, ctx | DefinitionEntry ({ const_entry_type = Some typ; const_entry_opaque = true } as c) -> + let env = push_context c.const_entry_universes env in let { const_entry_body = body; const_entry_feedback = feedback_id } = c in - let tyj, tycst = infer_type env typ in + let tyj = infer_type env typ in let proofterm = Future.chain ~greedy:true ~pure:true body (fun (body, side_eff) -> let body = handle_side_effects env body side_eff in - let j, cst = infer env body in + let j = infer env body in let j = hcons_j j in - let _typ, cst = constrain_type env j cst (`SomeWJ (typ,tyj,tycst)) in + let _typ = constrain_type env j c.const_entry_polymorphic (`SomeWJ (typ,tyj)) in feedback_completion_typecheck feedback_id; - j.uj_val, cst) in + j.uj_val, Univ.empty_constraint) in let def = OpaqueDef (Opaqueproof.create proofterm) in - let typ = NonPolymorphicType typ in - def, typ, tycst, c.const_entry_inline_code, c.const_entry_secctx + def, typ, None, c.const_entry_polymorphic, Future.from_val c.const_entry_universes, + c.const_entry_inline_code, c.const_entry_secctx | DefinitionEntry c -> + let env = push_context c.const_entry_universes env in let { const_entry_type = typ; const_entry_opaque = opaque } = c in let { const_entry_body = body; const_entry_feedback = feedback_id } = c in let body, side_eff = Future.join body in let body = handle_side_effects env body side_eff in - let j, cst = infer env body in + let j = infer env body in let j = hcons_j j in - let typ, cst = constrain_type env j cst (map_option_typ typ) in + let typ = constrain_type env j c.const_entry_polymorphic (map_option_typ typ) in feedback_completion_typecheck feedback_id; let def = Def (Mod_subst.from_val j.uj_val) in - def, typ, cst, c.const_entry_inline_code, c.const_entry_secctx + def, typ, None, c.const_entry_polymorphic, + Future.from_val c.const_entry_universes, c.const_entry_inline_code, c.const_entry_secctx -let global_vars_set_constant_type env = function - | NonPolymorphicType t -> global_vars_set env t - | PolymorphicArity (ctx,_) -> - Context.fold_rel_context - (fold_rel_declaration - (fun t c -> Id.Set.union (global_vars_set env t) c)) - ctx ~init:Id.Set.empty +(* let global_vars_set_constant_type env = function *) +(* | NonPolymorphicType t -> global_vars_set env t *) +(* | PolymorphicArity (ctx,_) -> *) +(* Context.fold_rel_context *) +(* (fold_rel_declaration *) +(* (fun t c -> Id.Set.union (global_vars_set env t) c)) *) +(* ctx ~init:Id.Set.empty *) let record_aux env s1 s2 = let v = @@ -137,7 +147,7 @@ let record_aux env s1 s2 = let suggest_proof_using = ref (fun _ _ _ _ _ -> ()) let set_suggest_proof_using f = suggest_proof_using := f -let build_constant_declaration kn env (def,typ,cst,inline_code,ctx) = +let build_constant_declaration kn env (def,typ,proj,poly,univs,inline_code,ctx) = let check declared inferred = let mk_set l = List.fold_right Id.Set.add (List.map pi1 l) Id.Set.empty in let inferred_set, declared_set = mk_set inferred, mk_set declared in @@ -152,12 +162,14 @@ let build_constant_declaration kn env (def,typ,cst,inline_code,ctx) = | None when not (List.is_empty context_ids) -> (* No declared section vars, and non-empty section context: we must look at the body NOW, if any *) - let ids_typ = global_vars_set_constant_type env typ in + let ids_typ = global_vars_set env typ in let ids_def = match def with | Undef _ -> Idset.empty | Def cs -> global_vars_set env (Mod_subst.force_constr cs) | OpaqueDef lc -> let vars = global_vars_set env (Opaqueproof.force_proof lc) in + (* we force so that cst are added to the env immediately after *) + ignore(Future.join univs); !suggest_proof_using kn env vars ids_typ context_ids; if !Flags.compilation_mode = Flags.BuildVo then record_aux env ids_typ vars; @@ -174,38 +186,50 @@ let build_constant_declaration kn env (def,typ,cst,inline_code,ctx) = match def with | Undef _ as x -> x (* nothing to check *) | Def cs as x -> - let ids_typ = global_vars_set_constant_type env typ in + let ids_typ = global_vars_set env typ in let ids_def = global_vars_set env (Mod_subst.force_constr cs) in let inferred = keep_hyps env (Idset.union ids_typ ids_def) in check declared inferred; x | OpaqueDef lc -> (* In this case we can postpone the check *) OpaqueDef (Opaqueproof.iter_direct_opaque (fun c -> - let ids_typ = global_vars_set_constant_type env typ in + let ids_typ = global_vars_set env typ in let ids_def = global_vars_set env c in let inferred = keep_hyps env (Idset.union ids_typ ids_def) in check declared inferred) lc) in + let tps = + match proj with + | None -> Cemitcodes.from_val (compile_constant_body env def) + | Some pb -> + Cemitcodes.from_val (compile_constant_body env (Def (Mod_subst.from_val pb.proj_body))) + in { const_hyps = hyps; const_body = def; const_type = typ; - const_body_code = Cemitcodes.from_val (compile_constant_body env def); - const_constraints = cst; + const_proj = proj; + const_body_code = tps; + const_polymorphic = poly; + const_universes = univs; const_inline_code = inline_code } + (*s Global and local constant declaration. *) let translate_constant env kn ce = - build_constant_declaration kn env (infer_declaration env ce) + build_constant_declaration kn env (infer_declaration env (Some kn) ce) + +let translate_local_assum env t = + let j = infer env t in + let t = Typeops.assumption_of_judgment env j in + t let translate_recipe env kn r = - let def,typ,cst,inline_code,hyps = Cooking.cook_constant env r in - build_constant_declaration kn env (def,typ,cst,inline_code,hyps) + build_constant_declaration kn env (Cooking.cook_constant env r) let translate_local_def env id centry = - let def,typ,cst,inline_code,ctx = - infer_declaration env (DefinitionEntry centry) in - let typ = type_of_constant_type env typ in - def, typ, cst + let def,typ,proj,poly,univs,inline_code,ctx = + infer_declaration env None (DefinitionEntry centry) in + def, typ, univs (* Insertion of inductive types. *) diff --git a/kernel/term_typing.mli b/kernel/term_typing.mli index b1c336ad9..a2a35492e 100644 --- a/kernel/term_typing.mli +++ b/kernel/term_typing.mli @@ -14,9 +14,9 @@ open Declarations open Entries val translate_local_def : env -> Id.t -> definition_entry -> - constant_def * types * Univ.constraints + constant_def * types * constant_universes -val translate_local_assum : env -> types -> types * constraints +val translate_local_assum : env -> types -> types (* returns the same definition_entry but with side effects turned into * let-ins or beta redexes. it is meant to get a term out of a not yet @@ -32,7 +32,9 @@ val translate_recipe : env -> constant -> Cooking.recipe -> constant_body (** Internal functions, mentioned here for debug purpose only *) -val infer_declaration : env -> constant_entry -> Cooking.result +val infer_declaration : env -> constant option -> + constant_entry -> Cooking.result + val build_constant_declaration : constant -> env -> Cooking.result -> constant_body diff --git a/kernel/type_errors.ml b/kernel/type_errors.ml index 42b93dd37..30dcbafe6 100644 --- a/kernel/type_errors.ml +++ b/kernel/type_errors.ml @@ -42,12 +42,12 @@ type type_error = | NotAType of unsafe_judgment | BadAssumption of unsafe_judgment | ReferenceVariables of identifier * constr - | ElimArity of inductive * sorts_family list * constr * unsafe_judgment + | ElimArity of pinductive * sorts_family list * constr * unsafe_judgment * (sorts_family * sorts_family * arity_error) option | CaseNotInductive of unsafe_judgment - | WrongCaseInfo of inductive * case_info + | WrongCaseInfo of pinductive * case_info | NumberBranches of unsafe_judgment * int - | IllFormedBranch of constr * constructor * constr * constr + | IllFormedBranch of constr * pconstructor * constr * constr | Generalization of (Name.t * types) * unsafe_judgment | ActualType of unsafe_judgment * types | CantApplyBadType of @@ -56,11 +56,12 @@ type type_error = | IllFormedRecBody of guard_error * Name.t array * int * env * unsafe_judgment array | IllTypedRecBody of int * Name.t array * unsafe_judgment array * types array + | UnsatisfiedConstraints of Univ.constraints exception TypeError of env * type_error -let nfj {uj_val=c;uj_type=ct} = - {uj_val=c;uj_type=nf_betaiota ct} +let nfj env {uj_val=c;uj_type=ct} = + {uj_val=c;uj_type=nf_betaiota env ct} let error_unbound_rel env n = raise (TypeError (env, UnboundRel n)) @@ -84,11 +85,11 @@ let error_case_not_inductive env j = raise (TypeError (env, CaseNotInductive j)) let error_number_branches env cj expn = - raise (TypeError (env, NumberBranches (nfj cj,expn))) + raise (TypeError (env, NumberBranches (nfj env cj,expn))) let error_ill_formed_branch env c i actty expty = raise (TypeError (env, - IllFormedBranch (c,i,nf_betaiota actty, nf_betaiota expty))) + IllFormedBranch (c,i,nf_betaiota env actty, nf_betaiota env expty))) let error_generalization env nvar c = raise (TypeError (env, Generalization (nvar,c))) @@ -114,3 +115,5 @@ let error_elim_explain kp ki = | InType, InSet -> StrongEliminationOnNonSmallType (* if Set impredicative *) | _ -> WrongArity +let error_unsatisfied_constraints env c = + raise (TypeError (env, UnsatisfiedConstraints c)) diff --git a/kernel/type_errors.mli b/kernel/type_errors.mli index b9d8efbcd..09310b42b 100644 --- a/kernel/type_errors.mli +++ b/kernel/type_errors.mli @@ -43,12 +43,12 @@ type type_error = | NotAType of unsafe_judgment | BadAssumption of unsafe_judgment | ReferenceVariables of identifier * constr - | ElimArity of inductive * sorts_family list * constr * unsafe_judgment + | ElimArity of pinductive * sorts_family list * constr * unsafe_judgment * (sorts_family * sorts_family * arity_error) option | CaseNotInductive of unsafe_judgment - | WrongCaseInfo of inductive * case_info + | WrongCaseInfo of pinductive * case_info | NumberBranches of unsafe_judgment * int - | IllFormedBranch of constr * constructor * constr * constr + | IllFormedBranch of constr * pconstructor * constr * constr | Generalization of (Name.t * types) * unsafe_judgment | ActualType of unsafe_judgment * types | CantApplyBadType of @@ -57,6 +57,7 @@ type type_error = | IllFormedRecBody of guard_error * Name.t array * int * env * unsafe_judgment array | IllTypedRecBody of int * Name.t array * unsafe_judgment array * types array + | UnsatisfiedConstraints of Univ.constraints exception TypeError of env * type_error @@ -71,14 +72,14 @@ val error_assumption : env -> unsafe_judgment -> 'a val error_reference_variables : env -> identifier -> constr -> 'a val error_elim_arity : - env -> inductive -> sorts_family list -> constr -> unsafe_judgment -> + env -> pinductive -> sorts_family list -> constr -> unsafe_judgment -> (sorts_family * sorts_family * arity_error) option -> 'a val error_case_not_inductive : env -> unsafe_judgment -> 'a val error_number_branches : env -> unsafe_judgment -> int -> 'a -val error_ill_formed_branch : env -> constr -> constructor -> constr -> constr -> 'a +val error_ill_formed_branch : env -> constr -> pconstructor -> constr -> constr -> 'a val error_generalization : env -> Name.t * types -> unsafe_judgment -> 'a @@ -98,3 +99,5 @@ val error_ill_typed_rec_body : env -> int -> Name.t array -> unsafe_judgment array -> types array -> 'a val error_elim_explain : sorts_family -> sorts_family -> arity_error + +val error_unsatisfied_constraints : env -> Univ.constraints -> 'a diff --git a/kernel/typeops.ml b/kernel/typeops.ml index 3400d8ce6..09fd4cc7f 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -20,19 +20,21 @@ open Reduction open Inductive open Type_errors -let conv_leq l2r = default_conv CUMUL ~l2r +let conv_leq l2r env x y = default_conv CUMUL ~l2r env x y let conv_leq_vecti env v1 v2 = Array.fold_left2_i - (fun i c t1 t2 -> - let c' = - try default_conv CUMUL env t1 t2 - with NotConvertible -> raise (NotConvertibleVect i) in - union_constraints c c') - empty_constraint + (fun i _ t1 t2 -> + try conv_leq false env t1 t2 + with NotConvertible -> raise (NotConvertibleVect i)) + () v1 v2 +let check_constraints cst env = + if Environ.check_constraints cst env then () + else error_unsatisfied_constraints env cst + (* This should be a type (a priori without intension to be an assumption) *) let type_judgment env j = match kind_of_term(whd_betadeltaiota env j.uj_type) with @@ -69,9 +71,9 @@ let judge_of_prop_contents = function (* Type of Type(i). *) let judge_of_type u = - let uu = super u in - { uj_val = mkType u; - uj_type = mkType uu } + let uu = Universe.super u in + { uj_val = mkType u; + uj_type = mkType uu } (*s Type of a de Bruijn index. *) @@ -111,53 +113,32 @@ let check_hyps_inclusion env c sign = (* Make a type polymorphic if an arity *) -let extract_level env p = - let _,c = dest_prod_assum env p in - match kind_of_term c with Sort (Type u) -> Some u | _ -> None - -let extract_context_levels env l = - let fold l (_, b, p) = match b with - | None -> extract_level env p :: l - | _ -> l - in - List.fold_left fold [] l - -let make_polymorphic_if_constant_for_ind env {uj_val = c; uj_type = t} = - let params, ccl = dest_prod_assum env t in - match kind_of_term ccl with - | Sort (Type u) when isInd (fst (decompose_app (whd_betadeltaiota env c))) -> - let param_ccls = extract_context_levels env params in - let s = { poly_param_levels = param_ccls; poly_level = u} in - PolymorphicArity (params,s) - | _ -> - NonPolymorphicType t - (* Type of constants *) -let type_of_constant_knowing_parameters env t paramtyps = - match t with - | NonPolymorphicType t -> t - | PolymorphicArity (sign,ar) -> - let ctx = List.rev sign in - let ctx,s = instantiate_universes env ctx ar paramtyps in - mkArity (List.rev ctx,s) - -let type_of_constant_type env t = - type_of_constant_knowing_parameters env t [||] +let type_of_constant env cst = constant_type env cst +let type_of_constant_in env cst = constant_type_in env cst +let type_of_constant_knowing_parameters env t _ = t +let type_of_constant_type env cst = cst -let type_of_constant env cst = - type_of_constant_type env (constant_type env cst) +let judge_of_constant env (kn,u as cst) = + let c = mkConstU cst in + let cb = lookup_constant kn env in + let _ = check_hyps_inclusion env c cb.const_hyps in + let ty, cu = type_of_constant env cst in + let _ = Environ.check_constraints cu env in + (make_judge c ty) -let judge_of_constant_knowing_parameters env cst jl = - let c = mkConst cst in +let type_of_projection env (cst,u) = let cb = lookup_constant cst env in - let _ = check_hyps_inclusion env c cb.const_hyps in - let paramstyp = Array.map (fun j -> lazy j.uj_type) jl in - let t = type_of_constant_knowing_parameters env cb.const_type paramstyp in - make_judge c t + match cb.const_proj with + | Some pb -> + if cb.const_polymorphic then + let mib,_ = lookup_mind_specif env (pb.proj_ind,0) in + let subst = make_inductive_subst mib u in + Vars.subst_univs_constr subst pb.proj_type + else pb.proj_type + | None -> raise (Invalid_argument "type_of_projection: not a projection") -let judge_of_constant env cst = - judge_of_constant_knowing_parameters env cst [||] (* Type of a lambda-abstraction. *) @@ -184,26 +165,27 @@ let judge_of_letin env name defj typj j = (* Type of an application. *) let judge_of_apply env funj argjv = - let len = Array.length argjv in - let rec apply_rec n typ cst = - if len <= n then - { uj_val = mkApp (j_val funj, Array.map j_val argjv); uj_type = typ }, - cst - else - let hj = Array.unsafe_get argjv n in - match kind_of_term (whd_betadeltaiota env typ) with - | Prod (_,c1,c2) -> - let c = - try conv_leq false env hj.uj_type c1 - with NotConvertible -> - error_cant_apply_bad_type env (n + 1, c1, hj.uj_type) funj argjv - in - let cst' = union_constraints cst c in - apply_rec (n+1) (subst1 hj.uj_val c2) cst' - | _ -> - error_cant_apply_not_functional env funj argjv + let rec apply_rec n typ = function + | [] -> + { uj_val = mkApp (j_val funj, Array.map j_val argjv); + uj_type = typ } + | hj::restjl -> + (match kind_of_term (whd_betadeltaiota env typ) with + | Prod (_,c1,c2) -> + (try + let () = conv_leq false env hj.uj_type c1 in + apply_rec (n+1) (subst1 hj.uj_val c2) restjl + with NotConvertible -> + error_cant_apply_bad_type env + (n,c1, hj.uj_type) + funj argjv) + + | _ -> + error_cant_apply_not_functional env funj argjv) in - apply_rec 0 funj.uj_type empty_constraint + apply_rec 1 + funj.uj_type + (Array.to_list argjv) (* Type of product *) @@ -221,14 +203,14 @@ let sort_of_product env domsort rangsort = rangsort | _ -> (* Rule is (Type_i,Set,Type_i) in the Set-predicative calculus *) - Type (sup u1 type0_univ) + Type (Universe.sup Universe.type0 u1) end (* Product rule (Prop,Type_i,Type_i) *) - | (Prop Pos, Type u2) -> Type (sup type0_univ u2) + | (Prop Pos, Type u2) -> Type (Universe.sup Universe.type0 u2) (* Product rule (Prop,Type_i,Type_i) *) | (Prop Null, Type _) -> rangsort (* Product rule (Type_i,Type_i,Type_i) *) - | (Type u1, Type u2) -> Type (sup u1 u2) + | (Type u1, Type u2) -> Type (Universe.sup u1 u2) (* [judge_of_product env name (typ1,s1) (typ2,s2)] implements the rule @@ -262,18 +244,17 @@ let judge_of_cast env cj k tj = vm_conv CUMUL env cj.uj_type expected_type | DEFAULTcast -> mkCast (cj.uj_val, k, expected_type), - conv_leq false env cj.uj_type expected_type + default_conv ~l2r:false CUMUL env cj.uj_type expected_type | REVERTcast -> cj.uj_val, - conv_leq true env cj.uj_type expected_type + default_conv ~l2r:true CUMUL env cj.uj_type expected_type | NATIVEcast -> let sigma = Nativelambda.empty_evars in mkCast (cj.uj_val, k, expected_type), native_conv CUMUL sigma env cj.uj_type expected_type in - { uj_val = c; - uj_type = expected_type }, - cst + { uj_val = c; + uj_type = expected_type } with NotConvertible -> error_actual_type env cj expected_type @@ -291,50 +272,70 @@ let judge_of_cast env cj k tj = the App case of execute; from this constraints, the expected dynamic constraints of the form u<=v are enforced *) -let judge_of_inductive_knowing_parameters env ind jl = - let c = mkInd ind in +(* let judge_of_inductive_knowing_parameters env ind jl = *) +(* let c = mkInd ind in *) +(* let (mib,mip) = lookup_mind_specif env ind in *) +(* check_args env c mib.mind_hyps; *) +(* let paramstyp = Array.map (fun j -> j.uj_type) jl in *) +(* let t = in *) +(* make_judge c t *) + +let judge_of_inductive env (ind,u as indu) = + let c = mkIndU indu in let (mib,mip) = lookup_mind_specif env ind in check_hyps_inclusion env c mib.mind_hyps; - let paramstyp = Array.map (fun j -> lazy j.uj_type) jl in - let t = Inductive.type_of_inductive_knowing_parameters env mip paramstyp in - make_judge c t - -let judge_of_inductive env ind = - judge_of_inductive_knowing_parameters env ind [||] + let t,cst = Inductive.constrained_type_of_inductive env ((mib,mip),u) in + check_constraints cst env; + (make_judge c t) (* Constructors. *) -let judge_of_constructor env c = - let constr = mkConstruct c in +let judge_of_constructor env (c,u as cu) = + let constr = mkConstructU cu in let _ = let ((kn,_),_) = c in let mib = lookup_mind kn env in check_hyps_inclusion env constr mib.mind_hyps in let specif = lookup_mind_specif env (inductive_of_constructor c) in - make_judge constr (type_of_constructor c specif) + let t,cst = constrained_type_of_constructor cu specif in + let () = check_constraints cst env in + (make_judge constr t) (* Case. *) -let check_branch_types env ind cj (lfj,explft) = +let check_branch_types env (ind,u) cj (lfj,explft) = try conv_leq_vecti env (Array.map j_type lfj) explft with NotConvertibleVect i -> - error_ill_formed_branch env cj.uj_val (ind,i+1) lfj.(i).uj_type explft.(i) + error_ill_formed_branch env cj.uj_val ((ind,i+1),u) lfj.(i).uj_type explft.(i) | Invalid_argument _ -> error_number_branches env cj (Array.length explft) let judge_of_case env ci pj cj lfj = - let indspec = + let (pind, _ as indspec) = try find_rectype env cj.uj_type with Not_found -> error_case_not_inductive env cj in - let _ = check_case_info env (fst indspec) ci in - let (bty,rslty,univ) = + let _ = check_case_info env pind ci in + let (bty,rslty) = type_case_branches env indspec pj cj.uj_val in - let univ' = check_branch_types env (fst indspec) cj (lfj,bty) in + let () = check_branch_types env pind cj (lfj,bty) in ({ uj_val = mkCase (ci, (*nf_betaiota*) pj.uj_val, cj.uj_val, Array.map j_val lfj); - uj_type = rslty }, - union_constraints univ univ') + uj_type = rslty }) + +let judge_of_projection env p cj = + let pb = lookup_projection p env in + let (ind,u), args = + try find_rectype env cj.uj_type + with Not_found -> error_case_not_inductive env cj + in + assert(eq_mind pb.proj_ind (fst ind)); + let usubst = make_inductive_subst (fst (lookup_mind_specif env ind)) u in + let ty = Vars.subst_univs_constr usubst pb.Declarations.proj_type in + let ty = substl (cj.uj_val :: List.rev args) ty in + (* TODO: Universe polymorphism for projections *) + {uj_val = mkProj (p,cj.uj_val); + uj_type = ty} (* Fixpoints. *) @@ -352,104 +353,88 @@ let type_fixpoint env lna lar vdefj = (************************************************************************) (************************************************************************) -(* This combinator adds the universe constraints both in the local - graph and in the universes of the environment. This is to ensure - that the infered local graph is satisfiable. *) -let univ_combinator (cst,univ) (j,c') = - (j,(union_constraints cst c', merge_constraints c' univ)) - (* The typing machine. *) (* ATTENTION : faudra faire le typage du contexte des Const, Ind et Constructsi un jour cela devient des constructions arbitraires et non plus des variables *) -let rec execute env cstr cu = +let rec execute env cstr = match kind_of_term cstr with (* Atomic terms *) | Sort (Prop c) -> - (judge_of_prop_contents c, cu) - + judge_of_prop_contents c + | Sort (Type u) -> - (judge_of_type u, cu) + judge_of_type u | Rel n -> - (judge_of_relative env n, cu) + judge_of_relative env n | Var id -> - (judge_of_variable env id, cu) + judge_of_variable env id | Const c -> - (judge_of_constant env c, cu) + judge_of_constant env c + + | Proj (p, c) -> + let cj = execute env c in + judge_of_projection env p cj (* Lambda calculus operators *) | App (f,args) -> - let (jl,cu1) = execute_array env args cu in - let (j,cu2) = - match kind_of_term f with - | Ind ind -> - (* Sort-polymorphism of inductive types *) - judge_of_inductive_knowing_parameters env ind jl, cu1 - | Const cst -> - (* Sort-polymorphism of constant *) - judge_of_constant_knowing_parameters env cst jl, cu1 - | _ -> - (* No sort-polymorphism *) - execute env f cu1 - in - univ_combinator cu2 (judge_of_apply env j jl) + let jl = execute_array env args in + let j = execute env f in + judge_of_apply env j jl | Lambda (name,c1,c2) -> - let (varj,cu1) = execute_type env c1 cu in - let env1 = push_rel (name,None,varj.utj_val) env in - let (j',cu2) = execute env1 c2 cu1 in - (judge_of_abstraction env name varj j', cu2) + let varj = execute_type env c1 in + let env1 = push_rel (name,None,varj.utj_val) env in + let j' = execute env1 c2 in + judge_of_abstraction env name varj j' | Prod (name,c1,c2) -> - let (varj,cu1) = execute_type env c1 cu in - let env1 = push_rel (name,None,varj.utj_val) env in - let (varj',cu2) = execute_type env1 c2 cu1 in - (judge_of_product env name varj varj', cu2) + let varj = execute_type env c1 in + let env1 = push_rel (name,None,varj.utj_val) env in + let varj' = execute_type env1 c2 in + judge_of_product env name varj varj' | LetIn (name,c1,c2,c3) -> - let (j1,cu1) = execute env c1 cu in - let (j2,cu2) = execute_type env c2 cu1 in - let (_,cu3) = - univ_combinator cu2 (judge_of_cast env j1 DEFAULTcast j2) in - let env1 = push_rel (name,Some j1.uj_val,j2.utj_val) env in - let (j',cu4) = execute env1 c3 cu3 in - (judge_of_letin env name j1 j2 j', cu4) + let j1 = execute env c1 in + let j2 = execute_type env c2 in + let _ = judge_of_cast env j1 DEFAULTcast j2 in + let env1 = push_rel (name,Some j1.uj_val,j2.utj_val) env in + let j' = execute env1 c3 in + judge_of_letin env name j1 j2 j' | Cast (c,k, t) -> - let (cj,cu1) = execute env c cu in - let (tj,cu2) = execute_type env t cu1 in - univ_combinator cu2 - (judge_of_cast env cj k tj) + let cj = execute env c in + let tj = execute_type env t in + judge_of_cast env cj k tj (* Inductive types *) | Ind ind -> - (judge_of_inductive env ind, cu) + judge_of_inductive env ind | Construct c -> - (judge_of_constructor env c, cu) + judge_of_constructor env c | Case (ci,p,c,lf) -> - let (cj,cu1) = execute env c cu in - let (pj,cu2) = execute env p cu1 in - let (lfj,cu3) = execute_array env lf cu2 in - univ_combinator cu3 - (judge_of_case env ci pj cj lfj) + let cj = execute env c in + let pj = execute env p in + let lfj = execute_array env lf in + judge_of_case env ci pj cj lfj | Fix ((vn,i as vni),recdef) -> - let ((fix_ty,recdef'),cu1) = execute_recdef env recdef i cu in - let fix = (vni,recdef') in + let (fix_ty,recdef') = execute_recdef env recdef i in + let fix = (vni,recdef') in check_fix env fix; - (make_judge (mkFix fix) fix_ty, cu1) - + make_judge (mkFix fix) fix_ty + | CoFix (i,recdef) -> - let ((fix_ty,recdef'),cu1) = execute_recdef env recdef i cu in - let cofix = (i,recdef') in + let (fix_ty,recdef') = execute_recdef env recdef i in + let cofix = (i,recdef') in check_cofix env cofix; - (make_judge (mkCoFix cofix) fix_ty, cu1) - + (make_judge (mkCoFix cofix) fix_ty) + (* Partial proofs: unsupported by the kernel *) | Meta _ -> anomaly (Pp.str "the kernel does not support metavariables") @@ -457,61 +442,53 @@ let rec execute env cstr cu = | Evar _ -> anomaly (Pp.str "the kernel does not support existential variables") -and execute_type env constr cu = - let (j,cu1) = execute env constr cu in - (type_judgment env j, cu1) +and execute_type env constr = + let j = execute env constr in + type_judgment env j -and execute_recdef env (names,lar,vdef) i cu = - let (larj,cu1) = execute_array env lar cu in +and execute_recdef env (names,lar,vdef) i = + let larj = execute_array env lar in let lara = Array.map (assumption_of_judgment env) larj in let env1 = push_rec_types (names,lara,vdef) env in - let (vdefj,cu2) = execute_array env1 vdef cu1 in + let vdefj = execute_array env1 vdef in let vdefv = Array.map j_val vdefj in - let cst = type_fixpoint env1 names lara vdefj in - univ_combinator cu2 - ((lara.(i),(names,lara,vdefv)),cst) + let () = type_fixpoint env1 names lara vdefj in + (lara.(i),(names,lara,vdefv)) -and execute_array env = Array.fold_map' (execute env) +and execute_array env = Array.map (execute env) (* Derived functions *) let infer env constr = - let (j,(cst,_)) = - execute env constr (empty_constraint, universes env) in - assert (eq_constr j.uj_val constr); - (j, cst) + let j = execute env constr in + assert (eq_constr j.uj_val constr); + j + +(* let infer_key = Profile.declare_profile "infer" *) +(* let infer = Profile.profile2 infer_key infer *) let infer_type env constr = - let (j,(cst,_)) = - execute_type env constr (empty_constraint, universes env) in - (j, cst) + let j = execute_type env constr in + j let infer_v env cv = - let (jv,(cst,_)) = - execute_array env cv (empty_constraint, universes env) in - (jv, cst) + let jv = execute_array env cv in + jv (* Typing of several terms. *) let infer_local_decl env id = function | LocalDef c -> - let (j,cst) = infer env c in - (Name id, Some j.uj_val, j.uj_type), cst + let j = infer env c in + (Name id, Some j.uj_val, j.uj_type) | LocalAssum c -> - let (j,cst) = infer env c in - (Name id, None, assumption_of_judgment env j), cst + let j = infer env c in + (Name id, None, assumption_of_judgment env j) let infer_local_decls env decls = let rec inferec env = function | (id, d) :: l -> - let env, l, cst1 = inferec env l in - let d, cst2 = infer_local_decl env id d in - push_rel d env, add_rel_decl d l, union_constraints cst1 cst2 - | [] -> env, empty_rel_context, empty_constraint in + let (env, l) = inferec env l in + let d = infer_local_decl env id d in + (push_rel d env, add_rel_decl d l) + | [] -> (env, empty_rel_context) in inferec env decls - -(* Exported typing functions *) - -let typing env c = - let (j,cst) = infer env c in - let _ = add_constraints cst env in - j diff --git a/kernel/typeops.mli b/kernel/typeops.mli index d6484e823..6bc1ce496 100644 --- a/kernel/typeops.mli +++ b/kernel/typeops.mli @@ -14,15 +14,21 @@ open Environ open Entries open Declarations -(** {6 Typing functions (not yet tagged as safe) } *) +(** {6 Typing functions (not yet tagged as safe) } -val infer : env -> constr -> unsafe_judgment * constraints -val infer_v : env -> constr array -> unsafe_judgment array * constraints -val infer_type : env -> types -> unsafe_type_judgment * constraints + They return unsafe judgments that are "in context" of a set of + (local) universe variables (the ones that appear in the term) + and associated constraints. In case of polymorphic definitions, + these variables and constraints will be generalized. + *) + + +val infer : env -> constr -> unsafe_judgment +val infer_v : env -> constr array -> unsafe_judgment array +val infer_type : env -> types -> unsafe_type_judgment val infer_local_decls : - env -> (Id.t * local_entry) list - -> env * rel_context * constraints + env -> (Id.t * local_entry) list -> (env * rel_context) (** {6 Basic operations of the typing machine. } *) @@ -45,21 +51,25 @@ val judge_of_relative : env -> int -> unsafe_judgment val judge_of_variable : env -> variable -> unsafe_judgment (** {6 type of a constant } *) -val judge_of_constant : env -> constant -> unsafe_judgment +val judge_of_constant : env -> constant puniverses -> unsafe_judgment + +(* val judge_of_constant_knowing_parameters : *) +(* env -> constant -> unsafe_judgment array -> unsafe_judgment *) -val judge_of_constant_knowing_parameters : - env -> constant -> unsafe_judgment array -> unsafe_judgment +val judge_of_projection : env -> Names.projection -> unsafe_judgment -> unsafe_judgment (** {6 Type of application. } *) val judge_of_apply : env -> unsafe_judgment -> unsafe_judgment array - -> unsafe_judgment * constraints + -> unsafe_judgment (** {6 Type of an abstraction. } *) val judge_of_abstraction : env -> Name.t -> unsafe_type_judgment -> unsafe_judgment -> unsafe_judgment +val sort_of_product : env -> sorts -> sorts -> sorts + (** {6 Type of a product. } *) val judge_of_product : env -> Name.t -> unsafe_type_judgment -> unsafe_type_judgment @@ -73,37 +83,35 @@ val judge_of_letin : (** {6 Type of a cast. } *) val judge_of_cast : env -> unsafe_judgment -> cast_kind -> unsafe_type_judgment -> - unsafe_judgment * constraints + unsafe_judgment (** {6 Inductive types. } *) -val judge_of_inductive : env -> inductive -> unsafe_judgment +val judge_of_inductive : env -> inductive puniverses -> unsafe_judgment -val judge_of_inductive_knowing_parameters : - env -> inductive -> unsafe_judgment array -> unsafe_judgment +(* val judge_of_inductive_knowing_parameters : *) +(* env -> inductive -> unsafe_judgment array -> unsafe_judgment *) -val judge_of_constructor : env -> constructor -> unsafe_judgment +val judge_of_constructor : env -> constructor puniverses -> unsafe_judgment (** {6 Type of Cases. } *) val judge_of_case : env -> case_info -> unsafe_judgment -> unsafe_judgment -> unsafe_judgment array - -> unsafe_judgment * constraints + -> unsafe_judgment (** Typecheck general fixpoint (not checking guard conditions) *) val type_fixpoint : env -> Name.t array -> types array - -> unsafe_judgment array -> constraints - -(** Kernel safe typing but applicable to partial proofs *) -val typing : env -> constr -> unsafe_judgment + -> unsafe_judgment array -> unit -val type_of_constant : env -> constant -> types +val type_of_constant : env -> constant puniverses -> types constrained val type_of_constant_type : env -> constant_type -> types +val type_of_projection : env -> Names.projection puniverses -> types + +val type_of_constant_in : env -> constant puniverses -> types + val type_of_constant_knowing_parameters : env -> constant_type -> types Lazy.t array -> types -(** Make a type polymorphic if an arity *) -val make_polymorphic_if_constant_for_ind : env -> unsafe_judgment -> - constant_type diff --git a/kernel/univ.ml b/kernel/univ.ml index 551d74043..8322a7e96 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -29,13 +29,56 @@ open Util union-find algorithm. The assertions $<$ and $\le$ are represented by adjacency lists *) -module UniverseLevel = struct +module Level = struct open Names type t = + | Prop | Set - | Level of int * DirPath.t + | Level of int * Names.DirPath.t + type _t = t + + (* Hash-consing *) + + module Hunivlevel = + Hashcons.Make( + struct + type t = _t + type u = Names.DirPath.t -> Names.DirPath.t + let hashcons hdir = function + | Prop as x -> x + | Set as x -> x + | Level (n,d) -> Level (n,hdir d) + let equal l1 l2 = + l1 == l2 || + match l1,l2 with + | Prop, Prop -> true + | Set, Set -> true + | Level (n,d), Level (n',d') -> + n == n' && d == d' + | _ -> false + let hash = Hashtbl.hash + end) + + let hcons = Hashcons.simple_hcons Hunivlevel.generate Names.DirPath.hcons + + let make m n = hcons (Level (n, m)) + + let set = hcons Set + let prop = hcons Prop + + let is_small = function + | Level _ -> false + | _ -> true + + let is_prop = function + | Prop -> true + | _ -> false + + let is_set = function + | Set -> true + | _ -> false (* A specialized comparison function: we compare the [int] part first. This way, most of the time, the [DirPath.t] part is not considered. @@ -49,6 +92,9 @@ module UniverseLevel = struct if u == v then 0 else (match u,v with + | Prop,Prop -> 0 + | Prop, _ -> -1 + | _, Prop -> 1 | Set, Set -> 0 | Set, _ -> -1 | _, Set -> 1 @@ -63,27 +109,385 @@ module UniverseLevel = struct Int.equal i1 i2 && DirPath.equal dp1 dp2 | _ -> false - let hash = function - | Set -> 0 - | Level (i, dp) -> - Hashset.Combine.combine (Int.hash i) (DirPath.hash dp) - - let make m n = Level (n, m) + let eq u v = u == v + let leq u v = compare u v <= 0 let to_string = function + | Prop -> "Prop" | Set -> "Set" - | Level (n,d) -> DirPath.to_string d^"."^string_of_int n + | Level (n,d) -> Names.DirPath.to_string d^"."^string_of_int n + + let pr u = str (to_string u) + + let apart u v = + match u, v with + | Prop, Set | Set, Prop -> true + | _ -> false + end -module UniverseLMap = Map.Make (UniverseLevel) -module UniverseLSet = Set.Make (UniverseLevel) +let pr_universe_level_list l = + prlist_with_sep spc Level.pr l + +module LSet = struct + module M = Set.Make (Level) + include M + + let pr s = + str"{" ++ pr_universe_level_list (elements s) ++ str"}" -type universe_level = UniverseLevel.t + let of_list l = + List.fold_left (fun acc x -> add x acc) empty l -let compare_levels = UniverseLevel.compare + let of_array l = + Array.fold_left (fun acc x -> add x acc) empty l +end + +module LMap = struct + module M = Map.Make (Level) + include M + + let union l r = + merge (fun k l r -> + match l, r with + | Some _, _ -> l + | _, _ -> r) l r + + let subst_union l r = + merge (fun k l r -> + match l, r with + | Some (Some _), _ -> l + | Some None, None -> l + | _, _ -> r) l r + + let diff ext orig = + fold (fun u v acc -> + if mem u orig then acc + else add u v acc) + ext empty + + let elements = bindings + let of_set s d = + LSet.fold (fun u -> add u d) s + empty + + let of_list l = + List.fold_left (fun m (u, v) -> add u v m) empty l + + let universes m = + fold (fun u _ acc -> LSet.add u acc) m LSet.empty + + let pr f m = + h 0 (prlist_with_sep fnl (fun (u, v) -> + Level.pr u ++ f v) (elements m)) + + let find_opt t m = + try Some (find t m) + with Not_found -> None +end + +type universe_level = Level.t + +module LList = struct + type t = Level.t list + type _t = t + module Huniverse_level_list = + Hashcons.Make( + struct + type t = _t + type u = universe_level -> universe_level + let hashcons huc s = + List.fold_right (fun x a -> huc x :: a) s [] + let equal s s' = List.for_all2eq (==) s s' + let hash = Hashtbl.hash + end) + + let hcons = + Hashcons.simple_hcons Huniverse_level_list.generate Level.hcons + + let empty = hcons [] + let eq l l' = l == l' || + (try List.for_all2 Level.eq l l' + with Invalid_argument _ -> false) + + let levels = + List.fold_left (fun s x -> LSet.add x s) LSet.empty + +end + +type universe_level_list = universe_level list + +type universe_level_subst_fn = universe_level -> universe_level + +type universe_set = LSet.t +type 'a universe_map = 'a LMap.t + +let compare_levels = Level.compare +let eq_levels = Level.eq + +module Hashconsing = struct + module Uid = struct + type t = int + + let make_maker () = + let _id = ref ~-1 in + ((fun () -> incr _id;!_id), + (fun () -> !_id), + (fun i -> _id := i)) + + let dummy = -1 + + external to_int : t -> int = "%identity" + + + external of_int : int -> t= "%identity" + end + + module Hcons = struct + + module type SA = + sig + type data + type t + val make : data -> t + val node : t -> data + val hash : t -> int + val uid : t -> Uid.t + val equal : t -> t -> bool + val stats : unit -> unit + val init : unit -> unit + end + + module type S = + sig + + type data + type t = private { id : Uid.t; + key : int; + node : data } + val make : data -> t + val node : t -> data + val hash : t -> int + val uid : t -> Uid.t + val equal : t -> t -> bool + val stats : unit -> unit + val init : unit -> unit + end + + module Make (H : Hashtbl.HashedType) : S with type data = H.t = + struct + let uid_make,uid_current,uid_set = Uid.make_maker() + type data = H.t + type t = { id : Uid.t; + key : int; + node : data } + let node t = t.node + let uid t = t.id + let hash t = t.key + let equal t1 t2 = t1 == t2 + module WH = Weak.Make( struct + type _t = t + type t = _t + let hash = hash + let equal a b = a == b || H.equal a.node b.node + end) + let pool = WH.create 491 + + exception Found of Uid.t + let total_count = ref 0 + let miss_count = ref 0 + let init () = + total_count := 0; + miss_count := 0 + + let make x = + incr total_count; + let cell = { id = Uid.dummy; key = H.hash x; node = x } in + try + WH.find pool cell + with + | Not_found -> + let cell = { cell with id = uid_make(); } in + incr miss_count; + WH.add pool cell; + cell + + exception Found of t + + let stats () = () + end + end + module HList = struct + + module type S = sig + type elt + type 'a node = Nil | Cons of elt * 'a + + module rec Node : + sig + include Hcons.S with type data = Data.t + end + and Data : sig + include Hashtbl.HashedType with type t = Node.t node + end + type data = Data.t + type t = Node.t + val hash : t -> int + val uid : t -> Uid.t + val make : data -> t + val equal : t -> t -> bool + val nil : t + val is_nil : t -> bool + val tip : elt -> t + val node : t -> t node + val cons : (* ?sorted:bool -> *) elt -> t -> t + val hd : t -> elt + val tl : t -> t + val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a + val map : (elt -> elt) -> t -> t + val iter : (elt -> 'a) -> t -> unit + val exists : (elt -> bool) -> t -> bool + val for_all : (elt -> bool) -> t -> bool + val rev : t -> t + val rev_map : (elt -> elt) -> t -> t + val length : t -> int + val mem : elt -> t -> bool + val remove : elt -> t -> t + val stats : unit -> unit + val init : unit -> unit + val to_list : t -> elt list + val compare : (elt -> elt -> int) -> t -> t -> int + end + + module Make (H : Hcons.SA) : S with type elt = H.t = + struct + type elt = H.t + type 'a node = Nil | Cons of elt * 'a + module rec Node : Hcons.S with type data = Data.t = Hcons.Make (Data) + and Data : Hashtbl.HashedType with type t = Node.t node = + struct + type t = Node.t node + let equal x y = + match x,y with + | _,_ when x==y -> true + | Cons (a,aa), Cons(b,bb) -> (aa==bb) && (H.equal a b) + | _ -> false + let hash = function + | Nil -> 0 + | Cons(a,aa) -> 17 + 65599 * (Uid.to_int (H.uid a)) + 491 * (Uid.to_int aa.Node.id) + end + + type data = Data.t + type t = Node.t + let make = Node.make + let node x = x.Node.node + let hash x = x.Node.key + let equal = Node.equal + let uid x= x.Node.id + let nil = Node.make Nil + let stats = Node.stats + let init = Node.init + + let is_nil = + function { Node.node = Nil } -> true | _ -> false + + (* doing sorted insertion allows to make + better use of hash consing *) + let rec sorted_cons e l = + match l.Node.node with + | Nil -> Node.make (Cons(e, l)) + | Cons (x, ll) -> + if H.uid e < H.uid x + then Node.make (Cons(e, l)) + else Node.make (Cons(x, sorted_cons e ll)) + + let cons e l = + Node.make(Cons(e, l)) + + let tip e = Node.make (Cons(e, nil)) + + (* let cons ?(sorted=true) e l = *) + (* if sorted then sorted_cons e l else cons e l *) + + let hd = function { Node.node = Cons(a,_) } -> a | _ -> failwith "hd" + let tl = function { Node.node = Cons(_,a) } -> a | _ -> failwith "tl" + + let fold f l acc = + let rec loop acc l = match l.Node.node with + | Nil -> acc + | Cons (a, aa) -> loop (f a acc) aa + in + loop acc l + + let map f l = + let rec loop l = match l.Node.node with + | Nil -> nil + | Cons(a, aa) -> cons (f a) (loop aa) + in + loop l + + let iter f l = + let rec loop l = match l.Node.node with + | Nil -> () + | Cons(a,aa) -> (f a);(loop aa) + in + loop l + + let exists f l = + let rec loop l = match l.Node.node with + | Nil -> false + | Cons(a,aa) -> f a || loop aa + in + loop l + + let for_all f l = + let rec loop l = match l.Node.node with + | Nil -> true + | Cons(a,aa) -> f a && loop aa + in + loop l + + let to_list l = + let rec loop l = match l.Node.node with + | Nil -> [] + | Cons(a,aa) -> a :: loop aa + in + loop l + + let remove x l = + let rec loop l = match l.Node.node with + | Nil -> l + | Cons(a,aa) -> + if H.equal a x then aa + else cons a (loop aa) + in + loop l + + let rev l = fold cons l nil + let rev_map f l = fold (fun x acc -> cons (f x) acc) l nil + let length l = fold (fun _ c -> c+1) l 0 + let rec mem e l = + match l.Node.node with + | Nil -> false + | Cons (x, ll) -> x == e || mem e ll + + let rec compare cmp l1 l2 = + if l1 == l2 then 0 else + match node l1, node l2 with + | Nil, Nil -> 0 + | _, Nil -> 1 + | Nil, _ -> -1 + | Cons (x1,l1), Cons(x2,l2) -> + (match cmp x1 x2 with + | 0 -> compare cmp l1 l2 + | c -> c) + + end + end +end (* An algebraic universe [universe] is either a universe variable - [UniverseLevel.t] or a formal universe known to be greater than some + [Level.t] or a formal universe known to be greater than some universe variables and strictly greater than some (other) universe variables @@ -96,158 +500,346 @@ let compare_levels = UniverseLevel.compare module Universe = struct - type t = - | Atom of UniverseLevel.t - | Max of UniverseLevel.t list * UniverseLevel.t list + (* Invariants: non empty, sorted and without duplicates *) + + module Expr = + struct + type t = Level.t * int + type _t = t + + (* Hashing of expressions *) + module ExprHash = + struct + type t = _t + type u = Level.t -> Level.t + let hashcons hdir (b,n as x) = + let b' = hdir b in + if b' == b then x else (b',n) + let equal l1 l2 = + l1 == l2 || + match l1,l2 with + | (b,n), (b',n') -> b == b' && n == n' + let hash = Hashtbl.hash + + end + + module HExpr = + struct + + include Hashcons.Make(ExprHash) + + type data = t + type node = t + + let make = + Hashcons.simple_hcons generate Level.hcons + external node : node -> data = "%identity" + let hash = ExprHash.hash + let uid = hash + let equal x y = x == y + let stats _ = () + let init _ = () + end + + let hcons = HExpr.make + + let make l = hcons (l, 0) + + let compare u v = + if u == v then 0 + else + let (x, n) = u and (x', n') = v in + if Int.equal n n' then Level.compare x x' + else n - n' + + let prop = make Level.prop + let set = make Level.set + let type1 = hcons (Level.set, 1) + + let is_prop = function + | (l,0) -> Level.is_prop l + | _ -> false + + let is_set = function + | (l,0) -> Level.is_set l + | _ -> false + + let is_type1 = function + | (l,1) -> Level.is_set l + | _ -> false + + let is_small = function + | (l, 0) -> Level.is_small l + | _ -> false + + (* let eq (u,n) (v,n') = *) + (* Int.equal n n' && Level.eq u v *) + let eq x y = x == y + + let leq (u,n) (v,n') = + let cmp = Level.compare u v in + if Int.equal cmp 0 then n <= n' + else if n <= n' then + (Level.is_prop u && Level.is_small v) + else false + + let successor (u,n) = + if Level.is_prop u then type1 + else hcons (u, n + 1) + + let addn k (u,n as x) = + if k = 0 then x + else if Level.is_prop u then + hcons (Level.set,n+k) + else hcons (u,n+k) + + let super (u,n as x) (v,n' as y) = + let cmp = Level.compare u v in + if Int.equal cmp 0 then + if n < n' then Inl true + else Inl false + else if is_prop x then Inl true + else if is_prop y then Inl false + else Inr cmp + + let to_string (v, n) = + if Int.equal n 0 then Level.to_string v + else Level.to_string v ^ "+" ^ string_of_int n + + let pr x = str(to_string x) + + let level = function + | (v,0) -> Some v + | _ -> None + + let get_level (v,n) = v + + let map f (v, n as x) = + let v' = f v in + if v' == v then x + else if Level.is_prop v' && n != 0 then + hcons (Level.set, n) + else hcons (v', n) + + end + + module Hunivelt = struct + let node x = x + let make x = x + end + + (* module Hunivelt = Hashconsing.Hcons.Make( *) + (* struct *) + (* type t = Expr.t *) + (* let equal l1 l2 = *) + (* l1 == l2 || *) + (* match l1,l2 with *) + (* | (b,n), (b',n') -> b == b' && n == n' *) + (* let hash = Hashtbl.hash *) + (* end) *) + + let compare_expr n m = Expr.compare (Hunivelt.node n) (Hunivelt.node m) + let pr_expr n = Expr.pr (Hunivelt.node n) + + module Huniv = Hashconsing.HList.Make(Expr.HExpr) + type t = Huniv.t + open Huniv + + let eq x y = x == y (* Huniv.equal *) let compare u1 u2 = - if u1 == u2 then 0 else - match u1, u2 with - | Atom l1, Atom l2 -> UniverseLevel.compare l1 l2 - | Max (lt1, le1), Max (lt2, le2) -> - let c = List.compare UniverseLevel.compare lt1 lt2 in - if Int.equal c 0 then - List.compare UniverseLevel.compare le1 le2 - else c - | Atom _, Max _ -> -1 - | Max _, Atom _ -> 1 - - let equal u1 u2 = Int.equal (compare u1 u2) 0 - - let make l = Atom l - - open Hashset.Combine - - let rec hash_list accu = function - | [] -> 0 - | u :: us -> - let accu = combine (UniverseLevel.hash u) accu in - hash_list accu us - - let hash = function - | Atom u -> combinesmall 1 (UniverseLevel.hash u) - | Max (lt, le) -> - let hlt = hash_list 0 lt in - let hle = hash_list 0 le in - combinesmall 2 (combine hlt hle) + if eq u1 u2 then 0 else + Huniv.compare compare_expr u1 u2 + + let hcons_unique = Huniv.make + let normalize x = x + (* let hcons_unique x = x *) + let hcons x = hcons_unique (normalize x) + + let make l = Huniv.tip (Hunivelt.make (Expr.make l)) + let tip x = Huniv.tip (Hunivelt.make x) + + let equal_universes x y = + x == y +(* then true *) +(* else *) +(* (\* Consider lists as sets, i.e. up to reordering, *) +(* they are already without duplicates thanks to normalization. *\) *) +(* CList.eq_set x' y' *) + + let pr l = match node l with + | Cons (u, n) when is_nil n -> Expr.pr (Hunivelt.node u) + | _ -> + str "max(" ++ hov 0 + (prlist_with_sep pr_comma Expr.pr (List.map Hunivelt.node (to_list l))) ++ + str ")" + + let atom l = match node l with + | Cons (l, n) when is_nil n -> Some l + | _ -> None + + let level l = match node l with + | Cons (l, n) when is_nil n -> Expr.level (Hunivelt.node l) + | _ -> None + + let levels l = + fold (fun x acc -> LSet.add (Expr.get_level (Hunivelt.node x)) acc) l LSet.empty + + let is_small u = + match level (normalize u) with + | Some l -> Level.is_small l + | _ -> false -end + (* The lower predicative level of the hierarchy that contains (impredicative) + Prop and singleton inductive types *) + let type0m = tip Expr.prop -open Universe + (* The level of sets *) + let type0 = tip Expr.set + + (* When typing [Prop] and [Set], there is no constraint on the level, + hence the definition of [type1_univ], the type of [Prop] *) + let type1 = tip (Expr.successor Expr.set) + + let is_type0m u = + match level u with + | Some l -> Level.is_prop l + | _ -> false + + let is_type0 u = + match level u with + | Some l -> Level.is_set l + | _ -> false + + let is_type1 u = + match node u with + | Cons (l, n) when is_nil n -> Expr.is_type1 (Hunivelt.node l) + | _ -> false + + (* Returns the formal universe that lies juste above the universe variable u. + Used to type the sort u. *) + let super l = + Huniv.map (fun x -> Hunivelt.make (Expr.successor (Hunivelt.node x))) l + + let addn n l = + Huniv.map (fun x -> Hunivelt.make (Expr.addn n (Hunivelt.node x))) l + + let rec merge_univs l1 l2 = + match node l1, node l2 with + | Nil, _ -> l2 + | _, Nil -> l1 + | Cons (h1, t1), Cons (h2, t2) -> + (match Expr.super (Hunivelt.node h1) (Hunivelt.node h2) with + | Inl true (* h1 < h2 *) -> merge_univs t1 l2 + | Inl false -> merge_univs l1 t2 + | Inr c -> + if c <= 0 (* h1 < h2 is name order *) + then cons h1 (merge_univs t1 l2) + else cons h2 (merge_univs l1 t2)) + + let sort u = + let rec aux a l = + match node l with + | Cons (b, l') -> + (match Expr.super (Hunivelt.node a) (Hunivelt.node b) with + | Inl false -> aux a l' + | Inl true -> l + | Inr c -> + if c <= 0 then cons a l + else cons b (aux a l')) + | Nil -> cons a l + in + fold (fun a acc -> aux a acc) u nil + + (* Returns the formal universe that is greater than the universes u and v. + Used to type the products. *) + let sup x y = merge_univs x y + + let of_list l = + List.fold_right + (fun x acc -> cons (Hunivelt.make x) acc) + l nil + + let empty = nil + let is_empty n = is_nil n + + let exists f l = + Huniv.exists (fun x -> f (Hunivelt.node x)) l + + let for_all f l = + Huniv.for_all (fun x -> f (Hunivelt.node x)) l + + let smartmap f l = + Huniv.map (fun x -> + let n = Hunivelt.node x in + let x' = f n in + if x' == n then x else Hunivelt.make x') + l + +end type universe = Universe.t -let universe_level = function - | Atom l -> Some l - | Max _ -> None +open Universe -let pr_uni_level u = str (UniverseLevel.to_string u) +(* type universe_list = UList.t *) +(* let pr_universe_list = UList.pr *) -let pr_uni = function - | Atom u -> - pr_uni_level u - | Max ([],[u]) -> - str "(" ++ pr_uni_level u ++ str ")+1" - | Max (gel,gtl) -> - let opt_sep = match gel, gtl with - | [], _ | _, [] -> mt () - | _ -> pr_comma () - in - str "max(" ++ hov 0 - (prlist_with_sep pr_comma pr_uni_level gel ++ opt_sep ++ - prlist_with_sep pr_comma - (fun x -> str "(" ++ pr_uni_level x ++ str ")+1") gtl) ++ - str ")" - -(* Returns the formal universe that lies juste above the universe variable u. - Used to type the sort u. *) -let super = function - | Atom u -> - Max ([],[u]) - | Max _ -> - anomaly (str "Cannot take the successor of a non variable universe" ++ spc () ++ - str "(maybe a bugged tactic)") - -(* Returns the formal universe that is greater than the universes u and v. - Used to type the products. *) -let sup u v = - match u,v with - | Atom u, Atom v -> - if UniverseLevel.equal u v then Atom u else Max ([u;v],[]) - | u, Max ([],[]) -> u - | Max ([],[]), v -> v - | Atom u, Max (gel,gtl) -> Max (List.add_set UniverseLevel.equal u gel,gtl) - | Max (gel,gtl), Atom v -> Max (List.add_set UniverseLevel.equal v gel,gtl) - | Max (gel,gtl), Max (gel',gtl') -> - let gel'' = List.union UniverseLevel.equal gel gel' in - let gtl'' = List.union UniverseLevel.equal gtl gtl' in - Max (List.subtract UniverseLevel.equal gel'' gtl'',gtl'') +let pr_uni = Universe.pr +let is_small_univ = Universe.is_small + +let universe_level = Universe.level (* Comparison on this type is pointer equality *) type canonical_arc = - { univ: UniverseLevel.t; - lt: UniverseLevel.t list; - le: UniverseLevel.t list; - rank: int } + { univ: Level.t; + lt: Level.t list; + le: Level.t list; + rank : int} let terminal u = {univ=u; lt=[]; le=[]; rank=0} -(* A UniverseLevel.t is either an alias for another one, or a canonical one, +(* A Level.t is either an alias for another one, or a canonical one, for which we know the universes that are above *) type univ_entry = Canonical of canonical_arc - | Equiv of UniverseLevel.t + | Equiv of Level.t -type universes = univ_entry UniverseLMap.t +type universes = univ_entry LMap.t let enter_equiv_arc u v g = - UniverseLMap.add u (Equiv v) g + LMap.add u (Equiv v) g let enter_arc ca g = - UniverseLMap.add ca.univ (Canonical ca) g - -(* The lower predicative level of the hierarchy that contains (impredicative) - Prop and singleton inductive types *) -let type0m_univ = Max ([],[]) + LMap.add ca.univ (Canonical ca) g -let is_type0m_univ = function - | Max ([],[]) -> true - | _ -> false +let is_type0m_univ = Universe.is_type0m (* The level of predicative Set *) -let type0_univ = Atom UniverseLevel.Set +let type0m_univ = Universe.type0m +let type0_univ = Universe.type0 +let type1_univ = Universe.type1 -let is_type0_univ = function - | Atom UniverseLevel.Set -> true - | Max ([UniverseLevel.Set], []) -> msg_warning (str "Non canonical Set"); true - | u -> false +let sup = Universe.sup +let super = Universe.super -let is_univ_variable = function - | Atom UniverseLevel.Set -> false - | Atom _ -> true - | _ -> false +let is_type0_univ = Universe.is_type0 -(* When typing [Prop] and [Set], there is no constraint on the level, - hence the definition of [type1_univ], the type of [Prop] *) +let is_univ_variable l = Universe.level l != None -let type1_univ = Max ([], [UniverseLevel.Set]) +(* Every Level.t has a unique canonical arc representative *) -let initial_universes = UniverseLMap.empty -let is_initial_universes = UniverseLMap.is_empty - -(* Every UniverseLevel.t has a unique canonical arc representative *) - -(* repr : universes -> UniverseLevel.t -> canonical_arc *) +(* repr : universes -> Level.t -> canonical_arc *) (* canonical representative : we follow the Equiv links *) let repr g u = let rec repr_rec u = let a = - try UniverseLMap.find u g + try LMap.find u g with Not_found -> anomaly ~label:"Univ.repr" - (str "Universe" ++ spc () ++ pr_uni_level u ++ spc () ++ str "undefined") + (str"Universe " ++ Level.pr u ++ str" undefined") in match a with | Equiv v -> repr_rec v @@ -262,7 +854,7 @@ let can g = List.map (repr g) let safe_repr g u = let rec safe_repr_rec u = - match UniverseLMap.find u g with + match LMap.find u g with | Equiv v -> safe_repr_rec v | Canonical arc -> arc in @@ -286,7 +878,7 @@ let reprleq g arcu = searchrec [] arcu.le -(* between : UniverseLevel.t -> canonical_arc -> canonical_arc list *) +(* between : Level.t -> canonical_arc -> canonical_arc list *) (* between u v = { w | u<=w<=v, w canonical } *) (* between is the most costly operation *) @@ -320,6 +912,7 @@ let between g arcu arcv = *) type constraint_type = Lt | Le | Eq + type explanation = (constraint_type * universe) list let constraint_type_ord c1 c2 = match c1, c2 with @@ -335,10 +928,10 @@ let constraint_type_ord c1 c2 = match c1, c2 with correspond to the universes in (direct) relation [rel] with it, make a list of canonical universe, updating the relation with the starting point (path stored in reverse order). *) -let canp g (p:explanation) rel l : (canonical_arc * explanation) list = - List.map (fun u -> (repr g u, (rel,Atom u)::p)) l +let canp g (p:explanation Lazy.t) rel l : (canonical_arc * explanation Lazy.t) list = + List.map (fun u -> (repr g u, lazy ((rel,Universe.make u):: Lazy.force p))) l -type order = EQ | LT of explanation | LE of explanation | NLE +type order = EQ | LT of explanation Lazy.t | LE of explanation Lazy.t | NLE (** [compare_neq] : is [arcv] in the transitive upward closure of [arcu] ? @@ -375,14 +968,14 @@ let compare_neq strict g arcu arcv = | [] -> cmp c (arc :: lt_done) le_done lt_todo le_todo | u :: lt -> let arc = repr g u in - let p = (Lt, Atom u) :: p in + let p = lazy ((Lt, make u) :: Lazy.force p) in if arc == arcv then if strict then LT p else LE p else find ((arc, p) :: lt_todo) lt le end | u :: le -> let arc = repr g u in - let p = (Le, Atom u) :: p in + let p = lazy ((Le, make u) :: Lazy.force p) in if arc == arcv then if strict then LT p else LE p else find ((arc, p) :: lt_todo) lt le @@ -402,21 +995,22 @@ let compare_neq strict g arcu arcv = let rec find lt_todo lt = match lt with | [] -> let fold accu u = - let node = (repr g u, (Le, Atom u) :: p) in + let p = lazy ((Le, make u) :: Lazy.force p) in + let node = (repr g u, p) in node :: accu in let le_new = List.fold_left fold le_todo arc.le in cmp c lt_done (arc :: le_done) lt_todo le_new | u :: lt -> let arc = repr g u in - let p = (Lt, Atom u) :: p in + let p = lazy ((Lt, make u) :: Lazy.force p) in if arc == arcv then if strict then LT p else LE p else find ((arc, p) :: lt_todo) lt in find [] arc.lt in - cmp NLE [] [] [] [arcu, []] + cmp NLE [] [] [] [arcu, Lazy.lazy_from_val []] let compare g arcu arcv = if arcu == arcv then EQ else compare_neq true g arcu arcv @@ -456,50 +1050,80 @@ let check_smaller g strict u v = if strict then is_lt g arcu arcv else - arcu == snd (safe_repr g UniverseLevel.Set) || is_leq g arcu arcv + arcu == snd (safe_repr g Level.prop) || is_leq g arcu arcv (** Then, checks on universes *) -type check_function = universes -> universe -> universe -> bool +type 'a check_function = universes -> 'a -> 'a -> bool + +(* let equiv_list cmp l1 l2 = *) +(* let rec aux l1 l2 = *) +(* match l1 with *) +(* | [] -> l2 = [] *) +(* | hd :: tl1 -> *) +(* let rec aux' acc = function *) +(* | hd' :: tl2 -> *) +(* if cmp hd hd' then aux tl1 (acc @ tl2) *) +(* else aux' (hd' :: acc) tl2 *) +(* | [] -> false *) +(* in aux' [] l2 *) +(* in aux l1 l2 *) let incl_list cmp l1 l2 = - List.for_all (fun x1 -> List.exists (fun x2 -> cmp x1 x2) l2) l1 + Huniv.for_all (fun x1 -> Huniv.exists (fun x2 -> cmp x1 x2) l2) l1 let compare_list cmp l1 l2 = - (l1 == l2) - || (incl_list cmp l1 l2 && incl_list cmp l2 l1) + (l1 == l2) || (* (equiv_list cmp l1 l2) *) + (incl_list cmp l1 l2 && incl_list cmp l2 l1) + +let check_equal_expr g x y = + x == y || (let (u, n) = Hunivelt.node x and (v, m) = Hunivelt.node y in + n = m && check_equal g u v) (** [check_eq] is also used in [Evd.set_eq_sort], hence [Evarconv] and [Unification]. In this case, it seems that the Atom/Max case may occur, hence a relaxed version. *) -let gen_check_eq strict g u v = - match u,v with - | Atom ul, Atom vl -> check_equal g ul vl - | Max(ule,ult), Max(vle,vlt) -> - (* TODO: remove elements of lt in le! *) - compare_list (check_equal g) ule vle && - compare_list (check_equal g) ult vlt - | _ -> - (* not complete! (Atom(u) = Max([u],[]) *) - if strict then anomaly (str "check_eq") - else false (* in non-strict mode, under-approximation *) - -let check_eq = gen_check_eq true -let lax_check_eq = gen_check_eq false +(* let gen_check_eq strict g u v = *) +(* match u,v with *) +(* | Atom ul, Atom vl -> check_equal g ul vl *) +(* | Max(ule,ult), Max(vle,vlt) -> *) +(* (\* TODO: remove elements of lt in le! *\) *) +(* compare_list (check_equal g) ule vle && *) +(* compare_list (check_equal g) ult vlt *) +(* | _ -> *) +(* (\* not complete! (Atom(u) = Max([u],[]) *\) *) +(* if strict then anomaly (str "check_eq") *) +(* else false (\* in non-strict mode, under-approximation *\) *) + +(* let check_eq = gen_check_eq true *) +(* let lax_check_eq = gen_check_eq false *) +let check_eq g u v = + compare_list (check_equal_expr g) u v +let check_eq_level g u v = u == v || check_equal g u v +let lax_check_eq = check_eq + +let check_smaller_expr g (u,n) (v,m) = + if n <= m then + check_smaller g false u v + else if n - m = 1 then + check_smaller g true u v + else false + +let exists_bigger g ul l = + Huniv.exists (fun ul' -> + check_smaller_expr g (Hunivelt.node ul) (Hunivelt.node ul')) l let check_leq g u v = - match u,v with - | Atom ul, Atom vl -> check_smaller g false ul vl - | Max(le,lt), Atom vl -> - List.for_all (fun ul -> check_smaller g false ul vl) le && - List.for_all (fun ul -> check_smaller g true ul vl) lt - | _ -> anomaly (str "check_leq") + u == v || + match Universe.level u with + | Some l when Level.is_prop l -> true + | _ -> Huniv.for_all (fun ul -> exists_bigger g ul v) u (** Enforcing new constraints : [setlt], [setleq], [merge], [merge_disc] *) -(* setlt : UniverseLevel.t -> UniverseLevel.t -> reason -> unit *) +(* setlt : Level.t -> Level.t -> reason -> unit *) (* forces u > v *) (* this is normally an update of u in g rather than a creation. *) let setlt g arcu arcv = @@ -512,7 +1136,7 @@ let setlt_if (g,arcu) v = if is_lt g arcu arcv then g, arcu else setlt g arcu arcv -(* setleq : UniverseLevel.t -> UniverseLevel.t -> unit *) +(* setleq : Level.t -> Level.t -> unit *) (* forces u >= v *) (* this is normally an update of u in g rather than a creation. *) let setleq g arcu arcv = @@ -526,7 +1150,7 @@ let setleq_if (g,arcu) v = if is_leq g arcu arcv then g, arcu else setleq g arcu arcv -(* merge : UniverseLevel.t -> UniverseLevel.t -> unit *) +(* merge : Level.t -> Level.t -> unit *) (* we assume compare(u,v) = LE *) (* merge u v forces u ~ v with repr u as canonical repr *) let merge g arcu arcv = @@ -559,7 +1183,7 @@ let merge g arcu arcv = let g_arcu = List.fold_left setleq_if g_arcu w' in fst g_arcu -(* merge_disc : UniverseLevel.t -> UniverseLevel.t -> unit *) +(* merge_disc : Level.t -> Level.t -> unit *) (* we assume compare(u,v) = compare(v,u) = NLE *) (* merge_disc u v forces u ~ v with repr u as canonical repr *) let merge_disc g arc1 arc2 = @@ -579,36 +1203,37 @@ let merge_disc g arc1 arc2 = (* Universe inconsistency: error raised when trying to enforce a relation that would create a cycle in the graph of universes. *) -exception UniverseInconsistency of - constraint_type * universe * universe * explanation +type univ_inconsistency = constraint_type * universe * universe * explanation + +exception UniverseInconsistency of univ_inconsistency let error_inconsistency o u v (p:explanation) = - raise (UniverseInconsistency (o,Atom u,Atom v,p)) + raise (UniverseInconsistency (o,make u,make v,p)) -(* enforce_univ_leq : UniverseLevel.t -> UniverseLevel.t -> unit *) +(* enforce_univ_leq : Level.t -> Level.t -> unit *) (* enforce_univ_leq u v will force u<=v if possible, will fail otherwise *) let enforce_univ_leq u v g = let g,arcu = safe_repr g u in let g,arcv = safe_repr g v in if is_leq g arcu arcv then g else match compare g arcv arcu with - | LT p -> error_inconsistency Le u v (List.rev p) + | LT p -> error_inconsistency Le u v (List.rev (Lazy.force p)) | LE _ -> merge g arcv arcu | NLE -> fst (setleq g arcu arcv) | EQ -> anomaly (Pp.str "Univ.compare") -(* enforc_univ_eq : UniverseLevel.t -> UniverseLevel.t -> unit *) +(* enforc_univ_eq : Level.t -> Level.t -> unit *) (* enforc_univ_eq u v will force u=v if possible, will fail otherwise *) let enforce_univ_eq u v g = let g,arcu = safe_repr g u in let g,arcv = safe_repr g v in match compare g arcu arcv with | EQ -> g - | LT p -> error_inconsistency Eq u v (List.rev p) + | LT p -> error_inconsistency Eq v u (List.rev (Lazy.force p)) | LE _ -> merge g arcu arcv | NLE -> (match compare g arcv arcu with - | LT p -> error_inconsistency Eq u v (List.rev p) + | LT p -> error_inconsistency Eq u v (List.rev (Lazy.force p)) | LE _ -> merge g arcv arcu | NLE -> merge_disc g arcu arcv | EQ -> anomaly (Pp.str "Univ.compare")) @@ -620,16 +1245,20 @@ let enforce_univ_lt u v g = match compare g arcu arcv with | LT _ -> g | LE _ -> fst (setlt g arcu arcv) - | EQ -> error_inconsistency Lt u v [(Eq,Atom v)] + | EQ -> error_inconsistency Lt u v [(Eq,make v)] | NLE -> (match compare_neq false g arcv arcu with NLE -> fst (setlt g arcu arcv) | EQ -> anomaly (Pp.str "Univ.compare") - | (LE p|LT p) -> error_inconsistency Lt u v (List.rev p)) + | (LE p|LT p) -> error_inconsistency Lt u v (List.rev (Lazy.force p))) -(* Constraints and sets of consrtaints. *) +let empty_universes = LMap.empty +let initial_universes = enforce_univ_lt Level.prop Level.set LMap.empty +let is_initial_universes g = LMap.equal (==) g initial_universes -type univ_constraint = UniverseLevel.t * constraint_type * UniverseLevel.t +(* Constraints and sets of constraints. *) + +type univ_constraint = Level.t * constraint_type * Level.t let enforce_constraint cst g = match cst with @@ -637,6 +1266,14 @@ let enforce_constraint cst g = | (u,Le,v) -> enforce_univ_leq u v g | (u,Eq,v) -> enforce_univ_eq u v g +let pr_constraint_type op = + let op_str = match op with + | Lt -> " < " + | Le -> " <= " + | Eq -> " = " + in str op_str + + module UConstraintOrd = struct type t = univ_constraint @@ -644,51 +1281,566 @@ struct let i = constraint_type_ord c c' in if not (Int.equal i 0) then i else - let i' = UniverseLevel.compare u u' in + let i' = Level.compare u u' in if not (Int.equal i' 0) then i' - else UniverseLevel.compare v v' + else Level.compare v v' end -module Constraint = Set.Make(UConstraintOrd) +module Constraint = +struct + module S = Set.Make(UConstraintOrd) + include S -type constraints = Constraint.t + let pr c = + fold (fun (u1,op,u2) pp_std -> + pp_std ++ Level.pr u1 ++ pr_constraint_type op ++ + Level.pr u2 ++ fnl () ) c (str "") + +end let empty_constraint = Constraint.empty let is_empty_constraint = Constraint.is_empty +let union_constraint = Constraint.union let eq_constraint = Constraint.equal -let union_constraints = Constraint.union +type constraints = Constraint.t + +module Hconstraint = + Hashcons.Make( + struct + type t = univ_constraint + type u = universe_level -> universe_level + let hashcons hul (l1,k,l2) = (hul l1, k, hul l2) + let equal (l1,k,l2) (l1',k',l2') = + l1 == l1' && k == k' && l2 == l2' + let hash = Hashtbl.hash + end) + +module Hconstraints = + Hashcons.Make( + struct + type t = constraints + type u = univ_constraint -> univ_constraint + let hashcons huc s = + Constraint.fold (fun x -> Constraint.add (huc x)) s Constraint.empty + let equal s s' = + List.for_all2eq (==) + (Constraint.elements s) + (Constraint.elements s') + let hash = Hashtbl.hash + end) + +let hcons_constraint = Hashcons.simple_hcons Hconstraint.generate Level.hcons +let hcons_constraints = Hashcons.simple_hcons Hconstraints.generate hcons_constraint + +type universe_constraint_type = ULe | UEq | ULub + +type universe_constraint = universe * universe_constraint_type * universe +module UniverseConstraints = struct + module S = Set.Make( + struct + type t = universe_constraint + + let compare_type c c' = + match c, c' with + | ULe, ULe -> 0 + | ULe, _ -> -1 + | _, ULe -> 1 + | UEq, UEq -> 0 + | UEq, _ -> -1 + | ULub, ULub -> 0 + | ULub, _ -> 1 + + let compare (u,c,v) (u',c',v') = + let i = compare_type c c' in + if Int.equal i 0 then + let i' = Universe.compare u u' in + if Int.equal i' 0 then Universe.compare v v' + else + if c != ULe && Universe.compare u v' = 0 && Universe.compare v u' = 0 then 0 + else i' + else i + end) + + include S + + let add (l,d,r as cst) s = + if Universe.eq l r then s + else add cst s + + let tr_dir = function + | ULe -> Le + | UEq -> Eq + | ULub -> Eq + + let op_str = function ULe -> " <= " | UEq -> " = " | ULub -> " /\\ " + + let pr c = + fold (fun (u1,op,u2) pp_std -> + pp_std ++ Universe.pr u1 ++ str (op_str op) ++ + Universe.pr u2 ++ fnl ()) c (str "") + + let equal x y = + x == y || equal x y -type constraint_function = - universe -> universe -> constraints -> constraints +end + +type universe_constraints = UniverseConstraints.t +type 'a universe_constrained = 'a * universe_constraints + +(** A value with universe constraints. *) +type 'a constrained = 'a * constraints + +let level_subst_of f = + fun l -> + try let u = f l in + match Universe.level u with + | None -> l + | Some l -> l + with Not_found -> l + +module Instance = struct + type t = Level.t array + + module HInstance = + Hashcons.Make( + struct + type _t = t + type t = _t + type u = Level.t -> Level.t + let hashcons huniv a = + CArray.smartmap huniv a + + let equal t1 t2 = + t1 == t2 || + (Int.equal (Array.length t1) (Array.length t2) && + let rec aux i = + (Int.equal i (Array.length t1)) || (t1.(i) == t2.(i) && aux (i + 1)) + in aux 0) + + let hash = Hashtbl.hash + end) + + let hcons_instance = Hashcons.simple_hcons HInstance.generate Level.hcons + + let hcons = hcons_instance + let empty = [||] + let is_empty x = Int.equal (Array.length x) 0 + + let eq t u = t == u || CArray.for_all2 Level.eq t u + + let of_array a = a + let to_array a = a + + let eqeq t1 t2 = + t1 == t2 || + (Int.equal (Array.length t1) (Array.length t2) && + let rec aux i = + (Int.equal i (Array.length t1)) || (t1.(i) == t2.(i) && aux (i + 1)) + in aux 0) + + let subst_fn fn t = CArray.smartmap fn t + let subst s t = CArray.smartmap (fun x -> try LMap.find x s with Not_found -> x) t + + let levels x = LSet.of_array x + + let pr = + prvect_with_sep spc Level.pr + + let append x y = + if Array.length x = 0 then y + else if Array.length y = 0 then x + else Array.append x y + + let max_level i = + if Array.is_empty i then 0 + else + let l = CArray.last i in + match l with + | Level.Level (i,_) -> i + | _ -> assert false + + let check_eq g t1 t2 = + t1 == t2 || + (Int.equal (Array.length t1) (Array.length t2) && + let rec aux i = + (Int.equal i (Array.length t1)) || (check_eq_level g t1.(i) t2.(i) && aux (i + 1)) + in aux 0) + +end + +type universe_instance = Instance.t + +type 'a puniverses = 'a * Instance.t +let out_punivs (x, y) = x +let in_punivs x = (x, Instance.empty) + +(** A context of universe levels with universe constraints, + representiong local universe variables and constraints *) + +module UContext = +struct + type t = Instance.t constrained + + let make x = x + + (** Universe contexts (variables as a list) *) + let empty = (Instance.empty, Constraint.empty) + let is_empty (univs, cst) = Instance.is_empty univs && Constraint.is_empty cst + + let pr (univs, cst as ctx) = + if is_empty ctx then mt() else + Instance.pr univs ++ str " |= " ++ v 1 (Constraint.pr cst) + + let hcons (univs, cst) = + (Instance.hcons univs, hcons_constraints cst) + + let instance (univs, cst) = univs + let constraints (univs, cst) = cst + + let union (univs, cst) (univs', cst') = + Instance.append univs univs', Constraint.union cst cst' +end + +type universe_context = UContext.t +let hcons_universe_context = UContext.hcons + +(** A set of universes with universe constraints. + We linearize the set to a list after typechecking. + Beware, representation could change. +*) + +module ContextSet = +struct + type t = universe_set constrained + + let empty = (LSet.empty, Constraint.empty) + let is_empty (univs, cst) = LSet.is_empty univs && Constraint.is_empty cst + + let of_context (ctx,cst) = + (Instance.levels ctx, cst) + + let of_set s = (s, Constraint.empty) + let singleton l = of_set (LSet.singleton l) + let of_instance i = of_set (Instance.levels i) + + let union (univs, cst) (univs', cst') = + LSet.union univs univs', Constraint.union cst cst' + + let diff (univs, cst) (univs', cst') = + LSet.diff univs univs', Constraint.diff cst cst' + + let add_constraints (univs, cst) cst' = + univs, Constraint.union cst cst' + + let add_universes univs ctx = + union (of_instance univs) ctx + + let to_context (ctx, cst) = + (Array.of_list (LSet.elements ctx), cst) + + let of_context (ctx, cst) = + (Instance.levels ctx, cst) + + let pr (univs, cst as ctx) = + if is_empty ctx then mt() else + LSet.pr univs ++ str " |= " ++ v 1 (Constraint.pr cst) + + let constraints (univs, cst) = cst + let levels (univs, cst) = univs + +end + +type universe_context_set = ContextSet.t + +(** A value in a universe context (resp. context set). *) +type 'a in_universe_context = 'a * universe_context +type 'a in_universe_context_set = 'a * universe_context_set + +(** A universe level substitution, note that no algebraic universes are + involved *) +type universe_level_subst = universe_level universe_map + +(** A full substitution might involve algebraic universes *) +type universe_subst = universe universe_map + +(** Pretty-printing *) +let pr_constraints = Constraint.pr + +let pr_universe_context = UContext.pr + +let pr_universe_context_set = ContextSet.pr + +let pr_universe_subst = + LMap.pr (fun u -> str" := " ++ Universe.pr u ++ spc ()) + +let pr_universe_level_subst = + LMap.pr (fun u -> str" := " ++ Level.pr u ++ spc ()) + +let constraints_of (_, cst) = cst + +let constraint_depend (l,d,r) u = + Level.eq l u || Level.eq l r + +let constraint_depend_list (l,d,r) us = + List.mem l us || List.mem r us + +let constraints_depend cstr us = + Constraint.exists (fun c -> constraint_depend_list c us) cstr + +let remove_dangling_constraints dangling cst = + Constraint.fold (fun (l,d,r as cstr) cst' -> + if List.mem l dangling || List.mem r dangling then cst' + else + (** Unnecessary constraints Prop <= u *) + if Level.eq l Level.prop && d == Le then cst' + else Constraint.add cstr cst') cst Constraint.empty + +let check_context_subset (univs, cst) (univs', cst') = + let newunivs, dangling = List.partition (fun u -> LSet.mem u univs) (Array.to_list univs') in + (* Some universe variables that don't appear in the term + are still mentionned in the constraints. This is the + case for "fake" universe variables that correspond to +1s. *) + (* if not (CList.is_empty dangling) then *) + (* todo ("A non-empty set of inferred universes do not appear in the term or type"); *) + (* (not (constraints_depend cst' dangling));*) + (* TODO: check implication *) + (** Remove local universes that do not appear in any constraint, they + are really entirely parametric. *) + (* let newunivs, dangling' = List.partition (fun u -> constraints_depend cst [u]) newunivs in *) + let cst' = remove_dangling_constraints dangling cst in + Array.of_list newunivs, cst' + +(** Substitutions. *) + +let make_universe_subst inst (ctx, csts) = + try Array.fold_left2 (fun acc c i -> LMap.add c (Universe.make i) acc) + LMap.empty ctx inst + with Invalid_argument _ -> + anomaly (Pp.str "Mismatched instance and context when building universe substitution") + +let empty_subst = LMap.empty +let is_empty_subst = LMap.is_empty + +let empty_level_subst = LMap.empty +let is_empty_level_subst = LMap.is_empty + +(** Substitution functions *) + +(** With level to level substitutions. *) +let subst_univs_level_level subst l = + try LMap.find l subst + with Not_found -> l + +let rec normalize_univs_level_level subst l = + try + let l' = LMap.find l subst in + normalize_univs_level_level subst l' + with Not_found -> l + +let subst_univs_level_fail subst l = + try match Universe.level (subst l) with + | Some l' -> l' + | None -> l + with Not_found -> l + +let rec subst_univs_level_universe subst u = + let u' = Universe.smartmap (Universe.Expr.map (subst_univs_level_level subst)) u in + if u == u' then u + else Universe.sort u' + +let subst_univs_level_constraint subst (u,d,v) = + let u' = subst_univs_level_level subst u + and v' = subst_univs_level_level subst v in + if d != Lt && Level.eq u' v' then None + else Some (u',d,v') + +let subst_univs_level_constraints subst csts = + Constraint.fold + (fun c -> Option.fold_right Constraint.add (subst_univs_level_constraint subst c)) + csts Constraint.empty + +(* let subst_univs_level_constraint_key = Profile.declare_profile "subst_univs_level_constraint";; *) +(* let subst_univs_level_constraint = *) +(* Profile.profile2 subst_univs_level_constraint_key subst_univs_level_constraint *) + +(** With level to universe substitutions. *) +type universe_subst_fn = universe_level -> universe + +let make_subst subst = fun l -> LMap.find l subst + +let subst_univs_level fn l = + try fn l + with Not_found -> make l + +let subst_univs_expr_opt fn (l,n) = + try Some (Universe.addn n (fn l)) + with Not_found -> None + +let subst_univs_universe fn ul = + let subst, nosubst = + Universe.Huniv.fold (fun u (subst,nosubst) -> + match subst_univs_expr_opt fn (Hunivelt.node u) with + | Some a' -> (a' :: subst, nosubst) + | None -> (subst, u :: nosubst)) + ul ([], []) + in + if CList.is_empty subst then ul + else + let substs = + List.fold_left Universe.merge_univs Universe.empty subst + in + List.fold_left (fun acc u -> Universe.merge_univs acc (Universe.Huniv.tip u)) + substs nosubst + +let subst_univs_constraint fn (u,d,v) = + let u' = subst_univs_level fn u and v' = subst_univs_level fn v in + if d != Lt && Universe.eq u' v' then None + else Some (u',d,v') + +let subst_univs_universe_constraint fn (u,d,v) = + let u' = subst_univs_universe fn u and v' = subst_univs_universe fn v in + if Universe.eq u' v' then None + else Some (u',d,v') + +(** Constraint functions. *) + +type 'a constraint_function = 'a -> 'a -> constraints -> constraints let constraint_add_leq v u c = - (* We just discard trivial constraints like Set<=u or u<=u *) - if UniverseLevel.equal v UniverseLevel.Set || UniverseLevel.equal v u then c - else Constraint.add (v,Le,u) c + (* We just discard trivial constraints like u<=u *) + if Expr.eq v u then c + else + match v, u with + | (x,n), (y,m) -> + let j = m - n in + if j = -1 (* n = m+1, v+1 <= u <-> v < u *) then + Constraint.add (x,Lt,y) c + else if j <= -1 (* n = m+k, v+k <= u <-> v+(k-1) < u *) then + if Level.eq x y then (* u+(k+1) <= u *) + raise (UniverseInconsistency (Le, Universe.tip v, Universe.tip u, [])) + else anomaly (Pp.str"Unable to handle arbitrary u+k <= v constraints") + else if j = 0 then + Constraint.add (x,Le,y) c + else (* j >= 1 *) (* m = n + k, u <= v+k *) + if Level.eq x y then c (* u <= u+k, trivial *) + else if Level.is_small x then c (* Prop,Set <= u+S k, trivial *) + else anomaly (Pp.str"Unable to handle arbitrary u <= v+k constraints") + +let check_univ_eq u v = Universe.eq u v + +let check_univ_leq_one u v = Universe.exists (Expr.leq u) v + +let check_univ_leq u v = + Universe.for_all (fun u -> check_univ_leq_one u v) u let enforce_leq u v c = - match u, v with - | Atom u, Atom v -> constraint_add_leq u v c - | Max (gel,gtl), Atom v -> - let d = List.fold_right (fun u -> constraint_add_leq u v) gel c in - List.fold_right (fun u -> Constraint.add (u,Lt,v)) gtl d - | _ -> anomaly (Pp.str "A universe bound can only be a variable") + match Huniv.node v with + | Universe.Huniv.Cons (v, n) when Universe.is_empty n -> + Universe.Huniv.fold (fun u -> constraint_add_leq (Hunivelt.node u) (Hunivelt.node v)) u c + | _ -> anomaly (Pp.str"A universe bound can only be a variable") + +let enforce_leq u v c = + if check_univ_leq u v then c + else enforce_leq u v c + +let enforce_eq_level u v c = + (* We discard trivial constraints like u=u *) + if Level.eq u v then c + else if Level.apart u v then + error_inconsistency Eq u v [] + else Constraint.add (u,Eq,v) c let enforce_eq u v c = - match (u,v) with - | Atom u, Atom v -> - (* We discard trivial constraints like u=u *) - if UniverseLevel.equal u v then c else Constraint.add (u,Eq,v) c + match Universe.level u, Universe.level v with + | Some u, Some v -> enforce_eq_level u v c | _ -> anomaly (Pp.str "A universe comparison can only happen between variables") +let enforce_eq u v c = + if check_univ_eq u v then c + else enforce_eq u v c + +let enforce_leq_level u v c = + if Level.eq u v then c else Constraint.add (u,Le,v) c + +let enforce_eq_instances = CArray.fold_right2 enforce_eq_level + +type 'a universe_constraint_function = 'a -> 'a -> universe_constraints -> universe_constraints + +let enforce_eq_instances_univs strict t1 t2 c = + let d = if strict then ULub else UEq in + CArray.fold_right2 (fun x y -> UniverseConstraints.add (Universe.make x, d, Universe.make y)) + t1 t2 c + let merge_constraints c g = Constraint.fold enforce_constraint c g +(* let merge_constraints_key = Profile.declare_profile "merge_constraints";; *) +(* let merge_constraints = Profile.profile2 merge_constraints_key merge_constraints *) + +let check_constraint g (l,d,r) = + match d with + | Eq -> check_equal g l r + | Le -> check_smaller g false l r + | Lt -> check_smaller g true l r + +let check_constraints c g = + Constraint.for_all (check_constraint g) c + +(* let check_constraints_key = Profile.declare_profile "check_constraints";; *) +(* let check_constraints = *) +(* Profile.profile2 check_constraints_key check_constraints *) + +let enforce_univ_constraint (u,d,v) = + match d with + | Eq -> enforce_eq u v + | Le -> enforce_leq u v + | Lt -> enforce_leq (super u) v + +let subst_univs_constraints subst csts = + Constraint.fold + (fun c -> Option.fold_right enforce_univ_constraint (subst_univs_constraint subst c)) + csts Constraint.empty + +(* let subst_univs_constraints_key = Profile.declare_profile "subst_univs_constraints";; *) +(* let subst_univs_constraints = *) +(* Profile.profile2 subst_univs_constraints_key subst_univs_constraints *) + +let subst_univs_universe_constraints subst csts = + UniverseConstraints.fold + (fun c -> Option.fold_right UniverseConstraints.add (subst_univs_universe_constraint subst c)) + csts UniverseConstraints.empty + +(* let subst_univs_universe_constraints_key = Profile.declare_profile "subst_univs_universe_constraints";; *) +(* let subst_univs_universe_constraints = *) +(* Profile.profile2 subst_univs_universe_constraints_key subst_univs_universe_constraints *) + +(** Substitute instance inst for ctx in csts *) +let instantiate_univ_context subst (_, csts) = + subst_univs_constraints (make_subst subst) csts + +let check_consistent_constraints (ctx,cstrs) cstrs' = + (* TODO *) () + +let to_constraints g s = + let rec tr (x,d,y) acc = + let add l d l' acc = Constraint.add (l,UniverseConstraints.tr_dir d,l') acc in + match Universe.level x, d, Universe.level y with + | Some l, (ULe | UEq | ULub), Some l' -> add l d l' acc + | _, ULe, Some l' -> enforce_leq x y acc + | _, ULub, _ -> acc + | _, d, _ -> + let f = if d == ULe then check_leq else check_eq in + if f g x y then acc else + raise (Invalid_argument + "to_constraints: non-trivial algebraic constraint between universes") + in UniverseConstraints.fold tr s Constraint.empty + + (* Normalization *) let lookup_level u g = - try Some (UniverseLMap.find u g) with Not_found -> None + try Some (LMap.find u g) with Not_found -> None (** [normalize_universes g] returns a graph where all edges point directly to the canonical representent of their target. The output @@ -702,20 +1854,20 @@ let normalize_universes g = | Some x -> x, cache | None -> match Lazy.force arc with | None -> - u, UniverseLMap.add u u cache + u, LMap.add u u cache | Some (Canonical {univ=v; lt=_; le=_}) -> - v, UniverseLMap.add u v cache + v, LMap.add u v cache | Some (Equiv v) -> let v, cache = visit v (lazy (lookup_level v g)) cache in - v, UniverseLMap.add u v cache + v, LMap.add u v cache in - let cache = UniverseLMap.fold + let cache = LMap.fold (fun u arc cache -> snd (visit u (Lazy.lazy_from_val (Some arc)) cache)) - g UniverseLMap.empty + g LMap.empty in - let repr x = UniverseLMap.find x cache in + let repr x = LMap.find x cache in let lrepr us = List.fold_left - (fun e x -> UniverseLSet.add (repr x) e) UniverseLSet.empty us + (fun e x -> LSet.add (repr x) e) LSet.empty us in let canonicalize u = function | Equiv _ -> Equiv (repr u) @@ -723,24 +1875,24 @@ let normalize_universes g = assert (u == v); (* avoid duplicates and self-loops *) let lt = lrepr lt and le = lrepr le in - let le = UniverseLSet.filter - (fun x -> x != u && not (UniverseLSet.mem x lt)) le + let le = LSet.filter + (fun x -> x != u && not (LSet.mem x lt)) le in - UniverseLSet.iter (fun x -> assert (x != u)) lt; + LSet.iter (fun x -> assert (x != u)) lt; Canonical { univ = v; - lt = UniverseLSet.elements lt; - le = UniverseLSet.elements le; + lt = LSet.elements lt; + le = LSet.elements le; rank = rank } in - UniverseLMap.mapi canonicalize g + LMap.mapi canonicalize g (** [check_sorted g sorted]: [g] being a universe graph, [sorted] being a map to levels, checks that all constraints in [g] are satisfied in [sorted]. *) let check_sorted g sorted = - let get u = try UniverseLMap.find u sorted with + let get u = try LMap.find u sorted with | Not_found -> assert false in let iter u arc = @@ -751,7 +1903,7 @@ let check_sorted g sorted = List.iter (fun v -> assert (lu <= get v)) le; List.iter (fun v -> assert (lu < get v)) lt in - UniverseLMap.iter iter g + LMap.iter iter g (** Bellman-Ford algorithm with a few customizations: @@ -765,7 +1917,7 @@ let bellman_ford bottom g = | None -> () | Some _ -> assert false in - let ( << ) a b = match a, b with + let ( <? ) a b = match a, b with | _, None -> true | None, _ -> false | Some x, Some y -> (x : int) < y @@ -774,38 +1926,38 @@ let bellman_ford bottom g = | Some x -> Some (x-y) and push u x m = match x with | None -> m - | Some y -> UniverseLMap.add u y m + | Some y -> LMap.add u y m in let relax u v uv distances = let x = lookup_level u distances ++ uv in - if x << lookup_level v distances then push v x distances + if x <? lookup_level v distances then push v x distances else distances in - let init = UniverseLMap.add bottom 0 UniverseLMap.empty in - let vertices = UniverseLMap.fold (fun u arc res -> - let res = UniverseLSet.add u res in + let init = LMap.add bottom 0 LMap.empty in + let vertices = LMap.fold (fun u arc res -> + let res = LSet.add u res in match arc with - | Equiv e -> UniverseLSet.add e res + | Equiv e -> LSet.add e res | Canonical {univ=univ; lt=lt; le=le} -> assert (u == univ); - let add res v = UniverseLSet.add v res in + let add res v = LSet.add v res in let res = List.fold_left add res le in let res = List.fold_left add res lt in - res) g UniverseLSet.empty + res) g LSet.empty in let g = let node = Canonical { univ = bottom; lt = []; - le = UniverseLSet.elements vertices; + le = LSet.elements vertices; rank = 0 - } in UniverseLMap.add bottom node g + } in LMap.add bottom node g in let rec iter count accu = if count <= 0 then accu else - let accu = UniverseLMap.fold (fun u arc res -> match arc with + let accu = LMap.fold (fun u arc res -> match arc with | Equiv e -> relax e u 0 (relax u e 0 res) | Canonical {univ=univ; lt=lt; le=le} -> assert (u == univ); @@ -814,16 +1966,16 @@ let bellman_ford bottom g = res) g accu in iter (count-1) accu in - let distances = iter (UniverseLSet.cardinal vertices) init in - let () = UniverseLMap.iter (fun u arc -> + let distances = iter (LSet.cardinal vertices) init in + let () = LMap.iter (fun u arc -> let lu = lookup_level u distances in match arc with | Equiv v -> let lv = lookup_level v distances in - assert (not (lu << lv) && not (lv << lu)) + assert (not (lu <? lv) && not (lv <? lu)) | Canonical {univ=univ; lt=lt; le=le} -> assert (u == univ); - List.iter (fun v -> assert (not (lu ++ 0 << lookup_level v distances))) le; - List.iter (fun v -> assert (not (lu ++ 1 << lookup_level v distances))) lt) g + List.iter (fun v -> assert (not (lu ++ 0 <? lookup_level v distances))) le; + List.iter (fun v -> assert (not (lu ++ 1 <? lookup_level v distances))) lt) g in distances (** [sort_universes g] builds a map from universes in [g] to natural @@ -837,23 +1989,23 @@ let bellman_ford bottom g = let sort_universes orig = let mp = Names.DirPath.make [Names.Id.of_string "Type"] in let rec make_level accu g i = - let type0 = UniverseLevel.Level (i, mp) in + let type0 = Level.make mp i in let distances = bellman_ford type0 g in - let accu, continue = UniverseLMap.fold (fun u x (accu, continue) -> + let accu, continue = LMap.fold (fun u x (accu, continue) -> let continue = continue || x < 0 in let accu = - if Int.equal x 0 && u != type0 then UniverseLMap.add u i accu + if Int.equal x 0 && u != type0 then LMap.add u i accu else accu in accu, continue) distances (accu, false) in - let filter x = not (UniverseLMap.mem x accu) in + let filter x = not (LMap.mem x accu) in let push g u = - if UniverseLMap.mem u g then g else UniverseLMap.add u (Equiv u) g + if LMap.mem u g then g else LMap.add u (Equiv u) g in - let g = UniverseLMap.fold (fun u arc res -> match arc with + let g = LMap.fold (fun u arc res -> match arc with | Equiv v as x -> begin match filter u, filter v with - | true, true -> UniverseLMap.add u x res + | true, true -> LMap.add u x res | true, false -> push res u | false, true -> push res v | false, false -> res @@ -863,24 +2015,24 @@ let sort_universes orig = if filter u then let lt = List.filter filter lt in let le = List.filter filter le in - UniverseLMap.add u (Canonical {univ=u; lt=lt; le=le; rank=r}) res + LMap.add u (Canonical {univ=u; lt=lt; le=le; rank=r}) res else let res = List.fold_left (fun g u -> if filter u then push g u else g) res lt in let res = List.fold_left (fun g u -> if filter u then push g u else g) res le in - res) g UniverseLMap.empty + res) g LMap.empty in if continue then make_level accu g (i+1) else i, accu in - let max, levels = make_level UniverseLMap.empty orig 0 in + let max, levels = make_level LMap.empty orig 0 in (* defensively check that the result makes sense *) check_sorted orig levels; - let types = Array.init (max+1) (fun x -> UniverseLevel.Level (x, mp)) in - let g = UniverseLMap.map (fun x -> Equiv types.(x)) levels in + let types = Array.init (max+1) (fun x -> Level.make mp x) in + let g = LMap.map (fun x -> Equiv types.(x)) levels in let g = let rec aux i g = if i < max then let u = types.(i) in - let g = UniverseLMap.add u (Canonical { + let g = LMap.add u (Canonical { univ = u; le = []; lt = [types.(i+1)]; @@ -893,26 +2045,19 @@ let sort_universes orig = (**********************************************************************) (* Tools for sort-polymorphic inductive types *) -(* Temporary inductive type levels *) - -let fresh_local_univ, set_remote_fresh_local_univ = - RemoteCounter.new_counter ~name:"local_univ" 0 ~incr:((+) 1) - ~build:(fun n -> Atom (UniverseLevel.Level (n, Names.DirPath.empty))) - (* Miscellaneous functions to remove or test local univ assumed to occur only in the le constraints *) -let make_max = function - | ([u],[]) -> Atom u - | (le,lt) -> Max (le,lt) - -let remove_large_constraint u = function - | Atom u' as x -> if UniverseLevel.equal u u' then Max ([],[]) else x - | Max (le,lt) -> make_max (List.remove UniverseLevel.equal u le,lt) +let remove_large_constraint u v min = + match Universe.level v with + | Some u' -> if Level.eq u u' then min else v + | None -> Huniv.remove (Hunivelt.make (Universe.Expr.make u)) v -let is_direct_constraint u = function - | Atom u' -> UniverseLevel.equal u u' - | Max (le,lt) -> List.mem_f UniverseLevel.equal u le +(* [is_direct_constraint u v] if level [u] is a member of universe [v] *) +let is_direct_constraint u v = + match Universe.level v with + | Some u' -> Level.eq u u' + | None -> Huniv.mem (Hunivelt.make (Universe.Expr.make u)) v (* Solve a system of universe constraint of the form @@ -932,29 +2077,31 @@ let is_direct_sort_constraint s v = match s with | Some u -> is_direct_constraint u v | None -> false -let solve_constraints_system levels level_bounds = +let solve_constraints_system levels level_bounds level_min = let levels = - Array.map (Option.map (function Atom u -> u | _ -> anomaly (Pp.str "expects Atom"))) + Array.map (Option.map (fun u -> match level u with Some u -> u | _ -> anomaly (Pp.str"expects Atom"))) levels in let v = Array.copy level_bounds in let nind = Array.length v in for i=0 to nind-1 do for j=0 to nind-1 do if not (Int.equal i j) && is_direct_sort_constraint levels.(j) v.(i) then - v.(i) <- sup v.(i) level_bounds.(j) + (v.(i) <- Universe.sup v.(i) level_bounds.(j); + level_min.(i) <- Universe.sup level_min.(i) level_min.(j)) done; for j=0 to nind-1 do match levels.(j) with - | Some u -> v.(i) <- remove_large_constraint u v.(i) + | Some u -> v.(i) <- remove_large_constraint u v.(i) level_min.(i) | None -> () done done; v let subst_large_constraint u u' v = - match u with - | Atom u -> - if is_direct_constraint u v then sup u' (remove_large_constraint u v) + match level u with + | Some u -> + if is_direct_constraint u v then + Universe.sup u' (remove_large_constraint u v type0m_univ) else v | _ -> anomaly (Pp.str "expect a universe level") @@ -963,21 +2110,30 @@ let subst_large_constraints = List.fold_right (fun (u,u') -> subst_large_constraint u u') let no_upper_constraints u cst = - match u with - | Atom u -> - let test (u1, _, _) = not (UniverseLevel.equal u1 u) in + match level u with + | Some u -> + let test (u1, _, _) = + not (Int.equal (Level.compare u1 u) 0) in Constraint.for_all test cst - | Max _ -> anomaly (Pp.str "no_upper_constraints") + | _ -> anomaly (Pp.str "no_upper_constraints") (* Is u mentionned in v (or equals to v) ? *) -let level_list_mem u l = List.mem_f UniverseLevel.equal u l - let univ_depends u v = - match u, v with - | Atom u, Atom v -> UniverseLevel.equal u v - | Atom u, Max (gel,gtl) -> level_list_mem u gel || level_list_mem u gtl - | _ -> anomaly (Pp.str "univ_depends given a non-atomic 1st arg") + match atom u with + | Some u -> Huniv.mem u v + | _ -> anomaly (Pp.str"univ_depends given a non-atomic 1st arg") + +let constraints_of_universes g = + let constraints_of u v acc = + match v with + | Canonical {univ=u; lt=lt; le=le} -> + let acc = List.fold_left (fun acc v -> Constraint.add (u,Lt,v) acc) acc lt in + let acc = List.fold_left (fun acc v -> Constraint.add (u,Le,v) acc) acc le in + acc + | Equiv v -> Constraint.add (u,Eq,v) acc + in + LMap.fold constraints_of g Constraint.empty (* Pretty-printing *) @@ -989,101 +2145,67 @@ let pr_arc = function | [], _ | _, [] -> mt () | _ -> spc () in - pr_uni_level u ++ str " " ++ + Level.pr u ++ str " " ++ v 0 - (pr_sequence (fun v -> str "< " ++ pr_uni_level v) lt ++ + (pr_sequence (fun v -> str "< " ++ Level.pr v) lt ++ opt_sep ++ - pr_sequence (fun v -> str "<= " ++ pr_uni_level v) le) ++ + pr_sequence (fun v -> str "<= " ++ Level.pr v) le) ++ fnl () | u, Equiv v -> - pr_uni_level u ++ str " = " ++ pr_uni_level v ++ fnl () + Level.pr u ++ str " = " ++ Level.pr v ++ fnl () let pr_universes g = - let graph = UniverseLMap.fold (fun u a l -> (u,a)::l) g [] in + let graph = LMap.fold (fun u a l -> (u,a)::l) g [] in prlist pr_arc graph -let pr_constraints c = - Constraint.fold (fun (u1,op,u2) pp_std -> - let op_str = match op with - | Lt -> " < " - | Le -> " <= " - | Eq -> " = " - in pp_std ++ pr_uni_level u1 ++ str op_str ++ - pr_uni_level u2 ++ fnl () ) c (str "") - (* Dumping constraints to a file *) let dump_universes output g = let dump_arc u = function | Canonical {univ=u; lt=lt; le=le} -> - let u_str = UniverseLevel.to_string u in - List.iter (fun v -> output Lt u_str (UniverseLevel.to_string v)) lt; - List.iter (fun v -> output Le u_str (UniverseLevel.to_string v)) le + let u_str = Level.to_string u in + List.iter (fun v -> output Lt u_str (Level.to_string v)) lt; + List.iter (fun v -> output Le u_str (Level.to_string v)) le | Equiv v -> - output Eq (UniverseLevel.to_string u) (UniverseLevel.to_string v) + output Eq (Level.to_string u) (Level.to_string v) in - UniverseLMap.iter dump_arc g + LMap.iter dump_arc g -(* Hash-consing *) - -module Hunivlevel = +module Huniverse_set = Hashcons.Make( struct - type t = universe_level - type u = Names.DirPath.t -> Names.DirPath.t - let hashcons hdir = function - | UniverseLevel.Set -> UniverseLevel.Set - | UniverseLevel.Level (n,d) -> UniverseLevel.Level (n,hdir d) - let equal l1 l2 = - l1 == l2 || - match l1,l2 with - | UniverseLevel.Set, UniverseLevel.Set -> true - | UniverseLevel.Level (n,d), UniverseLevel.Level (n',d') -> - n == n' && d == d' - | _ -> false - let hash = UniverseLevel.hash - end) - -module Huniv = - Hashcons.Make( - struct - type t = universe + type t = universe_set type u = universe_level -> universe_level - let hashcons hdir = function - | Atom u -> Atom (hdir u) - | Max (gel,gtl) -> Max (List.map hdir gel, List.map hdir gtl) - let equal u v = - u == v || - match u, v with - | Atom u, Atom v -> u == v - | Max (gel,gtl), Max (gel',gtl') -> - (List.for_all2eq (==) gel gel') && - (List.for_all2eq (==) gtl gtl') - | _ -> false - let hash = Universe.hash + let hashcons huc s = + LSet.fold (fun x -> LSet.add (huc x)) s LSet.empty + let equal s s' = + LSet.equal s s' + let hash = Hashtbl.hash end) -let hcons_univlevel = Hashcons.simple_hcons Hunivlevel.generate Names.DirPath.hcons -let hcons_univ = Hashcons.simple_hcons Huniv.generate hcons_univlevel +let hcons_universe_set = + Hashcons.simple_hcons Huniverse_set.generate Level.hcons -module Hconstraint = - Hashcons.Make( - struct - type t = univ_constraint - type u = universe_level -> universe_level - let hashcons hul (l1,k,l2) = (hul l1, k, hul l2) - let equal (l1,k,l2) (l1',k',l2') = - l1 == l1' && k == k' && l2 == l2' - let hash = Hashtbl.hash - end) +let hcons_universe_context_set (v, c) = + (hcons_universe_set v, hcons_constraints c) -module UConstraintHash = -struct - type t = univ_constraint - let hash = Hashtbl.hash -end -module Hconstraints = Set.Hashcons(UConstraintOrd)(UConstraintHash) +let hcons_univlevel = Level.hcons +let hcons_univ x = x (* Universe.hcons (Huniv.node x) *) +let equal_universes = Universe.equal_universes -let hcons_constraint = Hashcons.simple_hcons Hconstraint.generate hcons_univlevel -let hcons_constraints = Hashcons.simple_hcons Hconstraints.generate hcons_constraint +let explain_universe_inconsistency (o,u,v,p) = + let pr_rel = function + | Eq -> str"=" | Lt -> str"<" | Le -> str"<=" + in + let reason = match p with + [] -> mt() + | _::_ -> + str " because" ++ spc() ++ pr_uni v ++ + prlist (fun (r,v) -> spc() ++ pr_rel r ++ str" " ++ pr_uni v) + p ++ + (if Universe.eq (snd (List.last p)) u then mt() else + (spc() ++ str "= " ++ pr_uni u)) + in + str "Cannot enforce" ++ spc() ++ pr_uni u ++ spc() ++ + pr_rel o ++ spc() ++ pr_uni v ++ reason ++ str")" diff --git a/kernel/univ.mli b/kernel/univ.mli index 04267de70..9e7cc18b4 100644 --- a/kernel/univ.mli +++ b/kernel/univ.mli @@ -8,30 +8,67 @@ (** Universes. *) -module UniverseLevel : +module Level : sig type t (** Type of universe levels. A universe level is essentially a unique name that will be associated to constraints later on. *) + val set : t + val prop : t + val is_small : t -> bool + val compare : t -> t -> int (** Comparison function *) - val equal : t -> t -> bool + val eq : t -> t -> bool (** Equality function *) - val hash : t -> int + (* val hash : t -> int *) (** Hash function *) val make : Names.DirPath.t -> int -> t (** Create a new universe level from a unique identifier and an associated module path. *) + val pr : t -> Pp.std_ppcmds end -type universe_level = UniverseLevel.t +type universe_level = Level.t (** Alias name. *) +module LSet : +sig + include Set.S with type elt = universe_level + + val pr : t -> Pp.std_ppcmds +end + +type universe_set = LSet.t + +module LMap : +sig + include Map.S with type key = universe_level + + (** Favorizes the bindings in the first map. *) + val union : 'a t -> 'a t -> 'a t + val diff : 'a t -> 'a t -> 'a t + + val subst_union : 'a option t -> 'a option t -> 'a option t + + val elements : 'a t -> (universe_level * 'a) list + val of_list : (universe_level * 'a) list -> 'a t + val of_set : universe_set -> 'a -> 'a t + val mem : universe_level -> 'a t -> bool + val universes : 'a t -> universe_set + + val find_opt : universe_level -> 'a t -> 'a option + + val pr : ('a -> Pp.std_ppcmds) -> 'a t -> Pp.std_ppcmds +end + +type 'a universe_map = 'a LMap.t + module Universe : sig type t @@ -41,68 +78,260 @@ sig val compare : t -> t -> int (** Comparison function *) - val equal : t -> t -> bool + val eq : t -> t -> bool (** Equality function *) - val hash : t -> int + (* val hash : t -> int *) (** Hash function *) - val make : UniverseLevel.t -> t + val make : Level.t -> t (** Create a constraint-free universe out of a given level. *) + val pr : t -> Pp.std_ppcmds + + val level : t -> Level.t option + + val levels : t -> LSet.t + + val normalize : t -> t + + (** The type of a universe *) + val super : t -> t + + (** The max of 2 universes *) + val sup : t -> t -> t + + val type0m : t (** image of Prop in the universes hierarchy *) + val type0 : t (** image of Set in the universes hierarchy *) + val type1 : t (** the universe of the type of Prop/Set *) end type universe = Universe.t -(** Alias name. *) -module UniverseLSet : Set.S with type elt = universe_level +(** Alias name. *) +val pr_uni : universe -> Pp.std_ppcmds + (** The universes hierarchy: Type 0- = Prop <= Type 0 = Set <= Type 1 <= ... Typing of universes: Type 0-, Type 0 : Type 1; Type i : Type (i+1) if i>0 *) - -val type0m_univ : universe (** image of Prop in the universes hierarchy *) -val type0_univ : universe (** image of Set in the universes hierarchy *) -val type1_univ : universe (** the universe of the type of Prop/Set *) +val type0m_univ : universe +val type0_univ : universe +val type1_univ : universe val is_type0_univ : universe -> bool val is_type0m_univ : universe -> bool val is_univ_variable : universe -> bool +val is_small_univ : universe -> bool -val universe_level : universe -> universe_level option - -(** The type of a universe *) +val sup : universe -> universe -> universe val super : universe -> universe -(** The max of 2 universes *) -val sup : universe -> universe -> universe +val universe_level : universe -> universe_level option +val compare_levels : universe_level -> universe_level -> int +val eq_levels : universe_level -> universe_level -> bool + +(** Equality of formal universe expressions. *) +val equal_universes : universe -> universe -> bool (** {6 Graphs of universes. } *) type universes -type check_function = universes -> universe -> universe -> bool -val check_leq : check_function -val check_eq : check_function -val lax_check_eq : check_function (* same, without anomaly *) +type 'a check_function = universes -> 'a -> 'a -> bool +val check_leq : universe check_function +val check_eq : universe check_function +val lax_check_eq : universe check_function (* same, without anomaly *) (** The empty graph of universes *) +val empty_universes : universes + +(** The initial graph of universes: Prop < Set *) val initial_universes : universes val is_initial_universes : universes -> bool (** {6 Constraints. } *) -type constraints +type constraint_type = Lt | Le | Eq +type univ_constraint = universe_level * constraint_type * universe_level + +module Constraint : sig + include Set.S with type elt = univ_constraint +end -val empty_constraint : constraints -val union_constraints : constraints -> constraints -> constraints +type constraints = Constraint.t -val is_empty_constraint : constraints -> bool +val empty_constraint : constraints +val union_constraint : constraints -> constraints -> constraints val eq_constraint : constraints -> constraints -> bool -type constraint_function = universe -> universe -> constraints -> constraints +type universe_constraint_type = ULe | UEq | ULub + +type universe_constraint = universe * universe_constraint_type * universe +module UniverseConstraints : sig + include Set.S with type elt = universe_constraint + + val pr : t -> Pp.std_ppcmds +end + +type universe_constraints = UniverseConstraints.t +type 'a universe_constrained = 'a * universe_constraints + +(** A value with universe constraints. *) +type 'a constrained = 'a * constraints + +type universe_subst_fn = universe_level -> universe +type universe_level_subst_fn = universe_level -> universe_level + +(** A full substitution, might involve algebraic universes *) +type universe_subst = universe universe_map +type universe_level_subst = universe_level universe_map + +val level_subst_of : universe_subst_fn -> universe_level_subst_fn + +module Instance : +sig + type t + + val hcons : t -> t + val empty : t + val is_empty : t -> bool + + val eq : t -> t -> bool + + val of_array : Level.t array -> t + val to_array : t -> Level.t array + + (** Rely on physical equality of subterms only *) + val eqeq : t -> t -> bool + + val subst_fn : universe_level_subst_fn -> t -> t + val subst : universe_level_subst -> t -> t + + val pr : t -> Pp.std_ppcmds + + val append : t -> t -> t -val enforce_leq : constraint_function -val enforce_eq : constraint_function + val levels : t -> LSet.t + + val max_level : t -> int + + val check_eq : t check_function + +end + +type universe_instance = Instance.t + +type 'a puniverses = 'a * universe_instance +val out_punivs : 'a puniverses -> 'a +val in_punivs : 'a -> 'a puniverses + +(** A list of universes with universe constraints, + representiong local universe variables and constraints *) + +module UContext : +sig + type t + + val make : Instance.t constrained -> t + val empty : t + val is_empty : t -> bool + + val instance : t -> Instance.t + val constraints : t -> constraints + + (** Keeps the order of the instances *) + val union : t -> t -> t + +end + +type universe_context = UContext.t + +(** Universe contexts (as sets) *) + +module ContextSet : +sig + type t = universe_set constrained + + val empty : t + val is_empty : t -> bool + + val singleton : universe_level -> t + val of_instance : Instance.t -> t + val of_set : universe_set -> t + + val union : t -> t -> t + val diff : t -> t -> t + val add_constraints : t -> constraints -> t + val add_universes : Instance.t -> t -> t + + (** Arbitrary choice of linear order of the variables + and normalization of the constraints *) + val to_context : t -> universe_context + val of_context : universe_context -> t + + val constraints : t -> constraints + val levels : t -> universe_set +end + +(** A set of universes with universe constraints. + We linearize the set to a list after typechecking. + Beware, representation could change. +*) +type universe_context_set = ContextSet.t + +(** A value in a universe context (resp. context set). *) +type 'a in_universe_context = 'a * universe_context +type 'a in_universe_context_set = 'a * universe_context_set + +(** Constrained *) +val constraints_of : 'a constrained -> constraints + + +(** [check_context_subset s s'] checks that [s] is implied by [s'] as a set of constraints, + and shrinks [s'] to the set of variables declared in [s]. +. *) +val check_context_subset : universe_context_set -> universe_context -> universe_context + +(** Make a universe level substitution: the list must match the context variables. *) +val make_universe_subst : Instance.t -> universe_context -> universe_subst +val empty_subst : universe_subst +val is_empty_subst : universe_subst -> bool + +val empty_level_subst : universe_level_subst +val is_empty_level_subst : universe_level_subst -> bool + +(** Get the instantiated graph. *) +val instantiate_univ_context : universe_subst -> universe_context -> constraints + +(** Substitution of universes. *) +val subst_univs_level_level : universe_level_subst -> universe_level -> universe_level +val subst_univs_level_universe : universe_level_subst -> universe -> universe +val subst_univs_level_constraints : universe_level_subst -> constraints -> constraints + +val normalize_univs_level_level : universe_level_subst -> universe_level -> universe_level + +val make_subst : universe_subst -> universe_subst_fn + +(* val subst_univs_level_fail : universe_subst_fn -> universe_level -> universe_level *) +val subst_univs_level : universe_subst_fn -> universe_level -> universe +val subst_univs_universe : universe_subst_fn -> universe -> universe +val subst_univs_constraints : universe_subst_fn -> constraints -> constraints +val subst_univs_universe_constraints : universe_subst_fn -> universe_constraints -> universe_constraints + +(** Raises universe inconsistency if not compatible. *) +val check_consistent_constraints : universe_context_set -> constraints -> unit + +type 'a constraint_function = 'a -> 'a -> constraints -> constraints + +val enforce_leq : universe constraint_function +val enforce_eq : universe constraint_function +val enforce_eq_level : universe_level constraint_function +val enforce_leq_level : universe_level constraint_function +val enforce_eq_instances : universe_instance constraint_function + +type 'a universe_constraint_function = 'a -> 'a -> universe_constraints -> universe_constraints + +val enforce_eq_instances_univs : bool -> universe_instance universe_constraint_function (** {6 ... } *) (** Merge of constraints in a universes graph. @@ -110,8 +339,6 @@ val enforce_eq : constraint_function universes graph. It raises the exception [UniverseInconsistency] if the constraints are not satisfiable. *) -type constraint_type = Lt | Le | Eq - (** Type explanation is used to decorate error messages to provide useful explanation why a given constraint is rejected. It is composed of a path of universes and relation kinds [(r1,u1);..;(rn,un)] means @@ -125,20 +352,26 @@ type constraint_type = Lt | Le | Eq constraints... *) type explanation = (constraint_type * universe) list +type univ_inconsistency = constraint_type * universe * universe * explanation -exception UniverseInconsistency of - constraint_type * universe * universe * explanation +exception UniverseInconsistency of univ_inconsistency +val enforce_constraint : univ_constraint -> universes -> universes val merge_constraints : constraints -> universes -> universes val normalize_universes : universes -> universes val sort_universes : universes -> universes -(** {6 Support for sort-polymorphic inductive types } *) +val constraints_of_universes : universes -> constraints + +val to_constraints : universes -> universe_constraints -> constraints + +val check_constraint : universes -> univ_constraint -> bool +val check_constraints : constraints -> universes -> bool -val fresh_local_univ : unit -> universe -val set_remote_fresh_local_univ : universe RemoteCounter.installer -val solve_constraints_system : universe option array -> universe array -> +(** {6 Support for sort-polymorphism } *) + +val solve_constraints_system : universe option array -> universe array -> universe array -> universe array val subst_large_constraint : universe -> universe -> universe -> universe @@ -154,10 +387,15 @@ val univ_depends : universe -> universe -> bool (** {6 Pretty-printing of universes. } *) -val pr_uni_level : universe_level -> Pp.std_ppcmds -val pr_uni : universe -> Pp.std_ppcmds val pr_universes : universes -> Pp.std_ppcmds +val pr_constraint_type : constraint_type -> Pp.std_ppcmds val pr_constraints : constraints -> Pp.std_ppcmds +(* val pr_universe_list : universe_list -> Pp.std_ppcmds *) +val pr_universe_context : universe_context -> Pp.std_ppcmds +val pr_universe_context_set : universe_context_set -> Pp.std_ppcmds +val pr_universe_level_subst : universe_level_subst -> Pp.std_ppcmds +val pr_universe_subst : universe_subst -> Pp.std_ppcmds +val explain_universe_inconsistency : univ_inconsistency -> Pp.std_ppcmds (** {6 Dumping to a file } *) @@ -170,3 +408,8 @@ val dump_universes : val hcons_univlevel : universe_level -> universe_level val hcons_univ : universe -> universe val hcons_constraints : constraints -> constraints +val hcons_universe_set : universe_set -> universe_set +val hcons_universe_context : universe_context -> universe_context +val hcons_universe_context_set : universe_context_set -> universe_context_set + +(******) diff --git a/kernel/vars.ml b/kernel/vars.ml index f23d5fc2c..3cff51ba6 100644 --- a/kernel/vars.ml +++ b/kernel/vars.ml @@ -212,3 +212,89 @@ let substn_vars p vars c = in replace_vars (List.rev subst) c let subst_vars subst c = substn_vars 1 subst c + +(** Universe substitutions *) +open Constr + +let subst_univs_puniverses subst = + if Univ.is_empty_level_subst subst then fun c -> c + else + let f = Univ.Instance.subst subst in + fun ((c, u) as x) -> let u' = f u in if u' == u then x else (c, u') + +let subst_univs_fn_puniverses fn = + let f = Univ.Instance.subst_fn fn in + fun ((c, u) as x) -> let u' = f u in if u' == u then x else (c, u') + +let subst_univs_fn_constr f c = + let changed = ref false in + let fu = Univ.subst_univs_universe f in + let fi = Univ.Instance.subst_fn (Univ.level_subst_of f) in + let rec aux t = + match kind t with + | Sort (Sorts.Type u) -> + let u' = fu u in + if u' == u then t else + (changed := true; mkSort (Sorts.sort_of_univ u')) + | Const (c, u) -> + let u' = fi u in + if u' == u then t + else (changed := true; mkConstU (c, u')) + | Ind (i, u) -> + let u' = fi u in + if u' == u then t + else (changed := true; mkIndU (i, u')) + | Construct (c, u) -> + let u' = fi u in + if u' == u then t + else (changed := true; mkConstructU (c, u')) + | _ -> map aux t + in + let c' = aux c in + if !changed then c' else c + +let subst_univs_constr subst c = + if Univ.is_empty_subst subst then c + else + let f = Univ.make_subst subst in + subst_univs_fn_constr f c + +(* let subst_univs_constr_key = Profile.declare_profile "subst_univs_constr" *) +(* let subst_univs_constr = Profile.profile2 subst_univs_constr_key subst_univs_constr *) + +let subst_univs_level_constr subst c = + if Univ.is_empty_level_subst subst then c + else + let f = Univ.Instance.subst_fn (Univ.subst_univs_level_level subst) in + let changed = ref false in + let rec aux t = + match kind t with + | Const (c, u) -> + if Univ.Instance.is_empty u then t + else + let u' = f u in + if u' == u then t + else (changed := true; mkConstU (c, u')) + | Ind (i, u) -> + if Univ.Instance.is_empty u then t + else + let u' = f u in + if u' == u then t + else (changed := true; mkIndU (i, u')) + | Construct (c, u) -> + if Univ.Instance.is_empty u then t + else + let u' = f u in + if u' == u then t + else (changed := true; mkConstructU (c, u')) + | Sort (Sorts.Type u) -> + let u' = Univ.subst_univs_level_universe subst u in + if u' == u then t else + (changed := true; mkSort (Sorts.sort_of_univ u')) + | _ -> Constr.map aux t + in + let c' = aux c in + if !changed then c' else c + +let subst_univs_context s = + map_rel_context (subst_univs_constr s) diff --git a/kernel/vars.mli b/kernel/vars.mli index ef3381ab5..9d5d16d0c 100644 --- a/kernel/vars.mli +++ b/kernel/vars.mli @@ -68,3 +68,17 @@ val subst_vars : Id.t list -> constr -> constr (** [substn_vars n [id1;...;idn] t] substitute [VAR idj] by [Rel j+n-1] in [t] if two names are identical, the one of least indice is kept *) val substn_vars : int -> Id.t list -> constr -> constr + +(** {3 Substitution of universes} *) + +open Univ + +val subst_univs_fn_constr : universe_subst_fn -> constr -> constr +val subst_univs_fn_puniverses : universe_level_subst_fn -> + 'a puniverses -> 'a puniverses + +val subst_univs_constr : universe_subst -> constr -> constr +val subst_univs_puniverses : universe_level_subst -> 'a puniverses -> 'a puniverses +val subst_univs_level_constr : universe_level_subst -> constr -> constr + +val subst_univs_context : Univ.universe_subst -> rel_context -> rel_context diff --git a/kernel/vconv.ml b/kernel/vconv.ml index 484ee2a50..62ddeb182 100644 --- a/kernel/vconv.ml +++ b/kernel/vconv.ml @@ -42,13 +42,15 @@ let conv_vect fconv vect1 vect2 cu = let infos = ref (create_clos_infos betaiotazeta Environ.empty_env) +let eq_table_key = Names.eq_table_key eq_constant + let rec conv_val pb k v1 v2 cu = if v1 == v2 then cu else conv_whd pb k (whd_val v1) (whd_val v2) cu and conv_whd pb k whd1 whd2 cu = match whd1, whd2 with - | Vsort s1, Vsort s2 -> sort_cmp pb s1 s2 cu + | Vsort s1, Vsort s2 -> ignore(sort_cmp_universes pb s1 s2 (cu,None)); cu | Vprod p1, Vprod p2 -> let cu = conv_val CONV k (dom p1) (dom p2) cu in conv_fun pb k (codom p1) (codom p2) cu @@ -169,6 +171,13 @@ and conv_arguments k args1 args2 cu = !rcu else raise NotConvertible +let rec eq_puniverses f (x,l1) (y,l2) cu = + if f x y then conv_universes l1 l2 cu + else raise NotConvertible + +and conv_universes l1 l2 cu = + if Univ.Instance.eq l1 l2 then cu else raise NotConvertible + let rec conv_eq pb t1 t2 cu = if t1 == t2 then cu else @@ -179,7 +188,7 @@ let rec conv_eq pb t1 t2 cu = if Int.equal m1 m2 then cu else raise NotConvertible | Var id1, Var id2 -> if Id.equal id1 id2 then cu else raise NotConvertible - | Sort s1, Sort s2 -> sort_cmp pb s1 s2 cu + | Sort s1, Sort s2 -> ignore(sort_cmp_universes pb s1 s2 (cu,None)); cu | Cast (c1,_,_), _ -> conv_eq pb c1 t2 cu | _, Cast (c2,_,_) -> conv_eq pb t1 c2 cu | Prod (_,t1,c1), Prod (_,t2,c2) -> @@ -192,12 +201,13 @@ let rec conv_eq pb t1 t2 cu = | Evar (e1,l1), Evar (e2,l2) -> if Evar.equal e1 e2 then conv_eq_vect l1 l2 cu else raise NotConvertible - | Const c1, Const c2 -> - if eq_constant c1 c2 then cu else raise NotConvertible + | Const c1, Const c2 -> eq_puniverses eq_constant c1 c2 cu + | Proj (p1,c1), Proj (p2,c2) -> + if eq_constant p1 p2 then conv_eq pb c1 c2 cu else raise NotConvertible | Ind c1, Ind c2 -> - if eq_ind c1 c2 then cu else raise NotConvertible + eq_puniverses eq_ind c1 c2 cu | Construct c1, Construct c2 -> - if eq_constructor c1 c2 then cu else raise NotConvertible + eq_puniverses eq_constructor c1 c2 cu | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) -> let pcu = conv_eq CONV p1 p2 cu in let ccu = conv_eq CONV c1 c2 pcu in @@ -221,14 +231,14 @@ and conv_eq_vect vt1 vt2 cu = let vconv pb env t1 t2 = infos := create_clos_infos betaiotazeta env; - let cu = - try conv_eq pb t1 t2 empty_constraint + let _cu = + try conv_eq pb t1 t2 (universes env) with NotConvertible -> let v1 = val_of_constr env t1 in let v2 = val_of_constr env t2 in - let cu = conv_val pb (nb_rel env) v1 v2 empty_constraint in + let cu = conv_val pb (nb_rel env) v1 v2 (universes env) in cu - in cu + in () let _ = Reduction.set_vm_conv vconv diff --git a/lia.cache b/lia.cache Binary files differnew file mode 100644 index 000000000..b878cf355 --- /dev/null +++ b/lia.cache diff --git a/lib/cList.ml b/lib/cList.ml index 36dad3235..93ba0637e 100644 --- a/lib/cList.ml +++ b/lib/cList.ml @@ -479,14 +479,14 @@ let rec find_map f = function let uniquize l = let visited = Hashtbl.create 23 in - let rec aux acc = function - | h::t -> if Hashtbl.mem visited h then aux acc t else + let rec aux acc changed = function + | h::t -> if Hashtbl.mem visited h then aux acc true t else begin Hashtbl.add visited h h; - aux (h::acc) t + aux (h::acc) changed t end - | [] -> List.rev acc - in aux [] l + | [] -> if changed then List.rev acc else l + in aux [] false l (** [sort_uniquize] might be an alternative to the hashtbl-based [uniquize], when the order of the elements is irrelevant *) diff --git a/lib/cList.mli b/lib/cList.mli index 15900260c..01ae83960 100644 --- a/lib/cList.mli +++ b/lib/cList.mli @@ -127,7 +127,8 @@ sig there is none. *) val uniquize : 'a list -> 'a list - (** Return the list of elements without duplicates. *) + (** Return the list of elements without duplicates. + This is the list unchanged if there was none. *) val sort_uniquize : 'a cmp -> 'a list -> 'a list (** Return a sorted and de-duplicated version of a list, diff --git a/lib/flags.ml b/lib/flags.ml index 9b932946c..530617b0c 100644 --- a/lib/flags.ml +++ b/lib/flags.ml @@ -60,6 +60,8 @@ let async_proofs_is_worker () = let debug = ref false +let profile = false + let print_emacs = ref false let term_quality = ref false @@ -134,6 +136,21 @@ let auto_intros = ref true let make_auto_intros flag = auto_intros := flag let is_auto_intros () = version_strictly_greater V8_2 && !auto_intros +let universe_polymorphism = ref false +let make_universe_polymorphism b = universe_polymorphism := b +let is_universe_polymorphism () = !universe_polymorphism + +let local_polymorphic_flag = ref None +let use_polymorphic_flag () = + match !local_polymorphic_flag with + | Some p -> local_polymorphic_flag := None; p + | None -> is_universe_polymorphism () +let make_polymorphic_flag b = + local_polymorphic_flag := Some b + +(** [program_mode] tells that Program mode has been activated, either + globally via [Set Program] or locally via the Program command prefix. *) + let program_mode = ref false let is_program_mode () = !program_mode diff --git a/lib/flags.mli b/lib/flags.mli index ebd11ee77..57e31394e 100644 --- a/lib/flags.mli +++ b/lib/flags.mli @@ -24,6 +24,8 @@ val async_proofs_is_worker : unit -> bool val debug : bool ref +val profile : bool + val print_emacs : bool ref val term_quality : bool ref @@ -72,6 +74,14 @@ val is_term_color : unit -> bool val program_mode : bool ref val is_program_mode : unit -> bool +(** Global universe polymorphism flag. *) +val make_universe_polymorphism : bool -> unit +val is_universe_polymorphism : unit -> bool + +(** Local universe polymorphism flag. *) +val make_polymorphic_flag : bool -> unit +val use_polymorphic_flag : unit -> bool + val make_warn : bool -> unit val if_warn : ('a -> unit) -> 'a -> unit diff --git a/lib/profile.ml b/lib/profile.ml index 6a1b45a39..798f895fa 100644 --- a/lib/profile.ml +++ b/lib/profile.ml @@ -657,6 +657,48 @@ let profile7 e f a b c d g h i = last_alloc := get_alloc (); raise reraise +let profile8 e f a b c d g h i j = + let dw = spent_alloc () in + match !stack with [] -> assert false | p::_ -> + (* We add spent alloc since last measure to current caller own/total alloc *) + ajoute_ownalloc p dw; + ajoute_totalloc p dw; + e.owncount <- e.owncount + 1; + if not (p==e) then stack := e::!stack; + let totalloc0 = e.totalloc in + let intcount0 = e.intcount in + let t = get_time () in + try + last_alloc := get_alloc (); + let r = f a b c d g h i j in + let dw = spent_alloc () in + let dt = get_time () - t in + e.tottime <- e.tottime + dt; e.owntime <- e.owntime + dt; + ajoute_ownalloc e dw; + ajoute_totalloc e dw; + p.owntime <- p.owntime - dt; + ajoute_totalloc p (e.totalloc -. totalloc0); + p.intcount <- p.intcount + e.intcount - intcount0 + 1; + p.immcount <- p.immcount + 1; + if not (p==e) then + (match !stack with [] -> assert false | _::s -> stack := s); + last_alloc := get_alloc (); + r + with reraise -> + let dw = spent_alloc () in + let dt = get_time () - t in + e.tottime <- e.tottime + dt; e.owntime <- e.owntime + dt; + ajoute_ownalloc e dw; + ajoute_totalloc e dw; + p.owntime <- p.owntime - dt; + ajoute_totalloc p (e.totalloc -. totalloc0); + p.intcount <- p.intcount + e.intcount - intcount0 + 1; + p.immcount <- p.immcount + 1; + if not (p==e) then + (match !stack with [] -> assert false | _::s -> stack := s); + last_alloc := get_alloc (); + raise reraise + let print_logical_stats a = let (c, s, d) = CObj.obj_stats a in Printf.printf "Expanded size: %10d (str: %8d) Depth: %6d\n" (s+c) c d diff --git a/lib/profile.mli b/lib/profile.mli index 812fd8b1e..a7d9cabe5 100644 --- a/lib/profile.mli +++ b/lib/profile.mli @@ -100,6 +100,10 @@ val profile7 : profile_key -> ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h) -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h +val profile8 : + profile_key -> + ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h -> 'i) + -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h -> 'i (** Some utilities to compute the logical and physical sizes and depth diff --git a/library/assumptions.ml b/library/assumptions.ml index b1f133ac3..9cfe531ce 100644 --- a/library/assumptions.ml +++ b/library/assumptions.ml @@ -204,7 +204,7 @@ let assumptions ?(add_opaque=false) ?(add_transparent=false) st (* t *) = | Case (_,e1,e2,e_array) -> (iter e1)**(iter e2)**(iter_array e_array) | Fix (_,(_, e1_array, e2_array)) | CoFix (_,(_,e1_array, e2_array)) -> (iter_array e1_array) ** (iter_array e2_array) - | Const kn -> do_memoize_kn kn + | Const (kn,_) -> do_memoize_kn kn | _ -> identity2 (* closed atomic types + rel *) and iter_array a = Array.fold_right (fun e f -> (iter e)**f) a identity2 in iter t s acc @@ -222,11 +222,7 @@ let assumptions ?(add_opaque=false) ?(add_transparent=false) st (* t *) = and add_kn kn s acc = let cb = lookup_constant kn in let do_type cst = - let ctype = - match cb.Declarations.const_type with - | PolymorphicArity (ctx,a) -> mkArity (ctx, Type a.poly_level) - | NonPolymorphicType t -> t - in + let ctype = cb.Declarations.const_type in (s,ContextObjectMap.add cst ctype acc) in let (s,acc) = diff --git a/library/declare.ml b/library/declare.ml index c0c4dd571..452504bf0 100644 --- a/library/declare.ml +++ b/library/declare.ml @@ -44,36 +44,40 @@ let if_xml f x = if !Flags.xml_export then f x else () type section_variable_entry = | SectionLocalDef of definition_entry - | SectionLocalAssum of types * bool (* Implicit status *) + | SectionLocalAssum of types Univ.in_universe_context_set * polymorphic * bool (** Implicit status *) type variable_declaration = DirPath.t * section_variable_entry * logical_kind let cache_variable ((sp,_),o) = match o with - | Inl cst -> Global.add_constraints cst + | Inl ctx -> Global.push_context_set ctx | Inr (id,(p,d,mk)) -> (* Constr raisonne sur les noms courts *) if variable_exists id then alreadydeclared (pr_id id ++ str " already exists"); - let impl,opaq,cst = match d with (* Fails if not well-typed *) - | SectionLocalAssum (ty, impl) -> - let cst = Global.push_named_assum (id,ty) in - let impl = if impl then Implicit else Explicit in - impl, true, cst - | SectionLocalDef de -> - let cst = Global.push_named_def (id,de) in - Explicit, de.const_entry_opaque, cst in + + let impl,opaq,poly,ctx = match d with (* Fails if not well-typed *) + | SectionLocalAssum ((ty,ctx),poly,impl) -> + let () = Global.push_named_assum ((id,ty),ctx) in + let impl = if impl then Implicit else Explicit in + impl, true, poly, ctx + | SectionLocalDef (de) -> + let () = Global.push_named_def (id,de) in + Explicit, de.const_entry_opaque, de.const_entry_polymorphic, + (Univ.ContextSet.of_context de.const_entry_universes) in Nametab.push (Nametab.Until 1) (restrict_path 0 sp) (VarRef id); - add_section_variable id impl; + add_section_variable id impl poly ctx; Dischargedhypsmap.set_discharged_hyps sp []; - add_variable_data id (p,opaq,cst,mk) + add_variable_data id (p,opaq,ctx,poly,mk) let discharge_variable (_,o) = match o with - | Inr (id,_) -> Some (Inl (variable_constraints id)) + | Inr (id,_) -> + if variable_polymorphic id then None + else Some (Inl (variable_context id)) | Inl _ -> Some o type variable_obj = - (Univ.constraints, Id.t * variable_declaration) union + (Univ.ContextSet.t, Id.t * variable_declaration) union let inVariable : variable_obj -> obj = declare_object { (default_object "VARIABLE") with @@ -139,7 +143,8 @@ let cache_constant ((sp,kn), obj) = let kn' = Global.add_constant dir id obj.cst_decl in assert (eq_constant kn' (constant_of_kn kn)); Nametab.push (Nametab.Until 1) sp (ConstRef (constant_of_kn kn)); - add_section_constant kn' (Global.lookup_constant kn').const_hyps; + let cst = Global.lookup_constant kn' in + add_section_constant (cst.const_proj <> None) kn' cst.const_hyps; Dischargedhypsmap.set_discharged_hyps sp obj.cst_hyps; add_constant_kind (constant_of_kn kn) obj.cst_kind @@ -150,16 +155,18 @@ let discharged_hyps kn sechyps = let discharge_constant ((sp, kn), obj) = let con = constant_of_kn kn in + let from = Global.lookup_constant con in let modlist = replacement_context () in - let hyps = section_segment_of_constant con in + let hyps,uctx = section_segment_of_constant con in let new_hyps = (discharged_hyps kn hyps) @ obj.cst_hyps in - let abstract = named_of_variable_context hyps in + let abstract = (named_of_variable_context hyps, uctx) in let new_decl = GlobalRecipe{ from; info = { Opaqueproof.modlist; abstract}} in Some { obj with cst_hyps = new_hyps; cst_decl = new_decl; } (* Hack to reduce the size of .vo: we keep only what load/open needs *) -let dummy_constant_entry = ConstantEntry (ParameterEntry (None,mkProp,None)) +let dummy_constant_entry = + ConstantEntry (ParameterEntry (None,false,(mkProp,Univ.UContext.empty),None)) let dummy_constant cst = { cst_decl = dummy_constant_entry; @@ -187,6 +194,18 @@ let declare_constant_common id cst = Notation.declare_ref_arguments_scope (ConstRef c); c +let definition_entry ?(opaque=false) ?types + ?(poly=false) ?(univs=Univ.UContext.empty) body = + { const_entry_body = Future.from_val (body,Declareops.no_seff); + const_entry_secctx = None; + const_entry_type = types; + const_entry_proj = None; + const_entry_polymorphic = poly; + const_entry_universes = univs; + const_entry_opaque = opaque; + const_entry_feedback = None; + const_entry_inline_code = false} + let declare_scheme = ref (fun _ _ -> assert false) let set_declare_scheme f = declare_scheme := f let declare_sideff se = @@ -203,8 +222,7 @@ let declare_sideff se = in let ty_of cb = match cb.Declarations.const_type with - | Declarations.NonPolymorphicType t -> Some t - | _ -> None in + | (* Declarations.NonPolymorphicType *)t -> Some t in let cst_of cb = let pt, opaque = pt_opaque_of cb in let ty = ty_of cb in @@ -215,6 +233,9 @@ let declare_sideff se = const_entry_opaque = opaque; const_entry_inline_code = false; const_entry_feedback = None; + const_entry_polymorphic = cb.const_polymorphic; + const_entry_universes = Future.join cb.const_universes; + const_entry_proj = None; }); cst_hyps = [] ; cst_kind = Decl_kinds.IsDefinition Decl_kinds.Definition; @@ -252,16 +273,11 @@ let declare_constant ?(internal = UserVerbose) ?(local = false) id (cd, kind) = let () = if_xml (Hook.get f_xml_declare_constant) (internal, kn) in kn -let declare_definition ?(internal=UserVerbose) +let declare_definition ?(internal=UserVerbose) ?(opaque=false) ?(kind=Decl_kinds.Definition) ?(local = false) - id ?types body = + ?(poly=false) id ?types (body,ctx) = let cb = - { Entries.const_entry_body = body; - const_entry_type = types; - const_entry_opaque = opaque; - const_entry_inline_code = false; - const_entry_secctx = None; - const_entry_feedback = None } + definition_entry ?types ~poly ~univs:(Univ.ContextSet.to_context ctx) ~opaque body in declare_constant ~internal ~local id (Entries.DefinitionEntry cb, Decl_kinds.IsDefinition kind) @@ -311,7 +327,8 @@ let cache_inductive ((sp,kn),(dhyps,mie)) = let _,dir,_ = repr_kn kn in let kn' = Global.add_mind dir id mie in assert (eq_mind kn' (mind_of_kn kn)); - add_section_kn kn' (Global.lookup_mind kn').mind_hyps; + let mind = Global.lookup_mind kn' in + add_section_kn kn' mind.mind_hyps; Dischargedhypsmap.set_discharged_hyps sp dhyps; List.iter (fun (sp, ref) -> Nametab.push (Nametab.Until 1) sp ref) names @@ -319,9 +336,9 @@ let discharge_inductive ((sp,kn),(dhyps,mie)) = let mind = Global.mind_of_delta_kn kn in let mie = Global.lookup_mind mind in let repl = replacement_context () in - let sechyps = section_segment_of_mutual_inductive mind in + let sechyps,uctx = section_segment_of_mutual_inductive mind in Some (discharged_hyps kn sechyps, - Discharge.process_inductive (named_of_variable_context sechyps) repl mie) + Discharge.process_inductive (named_of_variable_context sechyps,uctx) repl mie) let dummy_one_inductive_entry mie = { mind_entry_typename = mie.mind_entry_typename; @@ -335,7 +352,9 @@ let dummy_inductive_entry (_,m) = ([],{ mind_entry_params = []; mind_entry_record = false; mind_entry_finite = true; - mind_entry_inds = List.map dummy_one_inductive_entry m.mind_entry_inds }) + mind_entry_inds = List.map dummy_one_inductive_entry m.mind_entry_inds; + mind_entry_polymorphic = false; + mind_entry_universes = Univ.UContext.empty }) type inductive_obj = Dischargedhypsmap.discharged_hyps * mutual_inductive_entry diff --git a/library/declare.mli b/library/declare.mli index 663d240dc..848bab618 100644 --- a/library/declare.mli +++ b/library/declare.mli @@ -23,7 +23,7 @@ open Decl_kinds type section_variable_entry = | SectionLocalDef of definition_entry - | SectionLocalAssum of types * bool (** Implicit status *) + | SectionLocalAssum of types Univ.in_universe_context_set * polymorphic * bool (** Implicit status *) type variable_declaration = DirPath.t * section_variable_entry * logical_kind @@ -47,12 +47,18 @@ type internal_flag = | KernelSilent | UserVerbose +(* Defaut definition entries, transparent with no secctx or proj information *) +val definition_entry : ?opaque:bool -> ?types:types -> + ?poly:polymorphic -> ?univs:Univ.universe_context -> + constr -> definition_entry + val declare_constant : ?internal:internal_flag -> ?local:bool -> Id.t -> constant_declaration -> constant val declare_definition : ?internal:internal_flag -> ?opaque:bool -> ?kind:definition_object_kind -> - ?local:bool -> Id.t -> ?types:constr -> Entries.const_entry_body -> constant + ?local:bool -> ?poly:polymorphic -> Id.t -> ?types:constr -> + constr Univ.in_universe_context_set -> constant (** Since transparent constant's side effects are globally declared, we * need that *) diff --git a/library/decls.ml b/library/decls.ml index 2d8807f80..811d09667 100644 --- a/library/decls.ml +++ b/library/decls.ml @@ -18,17 +18,18 @@ open Libnames (** Datas associated to section variables and local definitions *) type variable_data = - DirPath.t * bool (* opacity *) * Univ.constraints * logical_kind + DirPath.t * bool (* opacity *) * Univ.universe_context_set * polymorphic * logical_kind let vartab = Summary.ref (Id.Map.empty : variable_data Id.Map.t) ~name:"VARIABLE" let add_variable_data id o = vartab := Id.Map.add id o !vartab -let variable_path id = let (p,_,_,_) = Id.Map.find id !vartab in p -let variable_opacity id = let (_,opaq,_,_) = Id.Map.find id !vartab in opaq -let variable_kind id = let (_,_,_,k) = Id.Map.find id !vartab in k -let variable_constraints id = let (_,_,cst,_) = Id.Map.find id !vartab in cst +let variable_path id = let (p,_,_,_,_) = Id.Map.find id !vartab in p +let variable_opacity id = let (_,opaq,_,_,_) = Id.Map.find id !vartab in opaq +let variable_kind id = let (_,_,_,_,k) = Id.Map.find id !vartab in k +let variable_context id = let (_,_,ctx,_,_) = Id.Map.find id !vartab in ctx +let variable_polymorphic id = let (_,_,_,p,_) = Id.Map.find id !vartab in p let variable_secpath id = let dir = drop_dirpath_prefix (Lib.library_dp()) (variable_path id) in diff --git a/library/decls.mli b/library/decls.mli index f45e4f121..6e9d4a4ab 100644 --- a/library/decls.mli +++ b/library/decls.mli @@ -17,14 +17,15 @@ open Decl_kinds (** Registration and access to the table of variable *) type variable_data = - DirPath.t * bool (** opacity *) * Univ.constraints * logical_kind + DirPath.t * bool (** opacity *) * Univ.universe_context_set * polymorphic * logical_kind val add_variable_data : variable -> variable_data -> unit val variable_path : variable -> DirPath.t val variable_secpath : variable -> qualid val variable_kind : variable -> logical_kind val variable_opacity : variable -> bool -val variable_constraints : variable -> Univ.constraints +val variable_context : variable -> Univ.universe_context_set +val variable_polymorphic : variable -> polymorphic val variable_exists : variable -> bool (** Registration and access to the table of constants *) diff --git a/library/global.ml b/library/global.ml index a8121d15f..c56bc9e77 100644 --- a/library/global.ml +++ b/library/global.ml @@ -70,9 +70,12 @@ let globalize_with_summary fs f = let i2l = Label.of_id -let push_named_assum a = globalize (Safe_typing.push_named_assum a) -let push_named_def d = globalize (Safe_typing.push_named_def d) +let push_named_assum a = globalize0 (Safe_typing.push_named_assum a) +let push_named_def d = globalize0 (Safe_typing.push_named_def d) let add_constraints c = globalize0 (Safe_typing.add_constraints c) +let push_context_set c = globalize0 (Safe_typing.push_context_set c) +let push_context c = globalize0 (Safe_typing.push_context c) + let set_engagement c = globalize0 (Safe_typing.set_engagement c) let add_constant dir id d = globalize (Safe_typing.add_constant dir (i2l id) d) let add_mind dir id mie = globalize (Safe_typing.add_mind dir (i2l id) mie) @@ -101,6 +104,7 @@ let named_context_val () = named_context_val (env()) let lookup_named id = lookup_named id (env()) let lookup_constant kn = lookup_constant kn (env()) let lookup_inductive ind = Inductive.lookup_mind_specif (env()) ind +let lookup_pinductive (ind,_) = Inductive.lookup_mind_specif (env()) ind let lookup_mind kn = lookup_mind kn (env()) let lookup_module mp = lookup_module mp (env()) @@ -139,19 +143,43 @@ let env_of_context hyps = open Globnames -let type_of_reference env = function +(** Build a fresh instance for a given context, its associated substitution and + the instantiated constraints. *) + +let type_of_global_unsafe r = + let env = env() in + match r with | VarRef id -> Environ.named_type id env - | ConstRef c -> Typeops.type_of_constant env c + | ConstRef c -> + let cb = Environ.lookup_constant c env in cb.Declarations.const_type + | IndRef ind -> + let (mib, oib) = Inductive.lookup_mind_specif env ind in + oib.Declarations.mind_arity.Declarations.mind_user_arity + | ConstructRef cstr -> + let (mib,oib as specif) = Inductive.lookup_mind_specif env (inductive_of_constructor cstr) in + let inst = Univ.UContext.instance mib.Declarations.mind_universes in + Inductive.type_of_constructor (cstr,inst) specif + + +let is_polymorphic r = + let env = env() in + match r with + | VarRef id -> false + | ConstRef c -> + let cb = Environ.lookup_constant c env in cb.Declarations.const_polymorphic | IndRef ind -> - let specif = Inductive.lookup_mind_specif env ind in - Inductive.type_of_inductive env specif + let (mib, oib) = Inductive.lookup_mind_specif env ind in + mib.Declarations.mind_polymorphic | ConstructRef cstr -> - let specif = - Inductive.lookup_mind_specif env (inductive_of_constructor cstr) in - Inductive.type_of_constructor cstr specif + let (mib,oib as specif) = Inductive.lookup_mind_specif env (inductive_of_constructor cstr) in + mib.Declarations.mind_polymorphic -let type_of_global t = type_of_reference (env ()) t +let current_dirpath () = + Safe_typing.current_dirpath (safe_env ()) +let with_global f = + let (a, ctx) = f (env ()) (current_dirpath ()) in + push_context_set ctx; a (* spiwack: register/unregister functions for retroknowledge *) let register field value by_clause = diff --git a/library/global.mli b/library/global.mli index e11e1c017..b6825ffa5 100644 --- a/library/global.mli +++ b/library/global.mli @@ -33,13 +33,19 @@ val add_constraints : Univ.constraints -> unit (** Variables, Local definitions, constants, inductive types *) -val push_named_assum : (Id.t * Term.types) -> Univ.constraints -val push_named_def : (Id.t * Entries.definition_entry) -> Univ.constraints +val push_named_assum : (Id.t * Constr.types) Univ.in_universe_context_set -> unit +val push_named_def : (Id.t * Entries.definition_entry) -> unit + val add_constant : DirPath.t -> Id.t -> Safe_typing.global_declaration -> constant val add_mind : DirPath.t -> Id.t -> Entries.mutual_inductive_entry -> mutual_inductive +val add_constraints : Univ.constraints -> unit + +val push_context : Univ.universe_context -> unit +val push_context_set : Univ.universe_context_set -> unit + (** Non-interactive modules and module types *) val add_module : @@ -72,6 +78,8 @@ val lookup_named : variable -> Context.named_declaration val lookup_constant : constant -> Declarations.constant_body val lookup_inductive : inductive -> Declarations.mutual_inductive_body * Declarations.one_inductive_body +val lookup_pinductive : Constr.pinductive -> + Declarations.mutual_inductive_body * Declarations.one_inductive_body val lookup_mind : mutual_inductive -> Declarations.mutual_inductive_body val lookup_module : module_path -> Declarations.module_body val lookup_modtype : module_path -> Declarations.module_type_body @@ -94,11 +102,14 @@ val import : (** Function to get an environment from the constants part of the global * environment and a given context. *) -val type_of_global : Globnames.global_reference -> Term.types val env_of_context : Environ.named_context_val -> Environ.env val join_safe_environment : unit -> unit +val is_polymorphic : Globnames.global_reference -> bool + +(* val type_of_global : Globnames.global_reference -> types Univ.in_universe_context_set *) +val type_of_global_unsafe : Globnames.global_reference -> Constr.types (** {6 Retroknowledge } *) @@ -109,5 +120,10 @@ val register_inline : constant -> unit (** {6 Oracle } *) -val set_strategy : 'a Names.tableKey -> Conv_oracle.level -> unit +val set_strategy : Names.constant Names.tableKey -> Conv_oracle.level -> unit + +(* Modifies the global state, registering new universes *) + +val current_dirpath : unit -> Names.dir_path +val with_global : (Environ.env -> Names.dir_path -> 'a Univ.in_universe_context_set) -> 'a diff --git a/library/globnames.ml b/library/globnames.ml index 8a9e99621..c881e797e 100644 --- a/library/globnames.ml +++ b/library/globnames.ml @@ -38,19 +38,31 @@ let destConstRef = function ConstRef ind -> ind | _ -> failwith "destConstRef" let destIndRef = function IndRef ind -> ind | _ -> failwith "destIndRef" let destConstructRef = function ConstructRef ind -> ind | _ -> failwith "destConstructRef" -let subst_constructor subst ((kn,i),j as ref) = - let kn' = subst_ind subst kn in - if kn==kn' then ref, mkConstruct ref - else ((kn',i),j), mkConstruct ((kn',i),j) +let subst_constructor subst (ind,j as ref) = + let ind' = subst_ind subst ind in + if ind==ind' then ref, mkConstruct ref + else (ind',j), mkConstruct (ind',j) + +let subst_global_reference subst ref = match ref with + | VarRef var -> ref + | ConstRef kn -> + let kn' = subst_constant subst kn in + if kn==kn' then ref else ConstRef kn' + | IndRef ind -> + let ind' = subst_ind subst ind in + if ind==ind' then ref else IndRef ind' + | ConstructRef ((kn,i),j as c) -> + let c',t = subst_constructor subst c in + if c'==c then ref else ConstructRef c' let subst_global subst ref = match ref with | VarRef var -> ref, mkVar var | ConstRef kn -> - let kn',t = subst_con subst kn in + let kn',t = subst_con_kn subst kn in if kn==kn' then ref, mkConst kn else ConstRef kn', t - | IndRef (kn,i) -> - let kn' = subst_ind subst kn in - if kn==kn' then ref, mkInd (kn,i) else IndRef(kn',i), mkInd (kn',i) + | IndRef ind -> + let ind' = subst_ind subst ind in + if ind==ind' then ref, mkInd ind else IndRef ind', mkInd ind' | ConstructRef ((kn,i),j as c) -> let c',t = subst_constructor subst c in if c'==c then ref,t else ConstructRef c', t @@ -62,19 +74,26 @@ let canonical_gr = function | VarRef id -> VarRef id let global_of_constr c = match kind_of_term c with - | Const sp -> ConstRef sp - | Ind ind_sp -> IndRef ind_sp - | Construct cstr_cp -> ConstructRef cstr_cp + | Const (sp,u) -> ConstRef sp + | Ind (ind_sp,u) -> IndRef ind_sp + | Construct (cstr_cp,u) -> ConstructRef cstr_cp | Var id -> VarRef id | _ -> raise Not_found -let constr_of_global = function +let is_global c t = + match c, kind_of_term t with + | ConstRef c, Const (c', _) -> eq_constant c c' + | IndRef i, Ind (i', _) -> eq_ind i i' + | ConstructRef i, Construct (i', _) -> eq_constructor i i' + | VarRef id, Var id' -> id_eq id id' + | _ -> false + +let printable_constr_of_global = function | VarRef id -> mkVar id | ConstRef sp -> mkConst sp | ConstructRef sp -> mkConstruct sp | IndRef sp -> mkInd sp -let constr_of_reference = constr_of_global let reference_of_constr = global_of_constr let global_eq_gen eq_cst eq_ind eq_cons x y = @@ -179,10 +198,6 @@ type global_reference_or_constr = | IsGlobal of global_reference | IsConstr of constr -let constr_of_global_or_constr = function - | IsConstr c -> c - | IsGlobal gr -> constr_of_global gr - (** {6 Temporary function to brutally form kernel names from section paths } *) let encode_mind dir id = MutInd.make2 (MPfile dir) (Label.of_id id) diff --git a/library/globnames.mli b/library/globnames.mli index 5d717965e..5ea0c9de0 100644 --- a/library/globnames.mli +++ b/library/globnames.mli @@ -31,19 +31,21 @@ val destConstRef : global_reference -> constant val destIndRef : global_reference -> inductive val destConstructRef : global_reference -> constructor +val is_global : global_reference -> constr -> bool val subst_constructor : substitution -> constructor -> constructor * constr val subst_global : substitution -> global_reference -> global_reference * constr +val subst_global_reference : substitution -> global_reference -> global_reference -(** Turn a global reference into a construction *) -val constr_of_global : global_reference -> constr +(** This constr is not safe to be typechecked, universe polymorphism is not + handled here: just use for printing *) +val printable_constr_of_global : global_reference -> constr (** Turn a construction denoting a global reference into a global reference; raise [Not_found] if not a global reference *) val global_of_constr : constr -> global_reference (** Obsolete synonyms for constr_of_global and global_of_constr *) -val constr_of_reference : global_reference -> constr val reference_of_constr : constr -> global_reference module RefOrdered : sig @@ -87,8 +89,6 @@ type global_reference_or_constr = | IsGlobal of global_reference | IsConstr of constr -val constr_of_global_or_constr : global_reference_or_constr -> constr - (** {6 Temporary function to brutally form kernel names from section paths } *) val encode_mind : DirPath.t -> Id.t -> mutual_inductive diff --git a/library/heads.ml b/library/heads.ml index f64cdb05a..0faad827e 100644 --- a/library/heads.ml +++ b/library/heads.ml @@ -58,7 +58,7 @@ let variable_head id = Evalrefmap.find (EvalVarRef id) !head_map let constant_head cst = Evalrefmap.find (EvalConstRef cst) !head_map let kind_of_head env t = - let rec aux k l t b = match kind_of_term (Reduction.whd_betaiotazeta t) with + let rec aux k l t b = match kind_of_term (Reduction.whd_betaiotazeta env t) with | Rel n when n > k -> NotImmediatelyComputableHead | Rel n -> FlexibleHead (k,k+1-n,List.length l,b) | Var id -> @@ -68,7 +68,7 @@ let kind_of_head env t = match pi2 (lookup_named id env) with | Some c -> aux k l c b | None -> NotImmediatelyComputableHead) - | Const cst -> + | Const (cst,_) -> (try on_subterm k l b (constant_head cst) with Not_found -> assert false) | Construct _ | CoFix _ -> @@ -85,6 +85,10 @@ let kind_of_head env t = | LetIn _ -> assert false | Meta _ | Evar _ -> NotImmediatelyComputableHead | App (c,al) -> aux k (Array.to_list al @ l) c b + | Proj (p,c) -> + (try on_subterm k (c :: l) b (constant_head p) + with Not_found -> assert false) + | Case (_,_,c,_) -> aux k [] c true | Fix ((i,j),_) -> let n = i.(j) in @@ -113,11 +117,18 @@ let kind_of_head env t = | x -> x in aux 0 [] t false +(* FIXME: maybe change interface here *) let compute_head = function | EvalConstRef cst -> - (match constant_opt_value (Global.env()) cst with + let env = Global.env() in + let cb = Environ.lookup_constant cst env in + let body = + if cb.Declarations.const_proj = None + then Declareops.body_of_constant cb else None + in + (match body with | None -> RigidHead (RigidParameter cst) - | Some c -> kind_of_head (Global.env()) c) + | Some c -> kind_of_head env c) | EvalVarRef id -> (match pi2 (Global.lookup_named id) with | Some c when not (Decls.variable_opacity id) -> @@ -140,8 +151,8 @@ let cache_head o = let subst_head_approximation subst = function | RigidHead (RigidParameter cst) as k -> - let cst,c = subst_con subst cst in - if isConst c && eq_constant (destConst c) cst then + let cst,c = subst_con_kn subst cst in + if isConst c && eq_constant (fst (destConst c)) cst then (* A change of the prefix of the constant *) k else diff --git a/library/impargs.ml b/library/impargs.ml index 1bcff8695..5a44b5bdb 100644 --- a/library/impargs.ml +++ b/library/impargs.ml @@ -169,7 +169,7 @@ let is_flexible_reference env bound depth f = | Rel n when n >= bound+depth -> (* inductive type *) false | Rel n when n >= depth -> (* previous argument *) true | Rel n -> (* since local definitions have been expanded *) false - | Const kn -> + | Const (kn,_) -> let cb = Environ.lookup_constant kn env in (match cb.const_body with Def _ -> true | _ -> false) | Var id -> @@ -214,6 +214,7 @@ let rec is_rigid_head t = match kind_of_term t with | Rel _ | Evar _ -> false | Ind _ | Const _ | Var _ | Sort _ -> true | Case (_,_,f,_) -> is_rigid_head f + | Proj (p,c) -> true | App (f,args) -> (match kind_of_term f with | Fix ((fi,i),_) -> is_rigid_head (args.(fi.(i))) @@ -401,7 +402,14 @@ let compute_semi_auto_implicits env f manual t = let compute_constant_implicits flags manual cst = let env = Global.env () in - compute_semi_auto_implicits env flags manual (Typeops.type_of_constant env cst) + let cb = Environ.lookup_constant cst env in + let ty = cb.const_type in + let impls = compute_semi_auto_implicits env flags manual ty in + impls + (* match cb.const_proj with *) + (* | None -> impls *) + (* | Some {proj_npars = n} -> *) + (* List.map (fun (x,args) -> x, CList.skipn_at_least n args) impls *) (*s Inductives and constructors. Their implicit arguments are stored in an array, indexed by the inductive number, of pairs $(i,v)$ where @@ -413,14 +421,15 @@ let compute_mib_implicits flags manual kn = let mib = lookup_mind kn env in let ar = Array.to_list - (Array.map (* No need to lift, arities contain no de Bruijn *) - (fun mip -> - (Name mip.mind_typename, None, type_of_inductive env (mib,mip))) + (Array.mapi (* No need to lift, arities contain no de Bruijn *) + (fun i mip -> + (** No need to care about constraints here *) + (Name mip.mind_typename, None, Global.type_of_global_unsafe (IndRef (kn,i)))) mib.mind_packets) in let env_ar = push_rel_context ar env in let imps_one_inductive i mip = let ind = (kn,i) in - let ar = type_of_inductive env (mib,mip) in + let ar = Global.type_of_global_unsafe (IndRef ind) in ((IndRef ind,compute_semi_auto_implicits env flags manual ar), Array.mapi (fun j c -> (ConstructRef (ind,j+1),compute_semi_auto_implicits env_ar flags manual c)) @@ -517,7 +526,7 @@ let section_segment_of_reference = function | ConstRef con -> section_segment_of_constant con | IndRef (kn,_) | ConstructRef ((kn,_),_) -> section_segment_of_mutual_inductive kn - | _ -> [] + | _ -> [], Univ.UContext.empty let adjust_side_condition p = function | LessArgsThan n -> LessArgsThan (n+p) @@ -532,24 +541,36 @@ let discharge_implicits (_,(req,l)) = | ImplLocal -> None | ImplInteractive (ref,flags,exp) -> (try - let vars = section_segment_of_reference ref in + let vars,_ = section_segment_of_reference ref in + (* let isproj = *) + (* match ref with *) + (* | ConstRef cst -> is_projection cst (Global.env ()) *) + (* | _ -> false *) + (* in *) let ref' = if isVarRef ref then ref else pop_global_reference ref in let extra_impls = impls_of_context vars in - let l' = [ref', List.map (add_section_impls vars extra_impls) (snd (List.hd l))] in + let l' = + (* if isproj then [ref',snd (List.hd l)] *) + (* else *) + [ref', List.map (add_section_impls vars extra_impls) (snd (List.hd l))] in Some (ImplInteractive (ref',flags,exp),l') with Not_found -> (* ref not defined in this section *) Some (req,l)) | ImplConstant (con,flags) -> (try let con' = pop_con con in - let vars = section_segment_of_constant con in + let vars,_ = section_segment_of_constant con in let extra_impls = impls_of_context vars in - let l' = [ConstRef con',List.map (add_section_impls vars extra_impls) (snd (List.hd l))] in + let newimpls = + (* if is_projection con (Global.env()) then (snd (List.hd l)) *) + (* else *) List.map (add_section_impls vars extra_impls) (snd (List.hd l)) + in + let l' = [ConstRef con',newimpls] in Some (ImplConstant (con',flags),l') with Not_found -> (* con not defined in this section *) Some (req,l)) | ImplMutualInductive (kn,flags) -> (try let l' = List.map (fun (gr, l) -> - let vars = section_segment_of_reference gr in + let vars,_ = section_segment_of_reference gr in let extra_impls = impls_of_context vars in ((if isVarRef gr then gr else pop_global_reference gr), List.map (add_section_impls vars extra_impls) l)) l @@ -659,10 +680,14 @@ let check_rigidity isrigid = if not isrigid then errorlabstrm "" (strbrk "Multiple sequences of implicit arguments available only for references that cannot be applied to an arbitrarily large number of arguments.") +let projection_implicits env p (x, impls) = + let pb = Environ.lookup_projection p env in + x, CList.skipn_at_least pb.Declarations.proj_npars impls + let declare_manual_implicits local ref ?enriching l = let flags = !implicit_args in let env = Global.env () in - let t = Global.type_of_global ref in + let t = Global.type_of_global_unsafe ref in let enriching = Option.default flags.auto enriching in let isrigid,autoimpls = compute_auto_implicits env flags enriching t in let l' = match l with diff --git a/library/impargs.mli b/library/impargs.mli index e70cff838..8ad86bdff 100644 --- a/library/impargs.mli +++ b/library/impargs.mli @@ -129,6 +129,8 @@ val make_implicits_list : implicit_status list -> implicits_list list val drop_first_implicits : int -> implicits_list -> implicits_list +val projection_implicits : env -> projection -> implicits_list -> implicits_list + val select_impargs_size : int -> implicits_list list -> implicit_status list val select_stronger_impargs : implicits_list list -> implicit_status list diff --git a/library/kindops.ml b/library/kindops.ml index 6e6c7527b..b8337f5d7 100644 --- a/library/kindops.ml +++ b/library/kindops.ml @@ -24,7 +24,7 @@ let string_of_theorem_kind = function | Corollary -> "Corollary" let string_of_definition_kind def = - let (locality, kind) = def in + let (locality, poly, kind) = def in let error () = Errors.anomaly (Pp.str "Internal definition kind") in match kind with | Definition -> diff --git a/library/lib.ml b/library/lib.ml index 331196565..31f983595 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -380,11 +380,14 @@ let find_opening_node id = *) type variable_info = Names.Id.t * Decl_kinds.binding_kind * Term.constr option * Term.types + type variable_context = variable_info list -type abstr_list = variable_context Names.Cmap.t * variable_context Names.Mindmap.t +type abstr_list = variable_context Univ.in_universe_context Names.Cmap.t * + variable_context Univ.in_universe_context Names.Mindmap.t let sectab = - Summary.ref ([] : ((Names.Id.t * Decl_kinds.binding_kind) list * + Summary.ref ([] : ((Names.Id.t * Decl_kinds.binding_kind * + Decl_kinds.polymorphic * Univ.universe_context_set) list * Opaqueproof.work_list * abstr_list) list) ~name:"section-context" @@ -392,18 +395,19 @@ let add_section () = sectab := ([],(Names.Cmap.empty,Names.Mindmap.empty), (Names.Cmap.empty,Names.Mindmap.empty)) :: !sectab -let add_section_variable id impl = +let add_section_variable id impl poly ctx = match !sectab with | [] -> () (* because (Co-)Fixpoint temporarily uses local vars *) | (vars,repl,abs)::sl -> - sectab := ((id,impl)::vars,repl,abs)::sl + sectab := ((id,impl,poly,ctx)::vars,repl,abs)::sl let extract_hyps (secs,ohyps) = let rec aux = function - | ((id,impl)::idl,(id',b,t)::hyps) when Names.Id.equal id id' -> - (id',impl,b,t) :: aux (idl,hyps) + | ((id,impl,poly,ctx)::idl,(id',b,t)::hyps) when Names.Id.equal id id' -> + let l, r = aux (idl,hyps) in + (id',impl,b,t) :: l, if poly then Univ.ContextSet.union r ctx else r | (id::idl,hyps) -> aux (idl,hyps) - | [], _ -> [] + | [], _ -> [],Univ.ContextSet.empty in aux (secs,ohyps) let instance_from_variable_context sign = @@ -413,23 +417,26 @@ let instance_from_variable_context sign = | [] -> [] in Array.of_list (inst_rec sign) -let named_of_variable_context = List.map (fun (id,_,b,t) -> (id,b,t)) - +let named_of_variable_context ctx = List.map (fun (id,_,b,t) -> (id,b,t)) ctx + let add_section_replacement f g hyps = match !sectab with | [] -> () | (vars,exps,abs)::sl -> - let sechyps = extract_hyps (vars,hyps) in + let sechyps,ctx = extract_hyps (vars,hyps) in + let ctx = Univ.ContextSet.to_context ctx in let args = instance_from_variable_context (List.rev sechyps) in - sectab := (vars,f args exps,g sechyps abs)::sl + sectab := (vars,f (Univ.UContext.instance ctx,args) exps,g (sechyps,ctx) abs)::sl let add_section_kn kn = let f x (l1,l2) = (l1,Names.Mindmap.add kn x l2) in add_section_replacement f f -let add_section_constant kn = +let add_section_constant is_projection kn = + (* let g x (l1,l2) = (Names.Cmap.add kn (Univ.Instance.empty,[||]) l1,l2) in *) let f x (l1,l2) = (Names.Cmap.add kn x l1,l2) in - add_section_replacement f f + (* if is_projection then add_section_replacement g f *) + (* else *) add_section_replacement f f let replacement_context () = pi2 (List.hd !sectab) @@ -445,7 +452,9 @@ let rec list_mem_assoc x = function let section_instance = function | VarRef id -> - if list_mem_assoc id (pi1 (List.hd !sectab)) then [||] + if List.exists (fun (id',_,_,_) -> Names.id_eq id id') + (pi1 (List.hd !sectab)) + then Univ.Instance.empty, [||] else raise Not_found | ConstRef con -> Names.Cmap.find con (fst (pi2 (List.hd !sectab))) @@ -459,8 +468,8 @@ let full_replacement_context () = List.map pi2 !sectab let full_section_segment_of_constant con = List.map (fun (vars,_,(x,_)) -> fun hyps -> named_of_variable_context - (try Names.Cmap.find con x - with Not_found -> extract_hyps (vars, hyps))) !sectab + (try fst (Names.Cmap.find con x) + with Not_found -> fst (extract_hyps (vars, hyps)))) !sectab (*************) (* Sections. *) diff --git a/library/lib.mli b/library/lib.mli index 8975acd9a..759a1a135 100644 --- a/library/lib.mli +++ b/library/lib.mli @@ -161,23 +161,23 @@ val xml_close_section : (Names.Id.t -> unit) Hook.t (** {6 Section management for discharge } *) type variable_info = Names.Id.t * Decl_kinds.binding_kind * Term.constr option * Term.types -type variable_context = variable_info list +type variable_context = variable_info list val instance_from_variable_context : variable_context -> Names.Id.t array val named_of_variable_context : variable_context -> Context.named_context -val section_segment_of_constant : Names.constant -> variable_context -val section_segment_of_mutual_inductive: Names.mutual_inductive -> variable_context +val section_segment_of_constant : Names.constant -> variable_context Univ.in_universe_context +val section_segment_of_mutual_inductive: Names.mutual_inductive -> variable_context Univ.in_universe_context -val section_instance : Globnames.global_reference -> Names.Id.t array +val section_instance : Globnames.global_reference -> Univ.universe_instance * Names.Id.t array val is_in_section : Globnames.global_reference -> bool -val add_section_variable : Names.Id.t -> Decl_kinds.binding_kind -> unit +val add_section_variable : Names.Id.t -> Decl_kinds.binding_kind -> Decl_kinds.polymorphic -> Univ.universe_context_set -> unit -val add_section_constant : Names.constant -> Context.named_context -> unit +val add_section_constant : bool (* is_projection *) -> + Names.constant -> Context.named_context -> unit val add_section_kn : Names.mutual_inductive -> Context.named_context -> unit -val replacement_context : unit -> - (Names.Id.t array Names.Cmap.t * Names.Id.t array Names.Mindmap.t) +val replacement_context : unit -> Opaqueproof.work_list (** {6 Discharge: decrease the section level if in the current section } *) diff --git a/library/library.mllib b/library/library.mllib index 2568bcc18..6a58a1057 100644 --- a/library/library.mllib +++ b/library/library.mllib @@ -5,6 +5,7 @@ Libobject Summary Nametab Global +Universes Lib Declaremods Loadpath diff --git a/library/universes.ml b/library/universes.ml new file mode 100644 index 000000000..79286792d --- /dev/null +++ b/library/universes.ml @@ -0,0 +1,647 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Util +open Pp +open Names +open Term +open Context +open Environ +open Locus +open Univ + +(* Generator of levels *) +let new_univ_level, set_remote_new_univ_level = + RemoteCounter.new_counter ~name:"Universes" 0 ~incr:((+) 1) + ~build:(fun n -> Univ.Level.make (Global.current_dirpath ()) n) + +let new_univ_level _ = new_univ_level () + (* Univ.Level.make db (new_univ_level ()) *) + +let fresh_level () = new_univ_level (Global.current_dirpath ()) + +(* TODO: remove *) +let new_univ dp = Univ.Universe.make (new_univ_level dp) +let new_Type dp = mkType (new_univ dp) +let new_Type_sort dp = Type (new_univ dp) + +let fresh_universe_instance ctx = + Instance.subst_fn (fun _ -> new_univ_level (Global.current_dirpath ())) + (UContext.instance ctx) + +let fresh_instance_from_context ctx = + let inst = fresh_universe_instance ctx in + let subst = make_universe_subst inst ctx in + let constraints = instantiate_univ_context subst ctx in + (inst, subst), constraints + +let fresh_instance ctx = + let s = ref LSet.empty in + let inst = + Instance.subst_fn (fun _ -> + let u = new_univ_level (Global.current_dirpath ()) in + s := LSet.add u !s; u) + (UContext.instance ctx) + in !s, inst + +let fresh_instance_from ctx = + let ctx', inst = fresh_instance ctx in + let subst = make_universe_subst inst ctx in + let constraints = instantiate_univ_context subst ctx in + (inst, subst), (ctx', constraints) + +(** Fresh universe polymorphic construction *) + +let fresh_constant_instance env c = + let cb = lookup_constant c env in + if cb.Declarations.const_polymorphic then + let (inst,_), ctx = fresh_instance_from (Future.join cb.Declarations.const_universes) in + ((c, inst), ctx) + else ((c,Instance.empty), ContextSet.empty) + +let fresh_inductive_instance env ind = + let mib, mip = Inductive.lookup_mind_specif env ind in + if mib.Declarations.mind_polymorphic then + let (inst,_), ctx = fresh_instance_from mib.Declarations.mind_universes in + ((ind,inst), ctx) + else ((ind,Instance.empty), ContextSet.empty) + +let fresh_constructor_instance env (ind,i) = + let mib, mip = Inductive.lookup_mind_specif env ind in + if mib.Declarations.mind_polymorphic then + let (inst,_), ctx = fresh_instance_from mib.Declarations.mind_universes in + (((ind,i),inst), ctx) + else (((ind,i),Instance.empty), ContextSet.empty) + +open Globnames +let fresh_global_instance env gr = + match gr with + | VarRef id -> mkVar id, ContextSet.empty + | ConstRef sp -> + let c, ctx = fresh_constant_instance env sp in + mkConstU c, ctx + | ConstructRef sp -> + let c, ctx = fresh_constructor_instance env sp in + mkConstructU c, ctx + | IndRef sp -> + let c, ctx = fresh_inductive_instance env sp in + mkIndU c, ctx + +let constr_of_global gr = + let c, ctx = fresh_global_instance (Global.env ()) gr in + Global.push_context_set ctx; c + +let constr_of_global_univ (gr,u) = + match gr with + | VarRef id -> mkVar id + | ConstRef sp -> mkConstU (sp,u) + | ConstructRef sp -> mkConstructU (sp,u) + | IndRef sp -> mkIndU (sp,u) + +let fresh_global_or_constr_instance env = function + | IsConstr c -> c, ContextSet.empty + | IsGlobal gr -> fresh_global_instance env gr + +let global_of_constr c = + match kind_of_term c with + | Const (c, u) -> ConstRef c, u + | Ind (i, u) -> IndRef i, u + | Construct (c, u) -> ConstructRef c, u + | Var id -> VarRef id, Instance.empty + | _ -> raise Not_found + +let global_app_of_constr c = + match kind_of_term c with + | Const (c, u) -> (ConstRef c, u), None + | Ind (i, u) -> (IndRef i, u), None + | Construct (c, u) -> (ConstructRef c, u), None + | Var id -> (VarRef id, Instance.empty), None + | Proj (p, c) -> (ConstRef p, Instance.empty), Some c + | _ -> raise Not_found + +open Declarations + +let type_of_reference env r = + match r with + | VarRef id -> Environ.named_type id env, ContextSet.empty + | ConstRef c -> + let cb = Environ.lookup_constant c env in + if cb.const_polymorphic then + let (inst, subst), ctx = fresh_instance_from (Future.join cb.const_universes) in + Vars.subst_univs_constr subst cb.const_type, ctx + else cb.const_type, ContextSet.empty + + | IndRef ind -> + let (mib, oib) = Inductive.lookup_mind_specif env ind in + if mib.mind_polymorphic then + let (inst, subst), ctx = fresh_instance_from mib.mind_universes in + Vars.subst_univs_constr subst oib.mind_arity.mind_user_arity, ctx + else oib.mind_arity.mind_user_arity, ContextSet.empty + | ConstructRef cstr -> + let (mib,oib as specif) = Inductive.lookup_mind_specif env (inductive_of_constructor cstr) in + if mib.mind_polymorphic then + let (inst, subst), ctx = fresh_instance_from mib.mind_universes in + Inductive.type_of_constructor (cstr,inst) specif, ctx + else Inductive.type_of_constructor (cstr,Instance.empty) specif, ContextSet.empty + +let type_of_global t = type_of_reference (Global.env ()) t + +let fresh_sort_in_family env = function + | InProp -> prop_sort, ContextSet.empty + | InSet -> set_sort, ContextSet.empty + | InType -> + let u = fresh_level () in + Type (Univ.Universe.make u), ContextSet.singleton u + +let new_sort_in_family sf = + fst (fresh_sort_in_family (Global.env ()) sf) + +let extend_context (a, ctx) (ctx') = + (a, ContextSet.union ctx ctx') + +let new_global_univ () = + let u = fresh_level () in + (Univ.Universe.make u, ContextSet.singleton u) + +(** Simplification *) + +module LevelUnionFind = Unionfind.Make (Univ.LSet) (Univ.LMap) + +let remove_trivial_constraints cst = + Constraint.fold (fun (l,d,r as cstr) nontriv -> + if d != Lt && eq_levels l r then nontriv + else if d == Le && is_type0m_univ (Univ.Universe.make l) then nontriv + else Constraint.add cstr nontriv) + cst Constraint.empty + +let add_list_map u t map = + let l, d, r = LMap.split u map in + let d' = match d with None -> [t] | Some l -> t :: l in + let lr = + LMap.merge (fun k lm rm -> + match lm with Some t -> lm | None -> + match rm with Some t -> rm | None -> None) l r + in LMap.add u d' lr + +let find_list_map u map = + try LMap.find u map with Not_found -> [] + +module UF = LevelUnionFind +type universe_full_subst = (universe_level * universe) list + +(** Precondition: flexible <= ctx *) +let choose_canonical ctx flexible algs s = + let global = LSet.diff s ctx in + let flexible, rigid = LSet.partition (fun x -> LMap.mem x flexible) (LSet.inter s ctx) in + (** If there is a global universe in the set, choose it *) + if not (LSet.is_empty global) then + let canon = LSet.choose global in + canon, (LSet.remove canon global, rigid, flexible) + else (** No global in the equivalence class, choose a rigid one *) + if not (LSet.is_empty rigid) then + let canon = LSet.choose rigid in + canon, (global, LSet.remove canon rigid, flexible) + else (** There are only flexible universes in the equivalence + class, choose a non-algebraic. *) + let algs, nonalgs = LSet.partition (fun x -> LSet.mem x algs) flexible in + if not (LSet.is_empty nonalgs) then + let canon = LSet.choose nonalgs in + canon, (global, rigid, LSet.remove canon flexible) + else + let canon = LSet.choose algs in + canon, (global, rigid, LSet.remove canon flexible) + +open Universe + +let subst_puniverses subst (c, u as cu) = + let u' = Instance.subst subst u in + if u' == u then cu else (c, u') + +let nf_evars_and_universes_local f subst = + let rec aux c = + match kind_of_term c with + | Evar (evdk, _ as ev) -> + (match f ev with + | None -> c + | Some c -> aux c) + | Const pu -> + let pu' = subst_puniverses subst pu in + if pu' == pu then c else mkConstU pu' + | Ind pu -> + let pu' = subst_puniverses subst pu in + if pu' == pu then c else mkIndU pu' + | Construct pu -> + let pu' = subst_puniverses subst pu in + if pu' == pu then c else mkConstructU pu' + | Sort (Type u) -> + let u' = Univ.subst_univs_level_universe subst u in + if u' == u then c else mkSort (sort_of_univ u') + | _ -> map_constr aux c + in aux + +let subst_univs_fn_puniverses lsubst (c, u as cu) = + let u' = Instance.subst_fn lsubst u in + if u' == u then cu else (c, u') + +let subst_univs_puniverses subst cu = + subst_univs_fn_puniverses (Univ.level_subst_of (Univ.make_subst subst)) cu + +let nf_evars_and_universes_gen f subst = + let lsubst = Univ.level_subst_of subst in + let rec aux c = + match kind_of_term c with + | Evar (evdk, _ as ev) -> + (match try f ev with Not_found -> None with + | None -> c + | Some c -> aux c) + | Const pu -> + let pu' = subst_univs_fn_puniverses lsubst pu in + if pu' == pu then c else mkConstU pu' + | Ind pu -> + let pu' = subst_univs_fn_puniverses lsubst pu in + if pu' == pu then c else mkIndU pu' + | Construct pu -> + let pu' = subst_univs_fn_puniverses lsubst pu in + if pu' == pu then c else mkConstructU pu' + | Sort (Type u) -> + let u' = Univ.subst_univs_universe subst u in + if u' == u then c else mkSort (sort_of_univ u') + | _ -> map_constr aux c + in aux + +let nf_evars_and_universes_subst f subst = + nf_evars_and_universes_gen f (Univ.make_subst subst) + +let nf_evars_and_universes_opt_subst f subst = + let subst = fun l -> match LMap.find l subst with None -> raise Not_found | Some l' -> l' in + nf_evars_and_universes_gen f subst + +let subst_univs_full_constr subst c = + nf_evars_and_universes_subst (fun _ -> None) subst c + +let fresh_universe_context_set_instance ctx = + if ContextSet.is_empty ctx then LMap.empty, ctx + else + let (univs, cst) = ContextSet.levels ctx, ContextSet.constraints ctx in + let univs',subst = LSet.fold + (fun u (univs',subst) -> + let u' = fresh_level () in + (LSet.add u' univs', LMap.add u u' subst)) + univs (LSet.empty, LMap.empty) + in + let cst' = subst_univs_level_constraints subst cst in + subst, (univs', cst') + +let normalize_univ_variable ~find ~update = + let rec aux cur = + let b = find cur in + let b' = subst_univs_universe aux b in + if Universe.eq b' b then b + else update cur b' + in fun b -> try aux b with Not_found -> Universe.make b + +let normalize_univ_variable_opt_subst ectx = + let find l = + match Univ.LMap.find l !ectx with + | Some b -> b + | None -> raise Not_found + in + let update l b = + assert (match Universe.level b with Some l' -> not (Level.eq l l') | None -> true); + ectx := Univ.LMap.add l (Some b) !ectx; b + in normalize_univ_variable ~find ~update + +let normalize_univ_variable_subst subst = + let find l = Univ.LMap.find l !subst in + let update l b = + assert (match Universe.level b with Some l' -> not (Level.eq l l') | None -> true); + subst := Univ.LMap.add l b !subst; b in + normalize_univ_variable ~find ~update + +let normalize_universe_opt_subst subst = + let normlevel = normalize_univ_variable_opt_subst subst in + subst_univs_universe normlevel + +let normalize_universe_subst subst = + let normlevel = normalize_univ_variable_subst subst in + subst_univs_universe normlevel + +type universe_opt_subst = universe option universe_map + +let make_opt_subst s = + fun x -> + (match Univ.LMap.find x s with + | Some u -> u + | None -> raise Not_found) + +let subst_opt_univs_constr s = + let f = make_opt_subst s in + Vars.subst_univs_fn_constr f + +let normalize_univ_variables ctx = + let ectx = ref ctx in + let normalize = normalize_univ_variable_opt_subst ectx in + let _ = Univ.LMap.iter (fun u _ -> ignore(normalize u)) ctx in + let undef, def, subst = + Univ.LMap.fold (fun u v (undef, def, subst) -> + match v with + | None -> (Univ.LSet.add u undef, def, subst) + | Some b -> (undef, Univ.LSet.add u def, Univ.LMap.add u b subst)) + !ectx (Univ.LSet.empty, Univ.LSet.empty, Univ.LMap.empty) + in !ectx, undef, def, subst + +let pr_universe_body = function + | None -> mt () + | Some v -> str" := " ++ Univ.Universe.pr v + +let pr_universe_opt_subst = Univ.LMap.pr pr_universe_body + +let is_defined_var u l = + try + match LMap.find u l with + | Some _ -> true + | None -> false + with Not_found -> false + +let subst_univs_subst u l s = + LMap.add u l s + +exception Found of Level.t +let find_inst insts v = + try LMap.iter (fun k (enf,alg,v') -> + if not alg && enf && Universe.eq v' v then raise (Found k)) + insts; raise Not_found + with Found l -> l + +let add_inst u (enf,b,lbound) insts = + match lbound with + | Some v -> LMap.add u (enf,b,v) insts + | None -> insts + +exception Stays + +let compute_lbound left = + (** The universe variable was not fixed yet. + Compute its level using its lower bound. *) + if CList.is_empty left then None + else + let lbound = List.fold_left (fun lbound (d, l) -> + if d == Le (* l <= ?u *) then (Universe.sup l lbound) + else (* l < ?u *) + (assert (d == Lt); + (Universe.sup (Universe.super l) lbound))) + Universe.type0m left + in + Some lbound + +let maybe_enforce_leq lbound u cstrs = + match lbound with + | Some lbound -> enforce_leq lbound (Universe.make u) cstrs + | None -> cstrs + +let instantiate_with_lbound u lbound alg enforce (ctx, us, algs, insts, cstrs) = + if enforce then + let inst = Universe.make u in + let cstrs' = enforce_leq lbound inst cstrs in + (ctx, us, LSet.remove u algs, + LMap.add u (enforce,alg,lbound) insts, cstrs'), (enforce, alg, inst) + else (* Actually instantiate *) + (Univ.LSet.remove u ctx, Univ.LMap.add u (Some lbound) us, algs, + LMap.add u (enforce,alg,lbound) insts, cstrs), (enforce, alg, lbound) + +type constraints_map = (Univ.constraint_type * Univ.LMap.key) list Univ.LMap.t + +let pr_constraints_map cmap = + LMap.fold (fun l cstrs acc -> + Level.pr l ++ str " => " ++ + prlist_with_sep spc (fun (d,r) -> pr_constraint_type d ++ Level.pr r) cstrs ++ fnl () + ++ acc) + cmap (mt ()) + +let minimize_univ_variables ctx us algs left right cstrs = + let left, lbounds = + Univ.LMap.fold (fun r lower (left, lbounds as acc) -> + if Univ.LMap.mem r us || not (Univ.LSet.mem r ctx) then acc + else (* Fixed universe, just compute its glb for sharing *) + let lbounds' = + match compute_lbound (List.map (fun (d,l) -> d, Universe.make l) lower) with + | None -> lbounds + | Some lbound -> LMap.add r (true, false, lbound) lbounds + in (Univ.LMap.remove r left, lbounds')) + left (left, Univ.LMap.empty) + in + let rec instance (ctx', us, algs, insts, cstrs as acc) u = + let acc, left = + try let l = LMap.find u left in + List.fold_left (fun (acc, left') (d, l) -> + let acc', (enf,alg,l') = aux acc l in + (* if alg then assert(not alg); *) + let l' = + if enf then Universe.make l + else l' + (* match Universe.level l' with Some _ -> l' | None -> Universe.make l *) + in + acc', (d, l') :: left') (acc, []) l + with Not_found -> acc, [] + and right = + try Some (LMap.find u right) + with Not_found -> None + in + let instantiate_lbound lbound = + let alg = LSet.mem u algs in + if alg then + (* u is algebraic and has no upper bound constraints: we + instantiate it with it's lower bound, if any *) + instantiate_with_lbound u lbound true false acc + else (* u is non algebraic *) + match Universe.level lbound with + | Some l -> (* The lowerbound is directly a level *) + (* u is not algebraic but has no upper bounds, + we instantiate it with its lower bound if it is a + different level, otherwise we keep it. *) + if not (Level.eq l u) && not (LSet.mem l algs) then + (* if right = None then. Should check that u does not + have upper constraints that are not already in right *) + instantiate_with_lbound u lbound false false acc + (* else instantiate_with_lbound u lbound false true acc *) + else + (* assert false: l can't be alg *) + acc, (true, false, lbound) + | None -> + try + (* if right <> None then raise Not_found; *) + (* Another universe represents the same lower bound, + we can share them with no harm. *) + let can = find_inst insts lbound in + instantiate_with_lbound u (Universe.make can) false false acc + with Not_found -> + (* We set u as the canonical universe representing lbound *) + instantiate_with_lbound u lbound false true acc + in + let acc' acc = + match right with + | None -> acc + | Some cstrs -> + let dangling = List.filter (fun (d, r) -> not (LMap.mem r us)) cstrs in + if List.is_empty dangling then acc + else + let ((ctx', us, algs, insts, cstrs), (enf,_,inst as b)) = acc in + let cstrs' = List.fold_left (fun cstrs (d, r) -> + if d == Univ.Le then + enforce_leq inst (Universe.make r) cstrs + else + try let lev = Option.get (Universe.level inst) in + Constraint.add (lev, d, r) cstrs + with Option.IsNone -> assert false) + cstrs dangling + in + (ctx', us, algs, insts, cstrs'), b + in + if not (LSet.mem u ctx) then acc' (acc, (true, false, Universe.make u)) + else + let lbound = compute_lbound left in + match lbound with + | None -> (* Nothing to do *) + acc' (acc, (true, false, Universe.make u)) + | Some lbound -> + acc' (instantiate_lbound lbound) + and aux (ctx', us, algs, seen, cstrs as acc) u = + try acc, LMap.find u seen + with Not_found -> instance acc u + in + LMap.fold (fun u v (ctx', us, algs, seen, cstrs as acc) -> + if v == None then fst (aux acc u) + else LSet.remove u ctx', us, LSet.remove u algs, seen, cstrs) + us (ctx, us, algs, lbounds, cstrs) + +let normalize_context_set ctx us algs = + let (ctx, csts) = ContextSet.levels ctx, ContextSet.constraints ctx in + let uf = UF.create () in + let csts = + (* We first put constraints in a normal-form: all self-loops are collapsed + to equalities. *) + let g = Univ.merge_constraints csts Univ.empty_universes in + Univ.constraints_of_universes (Univ.normalize_universes g) + in + let noneqs = + Constraint.fold (fun (l,d,r) noneqs -> + if d == Eq then (UF.union l r uf; noneqs) + else Constraint.add (l,d,r) noneqs) + csts Constraint.empty + in + let partition = UF.partition uf in + let subst, eqs = List.fold_left (fun (subst, cstrs) s -> + let canon, (global, rigid, flexible) = choose_canonical ctx us algs s in + (* Add equalities for globals which can't be merged anymore. *) + let cstrs = LSet.fold (fun g cst -> + Constraint.add (canon, Univ.Eq, g) cst) global cstrs + in + (** Should this really happen? *) + let subst' = LSet.fold (fun f -> LMap.add f canon) + (LSet.union rigid flexible) LMap.empty + in + let subst = LMap.union subst' subst in + (subst, cstrs)) + (LMap.empty, Constraint.empty) partition + in + (* Noneqs is now in canonical form w.r.t. equality constraints, + and contains only inequality constraints. *) + let noneqs = subst_univs_level_constraints subst noneqs in + let us = + LMap.subst_union (LMap.map (fun v -> Some (Universe.make v)) subst) us + in + (* Compute the left and right set of flexible variables, constraints + mentionning other variables remain in noneqs. *) + let noneqs, ucstrsl, ucstrsr = + Constraint.fold (fun (l,d,r as cstr) (noneq, ucstrsl, ucstrsr) -> + let lus = LMap.mem l us + and rus = LMap.mem r us + in + let ucstrsl' = + if lus then add_list_map l (d, r) ucstrsl + else ucstrsl + and ucstrsr' = + add_list_map r (d, l) ucstrsr + in + let noneqs = + if lus || rus then noneq + else Constraint.add cstr noneq + in (noneqs, ucstrsl', ucstrsr')) + noneqs (Constraint.empty, LMap.empty, LMap.empty) + in + (* Now we construct the instanciation of each variable. *) + let ctx', us, algs, inst, noneqs = + minimize_univ_variables ctx us algs ucstrsr ucstrsl noneqs + in + let us = ref us in + let norm = normalize_univ_variable_opt_subst us in + let _normalize_subst = LMap.iter (fun u v -> ignore(norm u)) !us in + (!us, algs), (ctx', Constraint.union noneqs eqs) + +(* let normalize_conkey = Profile.declare_profile "normalize_context_set" *) +(* let normalize_context_set a b c = Profile.profile3 normalize_conkey normalize_context_set a b c *) + +let universes_of_constr c = + let rec aux s c = + match kind_of_term c with + | Const (_, u) | Ind (_, u) | Construct (_, u) -> + LSet.union (Instance.levels u) s + | Sort u -> + let u = univ_of_sort u in + LSet.union (Universe.levels u) s + | _ -> fold_constr aux s c + in aux LSet.empty c + +let shrink_universe_context (univs,csts) s = + let univs' = LSet.inter univs s in + Constraint.fold (fun (l,d,r as c) (univs',csts) -> + if LSet.mem l univs' then + let univs' = if LSet.mem r univs then LSet.add r univs' else univs' in + (univs', Constraint.add c csts) + else if LSet.mem r univs' then + let univs' = if LSet.mem l univs then LSet.add l univs' else univs' in + (univs', Constraint.add c csts) + else (univs', csts)) + csts (univs',Constraint.empty) + +let restrict_universe_context (univs,csts) s = + let univs' = LSet.inter univs s in + (* Universes that are not necessary to typecheck the term. + E.g. univs introduced by tactics and not used in the proof term. *) + let diff = LSet.diff univs s in + let csts' = + Constraint.fold (fun (l,d,r as c) csts -> + if LSet.mem l diff || LSet.mem r diff then csts + else Constraint.add c csts) + csts Constraint.empty + in (univs', csts') + +let is_prop_leq (l,d,r) = + Level.eq Level.prop l && d == Univ.Le + +(* Prop < i <-> Set+1 <= i <-> Set < i *) +let translate_cstr (l,d,r as cstr) = + if Level.eq Level.prop l && d == Univ.Lt then + (Level.set, d, r) + else cstr + +let refresh_constraints univs (ctx, cstrs) = + let cstrs', univs' = + Univ.Constraint.fold (fun c (cstrs', univs as acc) -> + let c = translate_cstr c in + if Univ.check_constraint univs c && not (is_prop_leq c) then acc + else (Univ.Constraint.add c cstrs', Univ.enforce_constraint c univs)) + cstrs (Univ.Constraint.empty, univs) + in ((ctx, cstrs'), univs') + +let remove_trivial_constraints (ctx, cstrs) = + let cstrs' = + Univ.Constraint.fold (fun c acc -> + if is_prop_leq c then Univ.Constraint.remove c acc + else acc) cstrs cstrs + in (ctx, cstrs') diff --git a/library/universes.mli b/library/universes.mli new file mode 100644 index 000000000..47876269a --- /dev/null +++ b/library/universes.mli @@ -0,0 +1,170 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Util +open Pp +open Names +open Term +open Context +open Environ +open Locus +open Univ + +(** Universes *) +val new_univ_level : Names.dir_path -> universe_level +val set_remote_new_univ_level : universe_level RemoteCounter.installer +val new_univ : Names.dir_path -> universe +val new_Type : Names.dir_path -> types +val new_Type_sort : Names.dir_path -> sorts + +(** Build a fresh instance for a given context, its associated substitution and + the instantiated constraints. *) + +val fresh_instance_from_context : universe_context -> + (universe_instance * universe_subst) constrained + +val fresh_instance_from : universe_context -> + (universe_instance * universe_subst) in_universe_context_set + +val new_global_univ : unit -> universe in_universe_context_set +val new_sort_in_family : sorts_family -> sorts + +val fresh_sort_in_family : env -> sorts_family -> + sorts in_universe_context_set +val fresh_constant_instance : env -> constant -> + pconstant in_universe_context_set +val fresh_inductive_instance : env -> inductive -> + pinductive in_universe_context_set +val fresh_constructor_instance : env -> constructor -> + pconstructor in_universe_context_set + +val fresh_global_instance : env -> Globnames.global_reference -> + constr in_universe_context_set + +val fresh_global_or_constr_instance : env -> Globnames.global_reference_or_constr -> + constr in_universe_context_set + +(** Raises [Not_found] if not a global reference. *) +val global_of_constr : constr -> Globnames.global_reference puniverses + +val global_app_of_constr : constr -> Globnames.global_reference puniverses * constr option + +val constr_of_global_univ : Globnames.global_reference puniverses -> constr + +val extend_context : 'a in_universe_context_set -> universe_context_set -> + 'a in_universe_context_set + +(** Simplification and pruning of constraints: + [normalize_context_set ctx us] + + - Instantiate the variables in [us] with their most precise + universe levels respecting the constraints. + + - Normalizes the context [ctx] w.r.t. equality constraints, + choosing a canonical universe in each equivalence class + (a global one if there is one) and transitively saturate + the constraints w.r.t to the equalities. *) + +module UF : Unionfind.PartitionSig with type elt = universe_level + +type universe_opt_subst = universe option universe_map + +val make_opt_subst : universe_opt_subst -> universe_subst_fn + +val subst_opt_univs_constr : universe_opt_subst -> constr -> constr + +val choose_canonical : universe_set -> universe_opt_subst -> universe_set -> universe_set -> + universe_level * (universe_set * universe_set * universe_set) + +val instantiate_with_lbound : + Univ.LMap.key -> + Univ.universe -> + bool -> + bool -> + Univ.LSet.t * Univ.universe option Univ.LMap.t * + Univ.LSet.t * + (bool * bool * Univ.universe) Univ.LMap.t * Univ.constraints -> + (Univ.LSet.t * Univ.universe option Univ.LMap.t * + Univ.LSet.t * + (bool * bool * Univ.universe) Univ.LMap.t * Univ.constraints) * + (bool * bool * Univ.universe) + +val compute_lbound : (constraint_type * Univ.universe) list -> universe option + +type constraints_map = (Univ.constraint_type * Univ.LMap.key) list Univ.LMap.t + +val pr_constraints_map : constraints_map -> Pp.std_ppcmds + +val minimize_univ_variables : + Univ.LSet.t -> + Univ.universe option Univ.LMap.t -> + Univ.LSet.t -> + constraints_map -> constraints_map -> + Univ.constraints -> + Univ.LSet.t * Univ.universe option Univ.LMap.t * + Univ.LSet.t * + (bool * bool * Univ.universe) Univ.LMap.t * Univ.constraints + + +val normalize_context_set : universe_context_set -> + universe_opt_subst (* The defined and undefined variables *) -> + universe_set (* univ variables that can be substituted by algebraics *) -> + (universe_opt_subst * universe_set) in_universe_context_set + +val normalize_univ_variables : universe_opt_subst -> + universe_opt_subst * universe_set * universe_set * universe_subst + +val normalize_univ_variable : + find:(universe_level -> universe) -> + update:(universe_level -> universe -> universe) -> + universe_level -> universe + +val normalize_univ_variable_opt_subst : universe_opt_subst ref -> + (universe_level -> universe) + +val normalize_univ_variable_subst : universe_subst ref -> + (universe_level -> universe) + +val normalize_universe_opt_subst : universe_opt_subst ref -> + (universe -> universe) + +val normalize_universe_subst : universe_subst ref -> + (universe -> universe) + +(** Create a fresh global in the global environment, shouldn't be done while + building polymorphic values as the constraints are added to the global + environment already. *) + +val constr_of_global : Globnames.global_reference -> constr + +val type_of_global : Globnames.global_reference -> types in_universe_context_set + +(** Full universes substitutions into terms *) + +val nf_evars_and_universes_local : (existential -> constr option) -> universe_level_subst -> + constr -> constr + +val nf_evars_and_universes_opt_subst : (existential -> constr option) -> + universe_opt_subst -> constr -> constr + +(** Get fresh variables for the universe context. + Useful to make tactics that manipulate constrs in universe contexts polymorphic. *) +val fresh_universe_context_set_instance : universe_context_set -> + universe_level_subst * universe_context_set + +val pr_universe_opt_subst : universe_opt_subst -> Pp.std_ppcmds + +(** Shrink a universe context to a restricted set of variables *) + +val universes_of_constr : constr -> universe_set +val shrink_universe_context : universe_context_set -> universe_set -> universe_context_set +val restrict_universe_context : universe_context_set -> universe_set -> universe_context_set + +val refresh_constraints : universes -> universe_context_set -> universe_context_set * universes + +val remove_trivial_constraints : universe_context_set -> universe_context_set diff --git a/parsing/egramcoq.ml b/parsing/egramcoq.ml index 3245c642f..e2b78d725 100644 --- a/parsing/egramcoq.ml +++ b/parsing/egramcoq.ml @@ -47,7 +47,7 @@ open Egramml let constr_expr_of_name (loc,na) = match na with | Anonymous -> CHole (loc,None,None) - | Name id -> CRef (Ident (loc,id)) + | Name id -> CRef (Ident (loc,id), None) let cases_pattern_expr_of_name (loc,na) = match na with | Anonymous -> CPatAtom (loc,None) @@ -76,7 +76,7 @@ let make_constr_action make (v :: constrs, constrlists, binders) tl) | ETReference -> Gram.action (fun (v:reference) -> - make (CRef v :: constrs, constrlists, binders) tl) + make (CRef (v,None) :: constrs, constrlists, binders) tl) | ETName -> Gram.action (fun (na:Loc.t * Name.t) -> make (constr_expr_of_name na :: constrs, constrlists, binders) tl) diff --git a/parsing/g_constr.ml4 b/parsing/g_constr.ml4 index cdaa809d2..499e7b053 100644 --- a/parsing/g_constr.ml4 +++ b/parsing/g_constr.ml4 @@ -159,7 +159,7 @@ GEXTEND Gram ; constr: [ [ c = operconstr LEVEL "8" -> c - | "@"; f=global -> CAppExpl(!@loc,(None,f),[]) ] ] + | "@"; f=global -> CAppExpl(!@loc,(None,f,None),[]) ] ] ; operconstr: [ "200" RIGHTA @@ -183,20 +183,20 @@ GEXTEND Gram | "90" RIGHTA [ ] | "10" LEFTA [ f=operconstr; args=LIST1 appl_arg -> CApp(!@loc,(None,f),args) - | "@"; f=global; args=LIST0 NEXT -> CAppExpl(!@loc,(None,f),args) + | "@"; f=global; args=LIST0 NEXT -> CAppExpl(!@loc,(None,f,None),args) | "@"; (locid,id) = pattern_identref; args=LIST1 identref -> - let args = List.map (fun x -> CRef (Ident x), None) args in + let args = List.map (fun x -> CRef (Ident x,None), None) args in CApp(!@loc,(None,CPatVar(locid,(true,id))),args) ] | "9" [ ".."; c = operconstr LEVEL "0"; ".." -> - CAppExpl (!@loc,(None,Ident (!@loc,ldots_var)),[c]) ] + CAppExpl (!@loc,(None,Ident (!@loc,ldots_var),None),[c]) ] | "8" [ ] | "1" LEFTA [ c=operconstr; ".("; f=global; args=LIST0 appl_arg; ")" -> - CApp(!@loc,(Some (List.length args+1),CRef f),args@[c,None]) + CApp(!@loc,(Some (List.length args+1),CRef (f,None)),args@[c,None]) | c=operconstr; ".("; "@"; f=global; args=LIST0 (operconstr LEVEL "9"); ")" -> - CAppExpl(!@loc,(Some (List.length args+1),f),args@[c]) + CAppExpl(!@loc,(Some (List.length args+1),f,None),args@[c]) | c=operconstr; "%"; key=IDENT -> CDelimiters (!@loc,key,c) ] | "0" [ c=atomic_constr -> c @@ -277,7 +277,7 @@ GEXTEND Gram | c=operconstr LEVEL "9" -> (c,None) ] ] ; atomic_constr: - [ [ g=global -> CRef g + [ [ g=global -> CRef (g,None) | s=sort -> CSort (!@loc,s) | n=INT -> CPrim (!@loc, Numeral (Bigint.of_string n)) | s=string -> CPrim (!@loc, String s) diff --git a/parsing/g_obligations.ml4 b/parsing/g_obligations.ml4 new file mode 100644 index 000000000..2354aa332 --- /dev/null +++ b/parsing/g_obligations.ml4 @@ -0,0 +1,135 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i camlp4deps: "grammar/grammar.cma" i*) + +(* + Syntax for the subtac terms and types. + Elaborated from correctness/psyntax.ml4 by Jean-Christophe Filliâtre *) + + +open Libnames +open Constrexpr +open Constrexpr_ops + +(* We define new entries for programs, with the use of this module + * Subtac. These entries are named Subtac.<foo> + *) + +module Gram = Pcoq.Gram +module Vernac = Pcoq.Vernac_ +module Tactic = Pcoq.Tactic + +open Pcoq + +let sigref = mkRefC (Qualid (Loc.ghost, Libnames.qualid_of_string "Coq.Init.Specif.sig")) + +type 'a withtac_argtype = (Tacexpr.raw_tactic_expr option, 'a) Genarg.abstract_argument_type + +let wit_withtac : Tacexpr.raw_tactic_expr option Genarg.uniform_genarg_type = + Genarg.create_arg None "withtac" + +let withtac = Pcoq.create_generic_entry "withtac" (Genarg.rawwit wit_withtac) + +GEXTEND Gram + GLOBAL: withtac; + + withtac: + [ [ "with"; t = Tactic.tactic -> Some t + | -> None ] ] + ; + + Constr.closed_binder: + [[ "("; id=Prim.name; ":"; t=Constr.lconstr; "|"; c=Constr.lconstr; ")" -> + let typ = mkAppC (sigref, [mkLambdaC ([id], default_binder_kind, t, c)]) in + [LocalRawAssum ([id], default_binder_kind, typ)] + ] ]; + + END + +open Obligations + +let classify_obbl _ = Vernacexpr.(VtStartProof ("Classic",GuaranteesOpacity,[]), VtLater) + +VERNAC COMMAND EXTEND Obligations CLASSIFIED BY classify_obbl +| [ "Obligation" integer(num) "of" ident(name) ":" lconstr(t) withtac(tac) ] -> + [ obligation (num, Some name, Some t) tac ] +| [ "Obligation" integer(num) "of" ident(name) withtac(tac) ] -> + [ obligation (num, Some name, None) tac ] +| [ "Obligation" integer(num) ":" lconstr(t) withtac(tac) ] -> + [ obligation (num, None, Some t) tac ] +| [ "Obligation" integer(num) withtac(tac) ] -> + [ obligation (num, None, None) tac ] +| [ "Next" "Obligation" "of" ident(name) withtac(tac) ] -> + [ next_obligation (Some name) tac ] +| [ "Next" "Obligation" withtac(tac) ] -> [ next_obligation None tac ] +END + +VERNAC COMMAND EXTEND Solve_Obligation CLASSIFIED AS SIDEFF +| [ "Solve" "Obligation" integer(num) "of" ident(name) "with" tactic(t) ] -> + [ try_solve_obligation num (Some name) (Some (Tacinterp.interp t)) ] +| [ "Solve" "Obligation" integer(num) "with" tactic(t) ] -> + [ try_solve_obligation num None (Some (Tacinterp.interp t)) ] +END + +VERNAC COMMAND EXTEND Solve_Obligations CLASSIFIED AS SIDEFF +| [ "Solve" "Obligations" "of" ident(name) "with" tactic(t) ] -> + [ try_solve_obligations (Some name) (Some (Tacinterp.interp t)) ] +| [ "Solve" "Obligations" "with" tactic(t) ] -> + [ try_solve_obligations None (Some (Tacinterp.interp t)) ] +| [ "Solve" "Obligations" ] -> + [ try_solve_obligations None None ] +END + +VERNAC COMMAND EXTEND Solve_All_Obligations CLASSIFIED AS SIDEFF +| [ "Solve" "All" "Obligations" "with" tactic(t) ] -> + [ solve_all_obligations (Some (Tacinterp.interp t)) ] +| [ "Solve" "All" "Obligations" ] -> + [ solve_all_obligations None ] +END + +VERNAC COMMAND EXTEND Admit_Obligations CLASSIFIED AS SIDEFF +| [ "Admit" "Obligations" "of" ident(name) ] -> [ admit_obligations (Some name) ] +| [ "Admit" "Obligations" ] -> [ admit_obligations None ] +END + +VERNAC COMMAND EXTEND Set_Solver CLASSIFIED AS SIDEFF +| [ "Obligation" "Tactic" ":=" tactic(t) ] -> [ + set_default_tactic + (Locality.make_section_locality (Locality.LocalityFixme.consume ())) + (Tacintern.glob_tactic t) ] +END + +open Pp + +VERNAC COMMAND EXTEND Show_Solver CLASSIFIED AS QUERY +| [ "Show" "Obligation" "Tactic" ] -> [ + msg_info (str"Program obligation tactic is " ++ print_default_tactic ()) ] +END + +VERNAC COMMAND EXTEND Show_Obligations CLASSIFIED AS QUERY +| [ "Obligations" "of" ident(name) ] -> [ show_obligations (Some name) ] +| [ "Obligations" ] -> [ show_obligations None ] +END + +VERNAC COMMAND EXTEND Show_Preterm CLASSIFIED AS QUERY +| [ "Preterm" "of" ident(name) ] -> [ msg_info (show_term (Some name)) ] +| [ "Preterm" ] -> [ msg_info (show_term None) ] +END + +open Pp + +(* Declare a printer for the content of Program tactics *) +let () = + let printer _ _ _ = function + | None -> mt () + | Some tac -> str "with" ++ spc () ++ Pptactic.pr_raw_tactic tac + in + (* should not happen *) + let dummy _ _ _ expr = assert false in + Pptactic.declare_extra_genarg_pprule wit_withtac printer dummy dummy diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index 6b989b6ba..65e046fb8 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -146,7 +146,7 @@ let mkTacCase with_evar = function (* Reinterpret ident as notations for variables in the context *) (* because we don't know if they are quantified or not *) | [ElimOnIdent id,(None,None)],None,None -> - TacCase (with_evar,(CRef (Ident id),NoBindings)) + TacCase (with_evar,(CRef (Ident id,None),NoBindings)) | ic -> if List.exists (function (ElimOnAnonHyp _,_) -> true | _ -> false) (pi1 ic) then diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index 73b26b02d..df3c18d10 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -72,8 +72,9 @@ GEXTEND Gram [ [ IDENT "Time"; v = vernac -> VernacTime v | IDENT "Timeout"; n = natural; v = vernac -> VernacTimeout(n,v) | IDENT "Fail"; v = vernac -> VernacFail v - | IDENT "Local"; v = vernac_aux -> VernacLocal (true, v) - | IDENT "Global"; v = vernac_aux -> VernacLocal (false, v) + + | IDENT "Local"; v = vernac_poly -> VernacLocal (true, v) + | IDENT "Global"; v = vernac_poly -> VernacLocal (false, v) (* Stm backdoor *) | IDENT "Stm"; IDENT "JoinDocument"; "." -> VernacStm JoinDocument @@ -85,7 +86,13 @@ GEXTEND Gram | IDENT "Stm"; IDENT "Command"; v = vernac_aux -> VernacStm (Command v) | IDENT "Stm"; IDENT "PGLast"; v = vernac_aux -> VernacStm (PGLast v) - | v = vernac_aux -> v ] + | v = vernac_poly -> v ] + ] + ; + vernac_poly: + [ [ IDENT "Polymorphic"; v = vernac_aux -> VernacPolymorphic (true, v) + | IDENT "Monomorphic"; v = vernac_aux -> VernacPolymorphic (false, v) + | v = vernac_aux -> v ] ] ; vernac_aux: @@ -171,8 +178,8 @@ GEXTEND Gram [ [ thm = thm_token; id = identref; bl = binders; ":"; c = lconstr; l = LIST0 [ "with"; id = identref; bl = binders; ":"; c = lconstr -> - (Some id,(bl,c,None)) ] -> - VernacStartTheoremProof (thm,(Some id,(bl,c,None))::l, false) + (Some id,(bl,c,None)) ] -> + VernacStartTheoremProof (thm, (Some id,(bl,c,None))::l, false) | stre = assumption_token; nl = inline; bl = assum_list -> VernacAssumption (stre, nl, bl) | stre = assumptions_token; nl = inline; bl = assum_list -> @@ -203,6 +210,7 @@ GEXTEND Gram VernacRegister(id, RegisterInline) ] ] ; + gallina_ext: [ [ b = record_token; infer = infer_token; oc = opt_coercion; name = identref; ps = binders; diff --git a/parsing/g_xml.ml4 b/parsing/g_xml.ml4 index 820d44392..99cfa7083 100644 --- a/parsing/g_xml.ml4 +++ b/parsing/g_xml.ml4 @@ -179,7 +179,7 @@ let rec interp_xml_constr = function | XmlTag (loc,"META",al,xl) -> GEvar (loc, get_xml_no al, Some (List.map interp_xml_substitution xl)) | XmlTag (loc,"CONST",al,[]) -> - GRef (loc, ConstRef (get_xml_constant al)) + GRef (loc, ConstRef (get_xml_constant al), None) | XmlTag (loc,"MUTCASE",al,x::y::yl) -> let ind = get_xml_inductive al in let p = interp_xml_patternsType x in @@ -192,9 +192,9 @@ let rec interp_xml_constr = function let nal,rtn = return_type_of_predicate ind n p in GCases (loc,RegularStyle,rtn,[tm,nal],mat) | XmlTag (loc,"MUTIND",al,[]) -> - GRef (loc, IndRef (get_xml_inductive al)) + GRef (loc, IndRef (get_xml_inductive al), None) | XmlTag (loc,"MUTCONSTRUCT",al,[]) -> - GRef (loc, ConstructRef (get_xml_constructor al)) + GRef (loc, ConstructRef (get_xml_constructor al), None) | XmlTag (loc,"FIX",al,xl) -> let li,lnct = List.split (List.map interp_xml_FixFunction xl) in let ln,lc,lt = List.split3 lnct in diff --git a/plugins/Derive/derive.ml b/plugins/Derive/derive.ml index c6a96b31a..906f5e383 100644 --- a/plugins/Derive/derive.ml +++ b/plugins/Derive/derive.ml @@ -7,14 +7,14 @@ (************************************************************************) let interp_init_def_and_relation env sigma init_def r = - let init_def = Constrintern.interp_constr sigma env init_def in + let init_def, _ = Constrintern.interp_constr sigma env init_def in let init_type = Typing.type_of env sigma init_def in let r_type = let open Term in mkProd (Names.Anonymous,init_type, mkProd (Names.Anonymous,init_type,mkProp)) in - let r = Constrintern.interp_casted_constr sigma env r r_type in + let r, _ = Constrintern.interp_casted_constr sigma env r r_type in init_def , init_type , r @@ -23,7 +23,7 @@ let interp_init_def_and_relation env sigma init_def r = [lemma] as the proof. *) let start_deriving f init_def r lemma = let env = Global.env () in - let kind = Decl_kinds.(Global,DefinitionBody Definition) in + let kind = Decl_kinds.(Global,false,DefinitionBody Definition) in let ( init_def , init_type , r ) = interp_init_def_and_relation env Evd.empty init_def r in diff --git a/plugins/btauto/Algebra.v b/plugins/btauto/Algebra.v index a515deefd..795211c20 100644 --- a/plugins/btauto/Algebra.v +++ b/plugins/btauto/Algebra.v @@ -8,11 +8,37 @@ repeat match goal with apply <- andb_true_iff; split end. +Arguments decide P /H. + Hint Extern 5 => progress bool. Ltac define t x H := set (x := t) in *; assert (H : t = x) by reflexivity; clearbody x. +Lemma Decidable_sound : forall P (H : Decidable P), + decide P = true -> P. +Proof. +intros P H Hp; apply -> Decidable_spec; assumption. +Qed. + +Lemma Decidable_complete : forall P (H : Decidable P), + P -> decide P = true. +Proof. +intros P H Hp; apply <- Decidable_spec; assumption. +Qed. + +Lemma Decidable_sound_alt : forall P (H : Decidable P), + ~ P -> decide P = false. +Proof. +intros P [wit spec] Hd; destruct wit; simpl; tauto. +Qed. + +Lemma Decidable_complete_alt : forall P (H : Decidable P), + decide P = false -> ~ P. +Proof. + intros P [wit spec] Hd Hc; simpl in *; intuition congruence. +Qed. + Ltac try_rewrite := repeat match goal with | [ H : ?P |- _ ] => rewrite H @@ -142,6 +168,7 @@ end. Program Instance Decidable_eq_poly : forall (p q : poly), Decidable (eq p q) := { Decidable_witness := beq_poly p q }. + Next Obligation. split. revert q; induction p; intros [] ?; simpl in *; bool; try_decide; @@ -185,8 +212,8 @@ Program Instance Decidable_valid : forall n p, Decidable (valid n p) := { }. Next Obligation. split. - revert n; induction p; simpl in *; intuition; bool; try_decide; auto. - intros H; induction H; simpl in *; bool; try_decide; auto. + revert n; induction p; unfold valid_dec in *; intuition; bool; try_decide; auto. + intros H; induction H; unfold valid_dec in *; bool; try_decide; auto. Qed. (** Basic algebra *) diff --git a/plugins/btauto/refl_btauto.ml b/plugins/btauto/refl_btauto.ml index b81821a2e..6a0f4d852 100644 --- a/plugins/btauto/refl_btauto.ml +++ b/plugins/btauto/refl_btauto.ml @@ -3,7 +3,7 @@ let contrib_name = "btauto" let init_constant dir s = let find_constant contrib dir s = - Globnames.constr_of_global (Coqlib.find_reference contrib dir s) + Universes.constr_of_global (Coqlib.find_reference contrib dir s) in find_constant contrib_name dir s diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml index 046ecf775..c726fd5de 100644 --- a/plugins/cc/ccalgo.ml +++ b/plugins/cc/ccalgo.ml @@ -123,7 +123,7 @@ module PacMap=Map.Make(PacOrd) module PafMap=Map.Make(PafOrd) type cinfo= - {ci_constr: constructor; (* inductive type *) + {ci_constr: pconstructor; (* inductive type *) ci_arity: int; (* # args *) ci_nhyps: int} (* # projectable args *) @@ -142,13 +142,13 @@ type term= let rec term_equal t1 t2 = match t1, t2 with - | Symb c1, Symb c2 -> eq_constr c1 c2 + | Symb c1, Symb c2 -> eq_constr_nounivs c1 c2 | Product (s1, t1), Product (s2, t2) -> family_eq s1 s2 && family_eq t1 t2 | Eps i1, Eps i2 -> Id.equal i1 i2 | Appli (t1, u1), Appli (t2, u2) -> term_equal t1 t2 && term_equal u1 u2 - | Constructor {ci_constr=c1; ci_arity=i1; ci_nhyps=j1}, - Constructor {ci_constr=c2; ci_arity=i2; ci_nhyps=j2} -> - Int.equal i1 i2 && Int.equal j1 j2 && eq_constructor c1 c2 + | Constructor {ci_constr=(c1,u1); ci_arity=i1; ci_nhyps=j1}, + Constructor {ci_constr=(c2,u2); ci_arity=i2; ci_nhyps=j2} -> + Int.equal i1 i2 && Int.equal j1 j2 && eq_constructor c1 c2 (* FIXME check eq? *) | _ -> false open Hashset.Combine @@ -163,7 +163,7 @@ let rec hash_term = function | Product (s1, s2) -> combine3 2 (hash_sorts_family s1) (hash_sorts_family s2) | Eps i -> combine 3 (Id.hash i) | Appli (t1, t2) -> combine3 4 (hash_term t1) (hash_term t2) - | Constructor {ci_constr=c; ci_arity=i; ci_nhyps=j} -> combine4 5 (constructor_hash c) i j + | Constructor {ci_constr=(c,u); ci_arity=i; ci_nhyps=j} -> combine4 5 (constructor_hash c) i j type ccpattern = PApp of term * ccpattern list (* arguments are reversed *) @@ -234,7 +234,7 @@ type node = module Constrhash = Hashtbl.Make (struct type t = constr - let equal = eq_constr + let equal = eq_constr_nounivs let hash = hash_constr end) module Typehash = Constrhash @@ -404,32 +404,50 @@ let _B_ = Name (Id.of_string "A") let _body_ = mkProd(Anonymous,mkRel 2,mkRel 2) let cc_product s1 s2 = - mkLambda(_A_,mkSort(Termops.new_sort_in_family s1), - mkLambda(_B_,mkSort(Termops.new_sort_in_family s2),_body_)) + mkLambda(_A_,mkSort(Universes.new_sort_in_family s1), + mkLambda(_B_,mkSort(Universes.new_sort_in_family s2),_body_)) let rec constr_of_term = function - Symb s->s + Symb s-> applist_projection s [] | Product(s1,s2) -> cc_product s1 s2 | Eps id -> mkVar id - | Constructor cinfo -> mkConstruct cinfo.ci_constr + | Constructor cinfo -> mkConstructU cinfo.ci_constr | Appli (s1,s2)-> make_app [(constr_of_term s2)] s1 and make_app l=function Appli (s1,s2)->make_app ((constr_of_term s2)::l) s1 - | other -> applistc (constr_of_term other) l + | other -> + applist_proj other l +and applist_proj c l = + match c with + | Symb s -> applist_projection s l + | _ -> applistc (constr_of_term c) l +and applist_projection c l = + match kind_of_term c with + | Const c when Environ.is_projection (fst c) (Global.env()) -> + (match l with + | [] -> (* Expand the projection *) + let kn = fst c in + let ty,_ = Typeops.type_of_constant (Global.env ()) c in + let pb = Environ.lookup_projection kn (Global.env()) in + let ctx,_ = Term.decompose_prod_n_assum (pb.Declarations.proj_npars + 1) ty in + it_mkLambda_or_LetIn (mkProj(kn,mkRel 1)) ctx + | hd :: tl -> + applistc (mkProj (fst c, hd)) tl) + | _ -> applistc c l let rec canonize_name c = let func = canonize_name in match kind_of_term c with - | Const kn -> + | Const (kn,u) -> let canon_const = constant_of_kn (canonical_con kn) in - (mkConst canon_const) - | Ind (kn,i) -> + (mkConstU (canon_const,u)) + | Ind ((kn,i),u) -> let canon_mind = mind_of_kn (canonical_mind kn) in - (mkInd (canon_mind,i)) - | Construct ((kn,i),j) -> + (mkIndU ((canon_mind,i),u)) + | Construct (((kn,i),j),u) -> let canon_mind = mind_of_kn (canonical_mind kn) in - mkConstruct ((canon_mind,i),j) + mkConstructU (((canon_mind,i),j),u) | Prod (na,t,ct) -> mkProd (na,func t, func ct) | Lambda (na,t,ct) -> @@ -438,6 +456,9 @@ let rec canonize_name c = mkLetIn (na, func b,func t,func ct) | App (ct,l) -> mkApp (func ct,Array.smartmap func l) + | Proj(kn,c) -> + let canon_const = constant_of_kn (canonical_con kn) in + (mkProj (canon_const, func c)) | _ -> c (* rebuild a term from a pattern and a substitution *) @@ -469,7 +490,7 @@ let rec add_term state t= try Termhash.find uf.syms t with Not_found -> let b=next uf in - let trm = Termops.refresh_universes (constr_of_term t) in + let trm = constr_of_term t in let typ = pf_type_of state.gls trm in let typ = canonize_name typ in let new_node= diff --git a/plugins/cc/ccalgo.mli b/plugins/cc/ccalgo.mli index 5d286c732..0c5d6ca1f 100644 --- a/plugins/cc/ccalgo.mli +++ b/plugins/cc/ccalgo.mli @@ -11,7 +11,7 @@ open Term open Names type cinfo = - {ci_constr: constructor; (* inductive type *) + {ci_constr: pconstructor; (* inductive type *) ci_arity: int; (* # args *) ci_nhyps: int} (* # projectable args *) diff --git a/plugins/cc/ccproof.ml b/plugins/cc/ccproof.ml index 5244dcf17..4e1806f5a 100644 --- a/plugins/cc/ccproof.ml +++ b/plugins/cc/ccproof.ml @@ -20,7 +20,7 @@ type rule= | Refl of term | Trans of proof*proof | Congr of proof*proof - | Inject of proof*constructor*int*int + | Inject of proof*pconstructor*int*int and proof = {p_lhs:term;p_rhs:term;p_rule:rule} diff --git a/plugins/cc/ccproof.mli b/plugins/cc/ccproof.mli index b8a8d229a..50e3624d0 100644 --- a/plugins/cc/ccproof.mli +++ b/plugins/cc/ccproof.mli @@ -16,7 +16,7 @@ type rule= | Refl of term | Trans of proof*proof | Congr of proof*proof - | Inject of proof*constructor*int*int + | Inject of proof*pconstructor*int*int and proof = private {p_lhs:term;p_rhs:term;p_rule:rule} diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index ac148fe18..783abc5d8 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -23,21 +23,17 @@ open Pp open Errors open Util -let constant dir s = lazy (Coqlib.gen_constant "CC" dir s) - -let _f_equal = constant ["Init";"Logic"] "f_equal" - -let _eq_rect = constant ["Init";"Logic"] "eq_rect" - -let _refl_equal = constant ["Init";"Logic"] "eq_refl" - -let _sym_eq = constant ["Init";"Logic"] "eq_sym" - -let _trans_eq = constant ["Init";"Logic"] "eq_trans" - -let _eq = constant ["Init";"Logic"] "eq" - -let _False = constant ["Init";"Logic"] "False" +let reference dir s = Coqlib.gen_reference "CC" dir s + +let _f_equal = reference ["Init";"Logic"] "f_equal" +let _eq_rect = reference ["Init";"Logic"] "eq_rect" +let _refl_equal = reference ["Init";"Logic"] "eq_refl" +let _sym_eq = reference ["Init";"Logic"] "eq_sym" +let _trans_eq = reference ["Init";"Logic"] "eq_trans" +let _eq = reference ["Init";"Logic"] "eq" +let _False = reference ["Init";"Logic"] "False" +let _True = reference ["Init";"Logic"] "True" +let _I = reference ["Init";"Logic"] "I" let whd env= let infos=Closure.create_clos_infos Closure.betaiotazeta env in @@ -64,32 +60,36 @@ let rec decompose_term env sigma t= Appli(Appli(Product (sort_a,sort_b) , decompose_term env sigma a), decompose_term env sigma b) - | Construct c-> - let (mind,i_ind),i_con = c in + | Construct c -> + let (((mind,i_ind),i_con),u)= c in let canon_mind = mind_of_kn (canonical_mind mind) in let canon_ind = canon_mind,i_ind in let (oib,_)=Global.lookup_inductive (canon_ind) in let nargs=mis_constructor_nargs_env env (canon_ind,i_con) in - Constructor {ci_constr= (canon_ind,i_con); + Constructor {ci_constr= ((canon_ind,i_con),u); ci_arity=nargs; ci_nhyps=nargs-oib.mind_nparams} | Ind c -> - let mind,i_ind = c in + let (mind,i_ind),u = c in let canon_mind = mind_of_kn (canonical_mind mind) in - let canon_ind = canon_mind,i_ind in (Symb (mkInd canon_ind)) - | Const c -> + let canon_ind = canon_mind,i_ind in (Symb (mkIndU (canon_ind,u))) + | Const (c,u) -> let canon_const = constant_of_kn (canonical_con c) in - (Symb (mkConst canon_const)) + (Symb (mkConstU (canon_const,u))) + | Proj (p, c) -> + let canon_const = constant_of_kn (canonical_con p) in + (Appli (Symb (mkConst canon_const), decompose_term env sigma c)) | _ ->if closed0 t then (Symb t) else raise Not_found (* decompose equality in members and type *) +open Globnames let atom_of_constr env sigma term = let wh = (whd_delta env term) in let kot = kind_of_term wh in match kot with App (f,args)-> - if eq_constr f (Lazy.force _eq) && Int.equal (Array.length args) 3 + if is_global _eq f && Int.equal (Array.length args) 3 then `Eq (args.(0), decompose_term env sigma args.(1), decompose_term env sigma args.(2)) @@ -124,7 +124,7 @@ let non_trivial = function let patterns_of_constr env sigma nrels term= let f,args= try destApp (whd_delta env term) with DestKO -> raise Not_found in - if eq_constr f (Lazy.force _eq) && Int.equal (Array.length args) 3 + if is_global _eq f && Int.equal (Array.length args) 3 then let patt1,rels1 = pattern_of_constr env sigma args.(1) and patt2,rels2 = pattern_of_constr env sigma args.(2) in @@ -145,7 +145,7 @@ let patterns_of_constr env sigma nrels term= let rec quantified_atom_of_constr env sigma nrels term = match kind_of_term (whd_delta env term) with Prod (id,atom,ff) -> - if eq_constr ff (Lazy.force _False) then + if is_global _False ff then let patts=patterns_of_constr env sigma nrels atom in `Nrule patts else @@ -157,7 +157,7 @@ let rec quantified_atom_of_constr env sigma nrels term = let litteral_of_constr env sigma term= match kind_of_term (whd_delta env term) with | Prod (id,atom,ff) -> - if eq_constr ff (Lazy.force _False) then + if is_global _False ff then match (atom_of_constr env sigma atom) with `Eq(t,a,b) -> `Neq(t,a,b) | `Other(p) -> `Nother(p) @@ -218,13 +218,13 @@ let make_prb gls depth additionnal_terms = (* indhyps builds the array of arrays of constructor hyps for (ind largs) *) -let build_projection intype outtype (cstr:constructor) special default gls= +let build_projection intype outtype (cstr:pconstructor) special default gls= let env=pf_env gls in let (h,argv) = try destApp intype with DestKO -> (intype,[||]) in - let ind=destInd h in - let types=Inductiveops.arities_of_constructors env ind in + let ind,u=destInd h in + let types=Inductiveops.arities_of_constructors env (ind,u) in let lp=Array.length types in - let ci=pred (snd cstr) in + let ci=pred (snd(fst cstr)) in let branch i= let ti= prod_appvect types.(i) argv in let rc=fst (decompose_prod_assum ti) in @@ -243,60 +243,67 @@ let build_projection intype outtype (cstr:constructor) special default gls= let _M =mkMeta +let app_global f args k = + Tacticals.pf_constr_of_global f (fun fc -> k (mkApp (fc, args))) + +let new_app_global f args k = + Tacticals.New.pf_constr_of_global f (fun fc -> k (mkApp (fc, args))) + +let new_exact_check c = Proofview.V82.tactic (exact_check c) +let new_refine c = Proofview.V82.tactic (refine c) + let rec proof_tac p : unit Proofview.tactic = Proofview.Goal.enter begin fun gl -> let type_of = Tacmach.New.pf_type_of gl in + try (* type_of can raise exceptions *) match p.p_rule with - Ax c -> Proofview.V82.tactic (exact_check c) + Ax c -> new_exact_check c | SymAx c -> Proofview.V82.tactic begin fun gls -> - let l=constr_of_term p.p_lhs and - r=constr_of_term p.p_rhs in - let typ = Termops.refresh_universes (pf_type_of gls l) in - exact_check - (mkApp(Lazy.force _sym_eq,[|typ;r;l;c|])) gls + let l=constr_of_term p.p_lhs and + r=constr_of_term p.p_rhs in + let typ = (* Termops.refresh_universes *)pf_type_of gls l in + (app_global _sym_eq [|typ;r;l;c|] exact_check) gls end | Refl t -> Proofview.V82.tactic begin fun gls -> - let lr = constr_of_term t in - let typ = Termops.refresh_universes (pf_type_of gls lr) in - exact_check - (mkApp(Lazy.force _refl_equal,[|typ;constr_of_term t|])) gls + let lr = constr_of_term t in + let typ = (* Termops.refresh_universes *) (pf_type_of gls lr) in + (app_global _refl_equal [|typ;constr_of_term t|] exact_check) gls end | Trans (p1,p2)-> let t1 = constr_of_term p1.p_lhs and t2 = constr_of_term p1.p_rhs and t3 = constr_of_term p2.p_rhs in - let typ = Termops.refresh_universes (type_of t2) in - let prf = - mkApp(Lazy.force _trans_eq,[|typ;t1;t2;t3;_M 1;_M 2|]) in - Tacticals.New.tclTHENS (Proofview.V82.tactic (refine prf)) [(proof_tac p1);(proof_tac p2)] + let typ = (* Termops.refresh_universes *) (type_of t2) in + let prf = new_app_global _trans_eq [|typ;t1;t2;t3;_M 1;_M 2|] in + Tacticals.New.tclTHENS (prf new_refine) [(proof_tac p1);(proof_tac p2)] | Congr (p1,p2)-> let tf1=constr_of_term p1.p_lhs and tx1=constr_of_term p2.p_lhs and tf2=constr_of_term p1.p_rhs and tx2=constr_of_term p2.p_rhs in - let typf = Termops.refresh_universes (type_of tf1) in - let typx = Termops.refresh_universes (type_of tx1) in - let typfx = Termops.refresh_universes (type_of (mkApp (tf1,[|tx1|]))) in + let typf = (* Termops.refresh_universes *)(type_of tf1) in + let typx = (* Termops.refresh_universes *) (type_of tx1) in + let typfx = (* Termops.refresh_universes *) (type_of (mkApp (tf1,[|tx1|]))) in let id = Tacmach.New.of_old (fun gls -> pf_get_new_id (Id.of_string "f") gls) gl in let appx1 = mkLambda(Name id,typf,mkApp(mkRel 1,[|tx1|])) in let lemma1 = - mkApp(Lazy.force _f_equal, - [|typf;typfx;appx1;tf1;tf2;_M 1|]) in + app_global _f_equal + [|typf;typfx;appx1;tf1;tf2;_M 1|] in let lemma2= - mkApp(Lazy.force _f_equal, - [|typx;typfx;tf2;tx1;tx2;_M 1|]) in + app_global _f_equal + [|typx;typfx;tf2;tx1;tx2;_M 1|] in let prf = - mkApp(Lazy.force _trans_eq, + app_global _trans_eq [|typfx; mkApp(tf1,[|tx1|]); mkApp(tf2,[|tx1|]); - mkApp(tf2,[|tx2|]);_M 2;_M 3|]) in - Tacticals.New.tclTHENS (Proofview.V82.tactic (refine prf)) - [Tacticals.New.tclTHEN (Proofview.V82.tactic (refine lemma1)) (proof_tac p1); + mkApp(tf2,[|tx2|]);_M 2;_M 3|] in + Tacticals.New.tclTHENS (Proofview.V82.tactic (prf refine)) + [Tacticals.New.tclTHEN (Proofview.V82.tactic (lemma1 refine)) (proof_tac p1); Tacticals.New.tclFIRST - [Tacticals.New.tclTHEN (Proofview.V82.tactic (refine lemma2)) (proof_tac p2); + [Tacticals.New.tclTHEN (Proofview.V82.tactic (lemma2 refine)) (proof_tac p2); reflexivity; Proofview.tclZERO (UserError ("Congruence" , (Pp.str @@ -305,46 +312,48 @@ let rec proof_tac p : unit Proofview.tactic = let ti=constr_of_term prf.p_lhs in let tj=constr_of_term prf.p_rhs in let default=constr_of_term p.p_lhs in - let intype = Termops.refresh_universes (type_of ti) in - let outtype = Termops.refresh_universes (type_of default) in + let intype = (* Termops.refresh_universes *) (type_of ti) in + let outtype = (* Termops.refresh_universes *) (type_of default) in let special=mkRel (1+nargs-argind) in let proj = Tacmach.New.of_old (build_projection intype outtype cstr special default) gl in let injt= - mkApp (Lazy.force _f_equal,[|intype;outtype;proj;ti;tj;_M 1|]) in - Tacticals.New.tclTHEN (Proofview.V82.tactic (refine injt)) (proof_tac prf) + app_global _f_equal [|intype;outtype;proj;ti;tj;_M 1|] in + Tacticals.New.tclTHEN (Proofview.V82.tactic (injt refine)) (proof_tac prf) + with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e end let refute_tac c t1 t2 p = Proofview.Goal.enter begin fun gl -> let tt1=constr_of_term t1 and tt2=constr_of_term t2 in let intype = - Tacmach.New.of_old (fun gls -> Termops.refresh_universes (pf_type_of gls tt1)) gl + Tacmach.New.of_old (fun gls -> (* Termops.refresh_universes *) (pf_type_of gls tt1)) gl in - let neweq= - mkApp(Lazy.force _eq, - [|intype;tt1;tt2|]) in + let neweq= new_app_global _eq [|intype;tt1;tt2|] in let hid = Tacmach.New.of_old (pf_get_new_id (Id.of_string "Heq")) gl in let false_t=mkApp (c,[|mkVar hid|]) in - Tacticals.New.tclTHENS (assert_tac (Name hid) neweq) + Tacticals.New.tclTHENS (neweq (assert_tac (Name hid))) [proof_tac p; simplest_elim false_t] end +let refine_exact_check c gl = + let evm, _ = pf_apply e_type_of gl c in + Tacticals.tclTHEN (Refiner.tclEVARS evm) (exact_check c) gl + let convert_to_goal_tac c t1 t2 p = Proofview.Goal.enter begin fun gl -> let tt1=constr_of_term t1 and tt2=constr_of_term t2 in let sort = - Tacmach.New.of_old (fun gls -> Termops.refresh_universes (pf_type_of gls tt2)) gl + Tacmach.New.of_old (fun gls -> (* Termops.refresh_universes *) (pf_type_of gls tt2)) gl in - let neweq=mkApp(Lazy.force _eq,[|sort;tt1;tt2|]) in + let neweq= new_app_global _eq [|sort;tt1;tt2|] in let e = Tacmach.New.of_old (pf_get_new_id (Id.of_string "e")) gl in let x = Tacmach.New.of_old (pf_get_new_id (Id.of_string "X")) gl in let identity=mkLambda (Name x,sort,mkRel 1) in - let endt=mkApp (Lazy.force _eq_rect, - [|sort;tt1;identity;c;tt2;mkVar e|]) in - Tacticals.New.tclTHENS (assert_tac (Name e) neweq) - [proof_tac p; Proofview.V82.tactic (exact_check endt)] + let endt=app_global _eq_rect [|sort;tt1;identity;c;tt2;mkVar e|] in + Tacticals.New.tclTHENS (neweq (assert_tac (Name e))) + [proof_tac p; Proofview.V82.tactic (endt refine_exact_check)] end let convert_to_hyp_tac c1 t1 c2 t2 p = @@ -357,29 +366,36 @@ let convert_to_hyp_tac c1 t1 c2 t2 p = simplest_elim false_t] end -let discriminate_tac cstr p = +let discriminate_tac (cstr,u as cstru) p = Proofview.Goal.enter begin fun gl -> let t1=constr_of_term p.p_lhs and t2=constr_of_term p.p_rhs in let intype = - Tacmach.New.of_old (fun gls -> Termops.refresh_universes (pf_type_of gls t1)) gl + Tacmach.New.of_old (fun gls -> (* Termops.refresh_universes *) (pf_type_of gls t1)) gl in let concl = Proofview.Goal.concl gl in - let outsort = mkType (Termops.new_univ ()) in + (* let evm,outsort = Evd.new_sort_variable Evd.univ_rigid (project gls) in *) + (* let outsort = mkSort outsort in *) let xid = Tacmach.New.of_old (pf_get_new_id (Id.of_string "X")) gl in - let tid = Tacmach.New.of_old (pf_get_new_id (Id.of_string "t")) gl in - let identity=mkLambda(Name xid,outsort,mkLambda(Name tid,mkRel 1,mkRel 1)) in - let trivial = Tacmach.New.of_old (fun gls -> pf_type_of gls identity) gl in - let outtype = mkType (Termops.new_univ ()) in + (* let tid = Tacmach.New.of_old (pf_get_new_id (Id.of_string "t")) gl in *) + (* let identity=mkLambda(Name xid,outsort,mkLambda(Name tid,mkRel 1,mkRel 1)) in *) + let identity = Universes.constr_of_global _I in + (* let trivial=pf_type_of gls identity in *) + let trivial = Universes.constr_of_global _True in + let evm, outtype = Evd.new_sort_variable Evd.univ_flexible (Proofview.Goal.sigma gl) in + let outtype = mkSort outtype in let pred=mkLambda(Name xid,outtype,mkRel 1) in let hid = Tacmach.New.of_old (pf_get_new_id (Id.of_string "Heq")) gl in - let proj = Tacmach.New.of_old (build_projection intype outtype cstr trivial concl) gl in - let injt=mkApp (Lazy.force _f_equal, - [|intype;outtype;proj;t1;t2;mkVar hid|]) in - let endt=mkApp (Lazy.force _eq_rect, - [|outtype;trivial;pred;identity;concl;injt|]) in - let neweq=mkApp(Lazy.force _eq,[|intype;t1;t2|]) in - Tacticals.New.tclTHENS (assert_tac (Name hid) neweq) - [proof_tac p; Proofview.V82.tactic (exact_check endt)] + let proj = Tacmach.New.of_old (build_projection intype outtype cstru trivial concl) gl in + let injt=app_global _f_equal + [|intype;outtype;proj;t1;t2;mkVar hid|] in + let endt k = + injt (fun injt -> + app_global _eq_rect + [|outtype;trivial;pred;identity;concl;injt|] k) in + let neweq=new_app_global _eq [|intype;t1;t2|] in + Tacticals.New.tclTHEN (Proofview.V82.tclEVARS evm) + (Tacticals.New.tclTHENS (neweq (assert_tac (Name hid))) + [proof_tac p; Proofview.V82.tactic (endt exact_check)]) end (* wrap everything *) @@ -389,7 +405,7 @@ let build_term_to_complete uf meta pac = let real_args = List.map (fun i -> constr_of_term (term uf i)) pac.args in let dummy_args = List.rev (List.init pac.arity meta) in let all_args = List.rev_append real_args dummy_args in - applistc (mkConstruct cinfo.ci_constr) all_args + applistc (mkConstructU cinfo.ci_constr) all_args let cc_tactic depth additionnal_terms = Proofview.Goal.enter begin fun gl -> @@ -457,7 +473,7 @@ let congruence_tac depth l = might be slow now, let's rather do something equivalent to a "simple apply refl_equal" *) -let simple_reflexivity () = apply (Lazy.force _refl_equal) +let simple_reflexivity () = apply (Universes.constr_of_global _refl_equal) (* The [f_equal] tactic. @@ -472,15 +488,17 @@ let f_equal = let type_of = Tacmach.New.pf_type_of gl in let cut_eq c1 c2 = try (* type_of can raise an exception *) - let ty = Termops.refresh_universes (type_of c1) in - Tacticals.New.tclTRY (Tacticals.New.tclTHEN - (Tactics.cut (mkApp (Lazy.force _eq, [|ty; c1; c2|]))) - (Tacticals.New.tclTRY (Proofview.V82.tactic (simple_reflexivity ())))) + let ty = (* Termops.refresh_universes *) (type_of c1) in + if eq_constr_nounivs c1 c2 then Proofview.tclUNIT () + else + Tacticals.New.tclTRY (Tacticals.New.tclTHEN + ((new_app_global _eq [|ty; c1; c2|]) Tactics.cut) + (Tacticals.New.tclTRY ((new_app_global _refl_equal [||]) (fun c -> Proofview.V82.tactic (apply c))))) with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e in Proofview.tclORELSE begin match kind_of_term concl with - | App (r,[|_;t;t'|]) when eq_constr r (Lazy.force _eq) -> + | App (r,[|_;t;t'|]) when Globnames.is_global _eq r -> begin match kind_of_term t, kind_of_term t' with | App (f,v), App (f',v') when Int.equal (Array.length v) (Array.length v') -> let rec cuts i = diff --git a/plugins/cc/cctac.mli b/plugins/cc/cctac.mli index a022a07da..7c1d9f1c0 100644 --- a/plugins/cc/cctac.mli +++ b/plugins/cc/cctac.mli @@ -1,3 +1,4 @@ + (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) diff --git a/plugins/decl_mode/decl_interp.ml b/plugins/decl_mode/decl_interp.ml index 505d7dba5..e0aee15e6 100644 --- a/plugins/decl_mode/decl_interp.ml +++ b/plugins/decl_mode/decl_interp.ml @@ -144,26 +144,26 @@ let intern_proof_instr globs instr= (* INTERP *) let interp_justification_items sigma env = - Option.map (List.map (fun c ->understand sigma env (fst c))) + Option.map (List.map (fun c -> fst (*FIXME*)(understand sigma env (fst c)))) let interp_constr check_sort sigma env c = if check_sort then - understand sigma env ~expected_type:IsType (fst c) + fst (understand sigma env ~expected_type:IsType (fst c) (* FIXME *)) else - understand sigma env (fst c) + fst (understand sigma env (fst c)) let special_whd env = let infos=Closure.create_clos_infos Closure.betadeltaiota env in (fun t -> Closure.whd_val infos (Closure.inject t)) -let _eq = Globnames.constr_of_global (Coqlib.glob_eq) +let _eq = lazy (Universes.constr_of_global (Coqlib.glob_eq)) let decompose_eq env id = let typ = Environ.named_type id env in let whd = special_whd env typ in match kind_of_term whd with App (f,args)-> - if eq_constr f _eq && Int.equal (Array.length args) 3 + if eq_constr f (Lazy.force _eq) && Int.equal (Array.length args) 3 then args.(0) else error "Previous step is not an equality." | _ -> error "Previous step is not an equality." @@ -173,7 +173,7 @@ let get_eq_typ info env = typ let interp_constr_in_type typ sigma env c = - understand sigma env (fst c) ~expected_type:(OfType typ) + fst (understand sigma env (fst c) ~expected_type:(OfType typ))(*FIXME*) let interp_statement interp_it sigma env st = {st_label=st.st_label; @@ -213,7 +213,7 @@ let rec match_hyps blend names constr = function qhyp::rhyps,head let interp_hyps_gen inject blend sigma env hyps head = - let constr=understand sigma env (glob_constr_of_hyps inject hyps head) in + let constr= fst(*FIXME*) (understand sigma env (glob_constr_of_hyps inject hyps head)) in match_hyps blend [] constr hyps let interp_hyps sigma env hyps = fst (interp_hyps_gen fst (fun x _ -> x) sigma env hyps glob_prop) @@ -246,7 +246,7 @@ let rec glob_of_pat = add_params (pred n) (GHole(Loc.ghost, Evar_kinds.TomatchTypeParameter(ind,n), None)::q) in let args = List.map glob_of_pat lpat in - glob_app(loc,GRef(Loc.ghost,Globnames.ConstructRef cstr), + glob_app(loc,GRef(Loc.ghost,Globnames.ConstructRef cstr,None), add_params mind.Declarations.mind_nparams args) let prod_one_hyp = function @@ -333,7 +333,7 @@ let interp_cases info sigma env params (pat:cases_pattern_expr) hyps = (if Int.equal expected 0 then str "none" else int expected) ++ spc () ++ str "expected.") in let app_ind = - let rind = GRef (Loc.ghost,Globnames.IndRef pinfo.per_ind) in + let rind = GRef (Loc.ghost,Globnames.IndRef pinfo.per_ind,None) in let rparams = List.map detype_ground pinfo.per_params in let rparams_rec = List.map @@ -365,7 +365,7 @@ let interp_cases info sigma env params (pat:cases_pattern_expr) hyps = let term3=List.fold_right let_in_one_alias aliases term2 in let term4=List.fold_right prod_one_id loc_ids term3 in let term5=List.fold_right prod_one_hyp params term4 in - let constr = understand sigma env term5 in + let constr = fst (understand sigma env term5)(*FIXME*) in let tparams,nam4,rest4 = match_args destProd [] constr params in let tpatvars,nam3,rest3 = match_args destProd nam4 rest4 loc_ids in let taliases,nam2,rest2 = match_aliases nam3 rest3 aliases in @@ -409,7 +409,7 @@ let interp_suffices_clause sigma env (hyps,cot)= nenv,res let interp_casee sigma env = function - Real c -> Real (understand sigma env (fst c)) + Real c -> Real (fst (understand sigma env (fst c)))(*FIXME*) | Virtual cut -> Virtual (interp_cut (interp_no_bind (interp_statement (interp_constr true))) sigma env cut) let abstract_one_arg = function @@ -425,7 +425,7 @@ let glob_constr_of_fun args body = List.fold_right abstract_one_arg args (fst body) let interp_fun sigma env args body = - let constr=understand sigma env (glob_constr_of_fun args body) in + let constr=fst (*FIXME*) (understand sigma env (glob_constr_of_fun args body)) in match_args destLambda [] constr args let rec interp_bare_proof_instr info (sigma:Evd.evar_map) (env:Environ.env) = function @@ -448,7 +448,7 @@ let rec interp_bare_proof_instr info (sigma:Evd.evar_map) (env:Environ.env) = fu let tparams,tpat,thyps = interp_cases info sigma env params pat hyps in Pcase (tparams,tpat,thyps) | Ptake witl -> - Ptake (List.map (fun c -> understand sigma env (fst c)) witl) + Ptake (List.map (fun c -> fst (*FIXME*) (understand sigma env (fst c))) witl) | Pconsider (c,hyps) -> Pconsider (interp_constr false sigma env c, interp_hyps sigma env hyps) | Pper (et,c) -> Pper (et,interp_casee sigma env c) diff --git a/plugins/decl_mode/decl_proof_instr.ml b/plugins/decl_mode/decl_proof_instr.ml index de57330ec..8647ca676 100644 --- a/plugins/decl_mode/decl_proof_instr.ml +++ b/plugins/decl_mode/decl_proof_instr.ml @@ -292,13 +292,13 @@ let rec replace_in_list m l = function let enstack_subsubgoals env se stack gls= let hd,params = decompose_app (special_whd gls se.se_type) in match kind_of_term hd with - Ind ind when is_good_inductive env ind -> + Ind (ind,u as indu) when is_good_inductive env ind -> (* MS: FIXME *) let mib,oib= Inductive.lookup_mind_specif env ind in let gentypes= - Inductive.arities_of_constructors ind (mib,oib) in + Inductive.arities_of_constructors indu (mib,oib) in let process i gentyp = - let constructor = mkConstruct(ind,succ i) + let constructor = mkConstructU ((ind,succ i),u) (* constructors numbering*) in let appterm = applist (constructor,params) in let apptype = prod_applist gentyp params in @@ -357,7 +357,7 @@ let find_subsubgoal c ctyp skip submetas gls = try let unifier = Unification.w_unify env se.se_evd Reduction.CUMUL - ~flags:Unification.elim_flags ctyp se.se_type in + ~flags:(Unification.elim_flags ()) ctyp se.se_type in if n <= 0 then {se with se_evd=meta_assign se.se_meta @@ -488,14 +488,14 @@ let instr_cut mkstat _thus _then cut gls0 = (* iterated equality *) -let _eq = Globnames.constr_of_global (Coqlib.glob_eq) +let _eq = lazy (Universes.constr_of_global (Coqlib.glob_eq)) let decompose_eq id gls = let typ = pf_get_hyp_typ gls id in let whd = (special_whd gls typ) in match kind_of_term whd with App (f,args)-> - if eq_constr f _eq && Int.equal (Array.length args) 3 + if eq_constr f (Lazy.force _eq) && Int.equal (Array.length args) 3 then (args.(0), args.(1), args.(2)) @@ -530,14 +530,14 @@ let instr_rew _thus rew_side cut gls0 = else tclIDTAC gls in match rew_side with Lhs -> - let new_eq = mkApp(_eq,[|typ;cut.cut_stat.st_it;rhs|]) in + let new_eq = mkApp(Lazy.force _eq,[|typ;cut.cut_stat.st_it;rhs|]) in tclTHENS (Proofview.V82.of_tactic (assert_postpone c_id new_eq)) [tclTHEN tcl_erase_info (tclTHENS (Proofview.V82.of_tactic (transitivity lhs)) [just_tac;exact_check (mkVar last_id)]); thus_tac new_eq] gls0 | Rhs -> - let new_eq = mkApp(_eq,[|typ;lhs;cut.cut_stat.st_it|]) in + let new_eq = mkApp(Lazy.force _eq,[|typ;lhs;cut.cut_stat.st_it|]) in tclTHENS (Proofview.V82.of_tactic (assert_postpone c_id new_eq)) [tclTHEN tcl_erase_info (tclTHENS (Proofview.V82.of_tactic (transitivity rhs)) @@ -663,11 +663,11 @@ let conjunction_arity id gls = let hd,params = decompose_app (special_whd gls typ) in let env =pf_env gls in match kind_of_term hd with - Ind ind when is_good_inductive env ind -> + Ind (ind,u as indu) when is_good_inductive env ind -> let mib,oib= Inductive.lookup_mind_specif env ind in let gentypes= - Inductive.arities_of_constructors ind (mib,oib) in + Inductive.arities_of_constructors indu (mib,oib) in let _ = if not (Int.equal (Array.length gentypes) 1) then raise Not_found in let apptype = prod_applist gentypes.(0) params in let rc,_ = Reduction.dest_prod env apptype in @@ -832,7 +832,7 @@ let build_per_info etype casee gls = let ctyp=pf_type_of gls casee in let is_dep = dependent casee concl in let hd,args = decompose_app (special_whd gls ctyp) in - let ind = + let (ind,u as indu) = try destInd hd with DestKO -> @@ -1031,7 +1031,7 @@ let rec st_assoc id = function let thesis_for obj typ per_info env= let rc,hd1=decompose_prod typ in let cind,all_args=decompose_app typ in - let ind = destInd cind in + let ind,u = destInd cind in let _ = if not (eq_ind ind per_info.per_ind) then errorlabstrm "thesis_for" ((Printer.pr_constr_env env obj) ++ spc () ++ @@ -1166,7 +1166,7 @@ let hrec_for fix_id per_info gls obj_id = let typ=pf_get_hyp_typ gls obj_id in let rc,hd1=decompose_prod typ in let cind,all_args=decompose_app typ in - let ind = destInd cind in assert (eq_ind ind per_info.per_ind); + let ind,u = destInd cind in assert (eq_ind ind per_info.per_ind); let params,args= List.chop per_info.per_nparams all_args in assert begin try List.for_all2 eq_constr params per_info.per_params with @@ -1205,7 +1205,8 @@ let rec execute_cases fix_name per_info tacnext args objs nhrec tree gls = let env=pf_env gls in let ctyp=pf_type_of gls casee in let hd,all_args = decompose_app (special_whd gls ctyp) in - let _ = assert (eq_ind (destInd hd) ind) in (* just in case *) + let ind', u = destInd hd in + let _ = assert (eq_ind ind' ind) in (* just in case *) let params,real_args = List.chop nparams all_args in let abstract_obj c body = let typ=pf_type_of gls c in @@ -1213,7 +1214,7 @@ let rec execute_cases fix_name per_info tacnext args objs nhrec tree gls = let elim_pred = List.fold_right abstract_obj real_args (lambda_create env (ctyp,subst_term casee concl)) in let case_info = Inductiveops.make_case_info env ind RegularStyle in - let gen_arities = Inductive.arities_of_constructors ind spec in + let gen_arities = Inductive.arities_of_constructors (ind,u) spec in let f_ids typ = let sign = (prod_assum (prod_applist typ params)) in diff --git a/plugins/decl_mode/g_decl_mode.ml4 b/plugins/decl_mode/g_decl_mode.ml4 index 7c9ef3c2a..36abb86cc 100644 --- a/plugins/decl_mode/g_decl_mode.ml4 +++ b/plugins/decl_mode/g_decl_mode.ml4 @@ -176,7 +176,7 @@ GLOBAL: proof_instr; statement : [[ i=ident ; ":" ; c=constr -> {st_label=Name i;st_it=c} | i=ident -> {st_label=Anonymous; - st_it=Constrexpr.CRef (Libnames.Ident (!@loc, i))} + st_it=Constrexpr.CRef (Libnames.Ident (!@loc, i), None)} | c=constr -> {st_label=Anonymous;st_it=c} ]]; constr_or_thesis : @@ -189,7 +189,7 @@ GLOBAL: proof_instr; | [ i=ident ; ":" ; cot=constr_or_thesis -> {st_label=Name i;st_it=cot} | i=ident -> {st_label=Anonymous; - st_it=This (Constrexpr.CRef (Libnames.Ident (!@loc, i)))} + st_it=This (Constrexpr.CRef (Libnames.Ident (!@loc, i), None))} | c=constr -> {st_label=Anonymous;st_it=This c} ] ]; diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml index 791294902..74de31368 100644 --- a/plugins/extraction/extract_env.ml +++ b/plugins/extraction/extract_env.ml @@ -131,7 +131,7 @@ end exception Impossible let check_arity env cb = - let t = Typeops.type_of_constant_type env cb.const_type in + let t = cb.const_type in if Reduction.is_arity env t then raise Impossible let check_fix env cb i = diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index 3927ad328..5b79f6d78 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -203,27 +203,28 @@ let oib_equal o1 o2 = Id.equal o1.mind_typename o2.mind_typename && List.equal eq_rel_declaration o1.mind_arity_ctxt o2.mind_arity_ctxt && begin match o1.mind_arity, o2.mind_arity with - | Monomorphic {mind_user_arity=c1; mind_sort=s1}, - Monomorphic {mind_user_arity=c2; mind_sort=s2} -> + (* | Monomorphic {mind_user_arity=c1; mind_sort=s1}, *) + (* Monomorphic {mind_user_arity=c2; mind_sort=s2} -> *) + (* eq_constr c1 c2 && Sorts.equal s1 s2 *) + (* | ma1, ma2 -> Pervasives.(=) ma1 ma2 (\** FIXME: this one is surely wrong *\) end && *) + (* Array.equal Id.equal o1.mind_consnames o2.mind_consnames *) + | {mind_user_arity=c1; mind_sort=s1}, + {mind_user_arity=c2; mind_sort=s2} -> eq_constr c1 c2 && Sorts.equal s1 s2 - | Polymorphic p1, Polymorphic p2 -> - let eq o1 o2 = Option.equal Univ.Universe.equal o1 o2 in - List.equal eq p1.poly_param_levels p2.poly_param_levels && - Univ.Universe.equal p1.poly_level p2.poly_level - | Monomorphic _, Polymorphic _ | Polymorphic _, Monomorphic _ -> false end && Array.equal Id.equal o1.mind_consnames o2.mind_consnames let mib_equal m1 m2 = Array.equal oib_equal m1.mind_packets m1.mind_packets && - (m1.mind_record : bool) == m2.mind_record && + (m1.mind_record) = m2.mind_record && (*FIXME*) (m1.mind_finite : bool) == m2.mind_finite && Int.equal m1.mind_ntypes m2.mind_ntypes && List.equal eq_named_declaration m1.mind_hyps m2.mind_hyps && Int.equal m1.mind_nparams m2.mind_nparams && Int.equal m1.mind_nparams_rec m2.mind_nparams_rec && List.equal eq_rel_declaration m1.mind_params_ctxt m2.mind_params_ctxt && - Univ.eq_constraint m1.mind_constraints m2.mind_constraints + Pervasives.(=) m1.mind_universes m2.mind_universes (** FIXME *) + (* m1.mind_universes = m2.mind_universes *) (*S Extraction of a type. *) @@ -278,10 +279,10 @@ let rec extract_type env db j c args = if n > List.length db then Tunknown else let n' = List.nth db (n-1) in if Int.equal n' 0 then Tunknown else Tvar n') - | Const kn -> + | Const (kn,u as c) -> let r = ConstRef kn in let cb = lookup_constant kn env in - let typ = Typeops.type_of_constant_type env cb.const_type in + let typ,_ = Typeops.type_of_constant env c in (match flag_of_type env typ with | (Logic,_) -> assert false (* Cf. logical cases above *) | (Info, TypeScheme) -> @@ -306,7 +307,7 @@ let rec extract_type env db j c args = (* We try to reduce. *) let newc = applist (Mod_subst.force_constr lbody, args) in extract_type env db j newc [])) - | Ind (kn,i) -> + | Ind ((kn,i),u) -> let s = (extract_ind env kn).ind_packets.(i).ip_sign in extract_type_app env db (IndRef (kn,i),s) args | Case _ | Fix _ | CoFix _ -> Tunknown @@ -388,8 +389,10 @@ and extract_ind env kn = (* kn is supposed to be in long form *) let packets = Array.mapi (fun i mip -> - let ar = Inductive.type_of_inductive env (mib,mip) in - let info = (fst (flag_of_type env ar) == Info) in + let (ind,u), ctx = + Universes.fresh_inductive_instance env (kn,i) in + let ar = Inductive.type_of_inductive env ((mib,mip),u) in + let info = (fst (flag_of_type env ar) = Info) in let s,v = if info then type_sign_vl env ar else [],[] in let t = Array.make (Array.length mip.mind_nf_lc) [] in { ip_typename = mip.mind_typename; @@ -397,21 +400,21 @@ and extract_ind env kn = (* kn is supposed to be in long form *) ip_logical = not info; ip_sign = s; ip_vars = v; - ip_types = t }) + ip_types = t }, u) mib.mind_packets in add_ind kn mib {ind_kind = Standard; ind_nparams = npar; - ind_packets = packets; + ind_packets = Array.map fst packets; ind_equiv = equiv }; (* Second pass: we extract constructors *) for i = 0 to mib.mind_ntypes - 1 do - let p = packets.(i) in + let p,u = packets.(i) in if not p.ip_logical then - let types = arities_of_constructors env (kn,i) in + let types = arities_of_constructors env ((kn,i),u) in for j = 0 to Array.length types - 1 do let t = snd (decompose_prod_n npar types.(j)) in let prods,head = dest_prod epar t in @@ -433,7 +436,7 @@ and extract_ind env kn = (* kn is supposed to be in long form *) if is_custom r then raise (I Standard); if not mib.mind_finite then raise (I Coinductive); if not (Int.equal mib.mind_ntypes 1) then raise (I Standard); - let p = packets.(0) in + let p,u = packets.(0) in if p.ip_logical then raise (I Standard); if not (Int.equal (Array.length p.ip_types) 1) then raise (I Standard); let typ = p.ip_types.(0) in @@ -442,7 +445,7 @@ and extract_ind env kn = (* kn is supposed to be in long form *) Int.equal (List.length l) 1 && not (type_mem_kn kn (List.hd l)) then raise (I Singleton); if List.is_empty l then raise (I Standard); - if not mib.mind_record then raise (I Standard); + if Option.is_empty mib.mind_record then raise (I Standard); (* Now we're sure it's a record. *) (* First, we find its field names. *) let rec names_prod t = match kind_of_term t with @@ -476,7 +479,7 @@ and extract_ind env kn = (* kn is supposed to be in long form *) (* If so, we use this information. *) begin try let n = nb_default_params env - (Inductive.type_of_inductive env (mib,mip0)) + (Inductive.type_of_inductive env ((mib,mip0),u)) in let check_proj kn = if Cset.mem kn !projs then add_projection n kn in List.iter (Option.iter check_proj) (lookup_projections ip) @@ -487,7 +490,7 @@ and extract_ind env kn = (* kn is supposed to be in long form *) in let i = {ind_kind = ind_info; ind_nparams = npar; - ind_packets = packets; + ind_packets = Array.map fst packets; ind_equiv = equiv } in add_ind kn mib i; @@ -522,7 +525,7 @@ and mlt_env env r = match r with | _ -> None with Not_found -> let cb = Environ.lookup_constant kn env in - let typ = Typeops.type_of_constant_type env cb.const_type in + let typ = cb.const_type (* FIXME not sure if we should instantiate univs here *) in match cb.const_body with | Undef _ | OpaqueDef _ -> None | Def l_body -> @@ -550,7 +553,7 @@ let record_constant_type env kn opt_typ = lookup_type kn with Not_found -> let typ = match opt_typ with - | None -> Typeops.type_of_constant env kn + | None -> (lookup_constant kn env).const_type | Some typ -> typ in let mlt = extract_type env [] 1 typ [] in let schema = (type_maxvar mlt, mlt) @@ -605,10 +608,12 @@ let rec extract_term env mle mlt c args = with NotDefault d -> let mle' = Mlenv.push_std_type mle (Tdummy d) in ast_pop (extract_term env' mle' mlt c2 args')) - | Const kn -> - extract_cst_app env mle mlt kn args - | Construct cp -> - extract_cons_app env mle mlt cp args + | Const (kn,u) -> + extract_cst_app env mle mlt kn u args + | Construct (cp,u) -> + extract_cons_app env mle mlt cp u args + | Proj (p, c) -> + extract_cst_app env mle mlt p Univ.Instance.empty (c :: args) | Rel n -> (* As soon as the expected [mlt] for the head is known, *) (* we unify it with an fresh copy of the stored type of [Rel n]. *) @@ -656,7 +661,7 @@ and make_mlargs env e s args typs = (*s Extraction of a constant applied to arguments. *) -and extract_cst_app env mle mlt kn args = +and extract_cst_app env mle mlt kn u args = (* First, the [ml_schema] of the constant, in expanded version. *) let nb,t = record_constant_type env kn None in let schema = nb, expand env t in @@ -729,7 +734,7 @@ and extract_cst_app env mle mlt kn args = they are fixed, and thus are not used for the computation. \end{itemize} *) -and extract_cons_app env mle mlt (((kn,i) as ip,j) as cp) args = +and extract_cons_app env mle mlt (((kn,i) as ip,j) as cp) u args = (* First, we build the type of the constructor, stored in small pieces. *) let mi = extract_ind env kn in let params_nb = mi.ind_nparams in @@ -971,7 +976,7 @@ let extract_fixpoint env vkn (fi,ti,ci) = let extract_constant env kn cb = let r = ConstRef kn in - let typ = Typeops.type_of_constant_type env cb.const_type in + let typ = cb.const_type in let warn_info () = if not (is_custom r) then add_info_axiom r in let warn_log () = if not (constant_has_body cb) then add_log_axiom r in @@ -1018,7 +1023,7 @@ let extract_constant env kn cb = let extract_constant_spec env kn cb = let r = ConstRef kn in - let typ = Typeops.type_of_constant_type env cb.const_type in + let typ = cb.const_type in match flag_of_type env typ with | (Logic, TypeScheme) -> Stype (r, [], Some (Tdummy Ktype)) | (Logic, Default) -> Sval (r, Tdummy Kother) diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml index ba21c6cbf..133f4ada9 100644 --- a/plugins/extraction/table.ml +++ b/plugins/extraction/table.ml @@ -645,7 +645,7 @@ let implicits_of_global r = try Refmap'.find r !implicits_table with Not_found -> [] let add_implicits r l = - let typ = Global.type_of_global r in + let typ = Global.type_of_global_unsafe r in let rels,_ = decompose_prod (Reduction.whd_betadeltaiota (Global.env ()) typ) in let names = List.rev_map fst rels in @@ -816,7 +816,7 @@ let extract_constant_inline inline r ids s = match g with | ConstRef kn -> let env = Global.env () in - let typ = Typeops.type_of_constant env kn in + let typ = (Environ.lookup_constant kn env).const_type in let typ = Reduction.whd_betadeltaiota env typ in if Reduction.is_arity env typ then begin diff --git a/plugins/firstorder/formula.ml b/plugins/firstorder/formula.ml index 03a832e90..430b549d9 100644 --- a/plugins/firstorder/formula.ml +++ b/plugins/firstorder/formula.ml @@ -43,7 +43,7 @@ let rec nb_prod_after n c= | _ -> 0 let construct_nhyps ind gls = - let nparams = (fst (Global.lookup_inductive ind)).mind_nparams in + let nparams = (fst (Global.lookup_inductive (fst ind))).mind_nparams in let constr_types = Inductiveops.arities_of_constructors (pf_env gls) ind in let hyp = nb_prod_after nparams in Array.map hyp constr_types @@ -67,10 +67,10 @@ let special_whd gl= type kind_of_formula= Arrow of constr*constr - | False of inductive*constr list - | And of inductive*constr list*bool - | Or of inductive*constr list*bool - | Exists of inductive*constr list + | False of pinductive*constr list + | And of pinductive*constr list*bool + | Or of pinductive*constr list*bool + | Exists of pinductive*constr list | Forall of constr*constr | Atom of constr @@ -85,11 +85,11 @@ let kind_of_formula gl term = |_-> match match_with_nodep_ind cciterm with Some (i,l,n)-> - let ind=destInd i in + let ind,u=destInd i in let (mib,mip) = Global.lookup_inductive ind in let nconstr=Array.length mip.mind_consnames in if Int.equal nconstr 0 then - False(ind,l) + False((ind,u),l) else let has_realargs=(n>0) in let is_trivial= @@ -102,9 +102,9 @@ let kind_of_formula gl term = Atom cciterm else if Int.equal nconstr 1 then - And(ind,l,is_trivial) + And((ind,u),l,is_trivial) else - Or(ind,l,is_trivial) + Or((ind,u),l,is_trivial) | _ -> match match_with_sigma_type cciterm with Some (i,l)-> Exists((destInd i),l) @@ -186,19 +186,19 @@ type right_pattern = type left_arrow_pattern= LLatom - | LLfalse of inductive*constr list - | LLand of inductive*constr list - | LLor of inductive*constr list + | LLfalse of pinductive*constr list + | LLand of pinductive*constr list + | LLor of pinductive*constr list | LLforall of constr - | LLexists of inductive*constr list + | LLexists of pinductive*constr list | LLarrow of constr*constr*constr type left_pattern= Lfalse - | Land of inductive - | Lor of inductive + | Land of pinductive + | Lor of pinductive | Lforall of metavariable*constr*bool - | Lexists of inductive + | Lexists of pinductive | LA of constr*left_arrow_pattern type t={id:global_reference; diff --git a/plugins/firstorder/formula.mli b/plugins/firstorder/formula.mli index 59b363393..d12b106cc 100644 --- a/plugins/firstorder/formula.mli +++ b/plugins/firstorder/formula.mli @@ -25,9 +25,9 @@ type ('a,'b) sum = Left of 'a | Right of 'b type counter = bool -> metavariable -val construct_nhyps : inductive -> Proof_type.goal Tacmach.sigma -> int array +val construct_nhyps : pinductive -> Proof_type.goal Tacmach.sigma -> int array -val ind_hyps : int -> inductive -> constr list -> +val ind_hyps : int -> pinductive -> constr list -> Proof_type.goal Tacmach.sigma -> rel_context array type atoms = {positive:constr list;negative:constr list} @@ -49,19 +49,19 @@ type right_pattern = type left_arrow_pattern= LLatom - | LLfalse of inductive*constr list - | LLand of inductive*constr list - | LLor of inductive*constr list + | LLfalse of pinductive*constr list + | LLand of pinductive*constr list + | LLor of pinductive*constr list | LLforall of constr - | LLexists of inductive*constr list + | LLexists of pinductive*constr list | LLarrow of constr*constr*constr type left_pattern= Lfalse - | Land of inductive - | Lor of inductive + | Land of pinductive + | Lor of pinductive | Lforall of metavariable*constr*bool - | Lexists of inductive + | Lexists of pinductive | LA of constr*left_arrow_pattern type t={id: global_reference; diff --git a/plugins/firstorder/ground.ml b/plugins/firstorder/ground.ml index 6c1709140..e0f4fa95f 100644 --- a/plugins/firstorder/ground.ml +++ b/plugins/firstorder/ground.ml @@ -18,7 +18,7 @@ let update_flags ()= let predref=ref Names.Cpred.empty in let f coe= try - let kn=destConst (Classops.get_coercion_value coe) in + let kn= fst (destConst (Classops.get_coercion_value coe)) in predref:=Names.Cpred.add kn !predref with DestKO -> () in diff --git a/plugins/firstorder/instances.ml b/plugins/firstorder/instances.ml index fe22708a0..c6db6a49f 100644 --- a/plugins/firstorder/instances.ml +++ b/plugins/firstorder/instances.ml @@ -101,6 +101,8 @@ let dummy_constr=mkMeta (-1) let dummy_bvid=Id.of_string "x" +let constr_of_global = Universes.constr_of_global + let mk_open_instance id gl m t= let env=pf_env gl in let evmap=Refiner.project gl in @@ -128,7 +130,7 @@ let mk_open_instance id gl m t= GLambda(loc,name,k,GHole (Loc.ghost,Evar_kinds.BinderType name,None),t1) | _-> anomaly (Pp.str "can't happen") in let ntt=try - Pretyping.understand evmap env (raux m rawt) + fst (Pretyping.understand evmap env (raux m rawt))(*FIXME*) with e when Errors.noncritical e -> error "Untypable instance, maybe higher-order non-prenex quantification" in decompose_lam_n_assum m ntt diff --git a/plugins/firstorder/rules.ml b/plugins/firstorder/rules.ml index 6d9af2bbf..31a1e6cb0 100644 --- a/plugins/firstorder/rules.ml +++ b/plugins/firstorder/rules.ml @@ -53,7 +53,7 @@ let clear_global=function VarRef id->clear [id] | _->tclIDTAC - +let constr_of_global = Universes.constr_of_global (* connection rules *) let axiom_tac t seq= @@ -117,14 +117,14 @@ let left_false_tac id= (* We use this function for false, and, or, exists *) -let ll_ind_tac ind largs backtrack id continue seq gl= - let rcs=ind_hyps 0 ind largs gl in +let ll_ind_tac (ind,u as indu) largs backtrack id continue seq gl= + let rcs=ind_hyps 0 indu largs gl in let vargs=Array.of_list largs in (* construire le terme H->B, le generaliser etc *) let myterm i= let rc=rcs.(i) in let p=List.length rc in - let cstr=mkApp ((mkConstruct (ind,(i+1))),vargs) in + let cstr=mkApp ((mkConstructU ((ind,(i+1)),u)),vargs) in let vars=Array.init p (fun j->mkRel (p-j)) in let capply=mkApp ((lift p cstr),vars) in let head=mkApp ((lift p (constr_of_global id)),[|capply|]) in @@ -204,8 +204,8 @@ let ll_forall_tac prod backtrack id continue seq= let constant str = Coqlib.gen_constant "User" ["Init";"Logic"] str let defined_connectives=lazy - [AllOccurrences,EvalConstRef (destConst (constant "not")); - AllOccurrences,EvalConstRef (destConst (constant "iff"))] + [AllOccurrences,EvalConstRef (fst (destConst (constant "not"))); + AllOccurrences,EvalConstRef (fst (destConst (constant "iff")))] let normalize_evaluables= onAllHypsAndConcl diff --git a/plugins/firstorder/rules.mli b/plugins/firstorder/rules.mli index bfebbaaf8..180f6f5da 100644 --- a/plugins/firstorder/rules.mli +++ b/plugins/firstorder/rules.mli @@ -33,19 +33,19 @@ val or_tac : seqtac with_backtracking val arrow_tac : seqtac with_backtracking -val left_and_tac : inductive -> lseqtac with_backtracking +val left_and_tac : pinductive -> lseqtac with_backtracking -val left_or_tac : inductive -> lseqtac with_backtracking +val left_or_tac : pinductive -> lseqtac with_backtracking val left_false_tac : global_reference -> tactic -val ll_ind_tac : inductive -> constr list -> lseqtac with_backtracking +val ll_ind_tac : pinductive -> constr list -> lseqtac with_backtracking val ll_arrow_tac : constr -> constr -> constr -> lseqtac with_backtracking val forall_tac : seqtac with_backtracking -val left_exists_tac : inductive -> lseqtac with_backtracking +val left_exists_tac : pinductive -> lseqtac with_backtracking val ll_forall_tac : types -> lseqtac with_backtracking diff --git a/plugins/firstorder/sequent.ml b/plugins/firstorder/sequent.ml index 72bde18f4..c0e5c7e58 100644 --- a/plugins/firstorder/sequent.ml +++ b/plugins/firstorder/sequent.ml @@ -199,7 +199,7 @@ let expand_constructor_hints = let extend_with_ref_list l seq gl= let l = expand_constructor_hints l in let f gr seq= - let c=constr_of_global gr in + let c=Universes.constr_of_global gr in let typ=(pf_type_of gl c) in add_formula Hyp gr typ seq gl in List.fold_right f l seq @@ -210,10 +210,10 @@ let extend_with_auto_hints l seq gl= let seqref=ref seq in let f p_a_t = match p_a_t.code with - Res_pf (c,_) | Give_exact c + Res_pf (c,_) | Give_exact (c,_) | Res_pf_THEN_trivial_fail (c,_) -> (try - let gr=global_of_constr c in + let gr = global_of_constr c in let typ=(pf_type_of gl c) in seqref:=add_formula Hint gr typ !seqref gl with Not_found->()) diff --git a/plugins/firstorder/unify.ml b/plugins/firstorder/unify.ml index 2556460f5..f7ee9fdad 100644 --- a/plugins/firstorder/unify.ml +++ b/plugins/firstorder/unify.ml @@ -78,7 +78,7 @@ let unif t1 t2= for i=0 to l-1 do Queue.add (va.(i),vb.(i)) bige done - | _->if not (eq_constr nt1 nt2) then raise (UFAIL (nt1,nt2)) + | _->if not (eq_constr_nounivs nt1 nt2) then raise (UFAIL (nt1,nt2)) done; assert false (* this place is unreachable but needed for the sake of typing *) diff --git a/plugins/fourier/fourierR.ml b/plugins/fourier/fourierR.ml index aeb07fc3a..d34d50364 100644 --- a/plugins/fourier/fourierR.ml +++ b/plugins/fourier/fourierR.ml @@ -87,7 +87,7 @@ let string_of_R_constant kn = let rec string_of_R_constr c = match kind_of_term c with Cast (c,_,_) -> string_of_R_constr c - |Const c -> string_of_R_constant c + |Const (c,_) -> string_of_R_constant c | _ -> "not_of_constant" exception NoRational @@ -114,7 +114,7 @@ let rec rational_of_constr c = rminus (rational_of_constr args.(0)) (rational_of_constr args.(1)) | _ -> raise NoRational) - | Const kn -> + | Const (kn,_) -> (match (string_of_R_constant kn) with "R1" -> r1 |"R0" -> r0 @@ -160,7 +160,7 @@ let rec flin_of_constr c = with NoRational -> flin_add (flin_zero()) args.(0) (rinv b)) |_-> raise NoLinear) - | Const c -> + | Const (c,_) -> (match (string_of_R_constant c) with "R1" -> flin_one () |"R0" -> flin_zero () @@ -194,7 +194,7 @@ let ineq1_of_constr (h,t) = match (kind_of_term t) with | App (f,args) -> (match kind_of_term f with - | Const c when Array.length args = 2 -> + | Const (c,_) when Array.length args = 2 -> let t1= args.(0) in let t2= args.(1) in (match (string_of_R_constant c) with @@ -227,13 +227,13 @@ let ineq1_of_constr (h,t) = (flin_of_constr t1); hstrict=false}] |_-> raise NoIneq) - | Ind (kn,i) -> + | Ind ((kn,i),_) -> if not (eq_gr (IndRef(kn,i)) Coqlib.glob_eq) then raise NoIneq; let t0= args.(0) in let t1= args.(1) in let t2= args.(2) in (match (kind_of_term t0) with - | Const c -> + | Const (c,_) -> (match (string_of_R_constant c) with | "R"-> [{hname=h; @@ -609,8 +609,9 @@ let rec fourier gl= [tclORELSE (* TODO : Ring.polynom []*) tclIDTAC tclIDTAC; - (tclTHEN (apply (get coq_sym_eqT)) - (apply (get coq_Rinv_1)))] + pf_constr_of_global (get coq_sym_eqT) (fun symeq -> + (tclTHEN (apply symeq) + (apply (get coq_Rinv_1))))] ) ])); diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index f06d8fa53..a3af23dcd 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -124,11 +124,13 @@ let finish_proof dynamic_infos g = let refine c = - Tacmach.refine_no_check c + Tacmach.refine c let thin l = Tacmach.thin_no_check l +let eq_constr u v = eq_constr_nounivs u v + let is_trivial_eq t = let res = try begin @@ -205,7 +207,7 @@ let prove_trivial_eq h_id context (constructor,type_of_term,term) = let find_rectype env c = - let (t, l) = decompose_app (Reduction.whd_betaiotazeta c) in + let (t, l) = decompose_app (Reduction.whd_betaiotazeta env c) in match kind_of_term t with | Ind ind -> (t, l) | Construct _ -> (t,l) @@ -233,7 +235,7 @@ let change_eq env sigma hyp_id (context:rel_context) x t end_of_type = failwith "NoChange"; end in - let eq_constr = Reductionops.is_conv env sigma in + let eq_constr = Evarconv.e_conv env (ref sigma) in if not (noccurn 1 end_of_type) then nochange "dependent"; (* if end_of_type depends on this term we don't touch it *) if not (isApp t) then nochange "not an equality"; @@ -325,7 +327,8 @@ let change_eq env sigma hyp_id (context:rel_context) x t end_of_type = let all_ids = pf_ids_of_hyps g in let new_ids,_ = list_chop ctxt_size all_ids in let to_refine = applist(witness_fun,List.rev_map mkVar new_ids) in - refine to_refine g + let evm, _ = pf_apply Typing.e_type_of g to_refine in + tclTHEN (Refiner.tclEVARS evm) (refine to_refine) g ) in let simpl_eq_tac = @@ -633,8 +636,11 @@ let instanciate_hyps_with_args (do_prove:Id.t list -> tactic) hyps args_id = ( (* we instanciate the hyp if possible *) fun g -> let prov_hid = pf_get_new_id hid g in + let c = mkApp(mkVar hid,args) in + let evm, _ = pf_apply Typing.e_type_of g c in tclTHENLIST[ - Proofview.V82.of_tactic (pose_proof (Name prov_hid) (mkApp(mkVar hid,args))); + Refiner.tclEVARS evm; + Proofview.V82.of_tactic (pose_proof (Name prov_hid) c); thin [hid]; rename_hyp [prov_hid,hid] ] g @@ -757,6 +763,7 @@ let build_proof begin match kind_of_term f with | App _ -> assert false (* we have collected all the app in decompose_app *) + | Proj _ -> assert false (*FIXME*) | Var _ | Construct _ | Rel _ | Evar _ | Meta _ | Ind _ | Sort _ | Prod _ -> let new_infos = { dyn_infos with @@ -764,7 +771,7 @@ let build_proof } in build_proof_args do_finalize new_infos g - | Const c when not (List.mem_f Constant.equal c fnames) -> + | Const (c,_) when not (List.mem_f Constant.equal c fnames) -> let new_infos = { dyn_infos with info = (f,args) @@ -809,6 +816,7 @@ let build_proof | Fix _ | CoFix _ -> error ( "Anonymous local (co)fixpoints are not handled yet") + | Proj _ -> error "Prod" | Prod _ -> error "Prod" | LetIn _ -> let new_infos = @@ -938,7 +946,7 @@ let generate_equation_lemma fnames f fun_num nb_params nb_args rec_args_num = (* observe (str "nb_args := " ++ str (string_of_int nb_args)); *) (* observe (str "nb_params := " ++ str (string_of_int nb_params)); *) (* observe (str "rec_args_num := " ++ str (string_of_int (rec_args_num + 1) )); *) - let f_def = Global.lookup_constant (destConst f) in + let f_def = Global.lookup_constant (fst (destConst f)) in let eq_lhs = mkApp(f,Array.init (nb_params + nb_args) (fun i -> mkRel(nb_params + nb_args - i))) in let f_body = Option.get (body_of_constant f_def) in @@ -956,10 +964,10 @@ let generate_equation_lemma fnames f fun_num nb_params nb_args rec_args_num = let eq_rhs = nf_betaiotazeta (mkApp(compose_lam params f_body_with_params_and_other_fun,Array.init (nb_params + nb_args) (fun i -> mkRel(nb_params + nb_args - i)))) in (* observe (str "eq_rhs " ++ pr_lconstr eq_rhs); *) let type_ctxt,type_of_f = decompose_prod_n_assum (nb_params + nb_args) - (Typeops.type_of_constant_type (Global.env()) f_def.const_type) in + ((*FIXME*)f_def.const_type) in let eqn = mkApp(Lazy.force eq,[|type_of_f;eq_lhs;eq_rhs|]) in let lemma_type = it_mkProd_or_LetIn eqn type_ctxt in - let f_id = Label.to_id (con_label (destConst f)) in + let f_id = Label.to_id (con_label (fst (destConst f))) in let prove_replacement = tclTHENSEQ [ @@ -978,8 +986,8 @@ let generate_equation_lemma fnames f fun_num nb_params nb_args rec_args_num = Ensures by: obvious i*) (mk_equation_id f_id) - (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem)) - lemma_type + (Decl_kinds.Global, false, (Decl_kinds.Proof Decl_kinds.Theorem)) + (lemma_type, (*FIXME*) Univ.ContextSet.empty) (fun _ _ -> ()); ignore (Pfedit.by (Proofview.V82.tactic prove_replacement)); Lemmas.save_proof (Vernacexpr.Proved(false,None)) @@ -990,10 +998,10 @@ let generate_equation_lemma fnames f fun_num nb_params nb_args rec_args_num = let do_replace params rec_arg_num rev_args_id f fun_num all_funs g = let equation_lemma = try - let finfos = find_Function_infos (destConst f) in + let finfos = find_Function_infos (fst (destConst f)) (*FIXME*) in mkConst (Option.get finfos.equation_lemma) with (Not_found | Option.IsNone as e) -> - let f_id = Label.to_id (con_label (destConst f)) in + let f_id = Label.to_id (con_label (fst (destConst f))) in (*i The next call to mk_equation_id is valid since we will construct the lemma Ensures by: obvious i*) @@ -1002,7 +1010,7 @@ let do_replace params rec_arg_num rev_args_id f fun_num all_funs g = let _ = match e with | Option.IsNone -> - let finfos = find_Function_infos (destConst f) in + let finfos = find_Function_infos (fst (destConst f)) in update_Function {finfos with equation_lemma = Some (match Nametab.locate (qualid_of_ident equation_lemma_id) with @@ -1306,7 +1314,7 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : in let fname = destConst (fst (decompose_app (List.hd (List.rev pte_args)))) in tclTHENSEQ - [unfold_in_concl [(Locus.AllOccurrences, Names.EvalConstRef fname)]; + [unfold_in_concl [(Locus.AllOccurrences, Names.EvalConstRef (fst fname))]; let do_prove = build_proof interactive_proof diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index d6f21fb86..2adc82505 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -106,14 +106,14 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = let pre_princ = substl (List.map mkVar ptes_vars) pre_princ in let is_dom c = match kind_of_term c with - | Ind((u,_)) -> MutInd.equal u rel_as_kn - | Construct((u,_),_) -> MutInd.equal u rel_as_kn + | Ind((u,_),_) -> MutInd.equal u rel_as_kn + | Construct(((u,_),_),_) -> MutInd.equal u rel_as_kn | _ -> false in let get_fun_num c = match kind_of_term c with - | Ind(_,num) -> num - | Construct((_,num),_) -> num + | Ind((_,num),_) -> num + | Construct(((_,num),_),_) -> num | _ -> assert false in let dummy_var = mkVar (Id.of_string "________") in @@ -251,8 +251,10 @@ let change_property_sort toSort princ princName = let princ_info = compute_elim_sig princ in let change_sort_in_predicate (x,v,t) = (x,None, - let args,_ = decompose_prod t in - compose_prod args (mkSort toSort) + let args,ty = decompose_prod t in + let s = destSort ty in + Global.add_constraints (Univ.enforce_leq (univ_of_sort toSort) (univ_of_sort s) Univ.Constraint.empty); + compose_prod args (mkSort toSort) ) in let princName_as_constr = Constrintern.global_reference princName in @@ -292,8 +294,8 @@ let build_functional_principle interactive_proof old_princ_type sorts funs i pro begin Lemmas.start_proof new_princ_name - (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem)) - new_principle_type + (Decl_kinds.Global,false,(Decl_kinds.Proof Decl_kinds.Theorem)) + (new_principle_type, (*FIXME*) Univ.ContextSet.empty) hook ; (* let _tim1 = System.get_time () in *) @@ -315,7 +317,7 @@ let generate_functional_principle try let f = funs.(i) in - let type_sort = Termops.new_sort_in_family InType in + let type_sort = Universes.new_sort_in_family InType in let new_sorts = match sorts with | None -> Array.make (Array.length funs) (type_sort) @@ -334,18 +336,23 @@ let generate_functional_principle then (* let id_of_f = Label.to_id (con_label f) in *) let register_with_sort fam_sort = - let s = Termops.new_sort_in_family fam_sort in + let s = Universes.new_sort_in_family fam_sort in let name = Indrec.make_elimination_ident base_new_princ_name fam_sort in let value = change_property_sort s new_principle_type new_princ_name in (* Pp.msgnl (str "new principle := " ++ pr_lconstr value); *) - let ce = { - const_entry_body = Future.from_val (value,Declareops.no_seff); - const_entry_secctx = None; - const_entry_type = None; - const_entry_opaque = false; - const_entry_inline_code = false; - const_entry_feedback = None; - } in + let ce = + { const_entry_body = + Future.from_val (value,Declareops.no_seff); + const_entry_secctx = None; + const_entry_type = None; + const_entry_polymorphic = false; + const_entry_universes = Univ.UContext.empty (*FIXME*); + const_entry_proj = None; + const_entry_opaque = false; + const_entry_feedback = None; + const_entry_inline_code = false + } + in ignore( Declare.declare_constant name @@ -488,19 +495,20 @@ let make_scheme (fas : (constant*glob_sort) list) : Entries.definition_entry lis List.map (fun (idx) -> let ind = first_fun_kn,idx in - ind,true,prop_sort + (ind,Univ.Instance.empty)(*FIXME*),true,prop_sort ) funs_indexes in + let sigma, schemes = + Indrec.build_mutual_induction_scheme env sigma ind_list + in let l_schemes = - List.map - (Typing.type_of env sigma) - (Indrec.build_mutual_induction_scheme env sigma ind_list) + List.map (Typing.type_of env sigma) schemes in let i = ref (-1) in let sorts = List.rev_map (fun (_,x) -> - Termops.new_sort_in_family (Pretyping.interp_elimination_sort x) + Universes.new_sort_in_family (Pretyping.interp_elimination_sort x) ) fas in @@ -649,10 +657,10 @@ let build_case_scheme fa = (* Constrintern.global_reference id *) (* in *) let funs = (fun (_,f,_) -> - try Globnames.constr_of_global (Nametab.global f) + try Universes.constr_of_global (Nametab.global f) with Not_found -> Errors.error ("Cannot find "^ Libnames.string_of_reference f)) fa in - let first_fun = destConst funs in + let first_fun,u = destConst funs in let funs_mp,funs_dp,_ = Names.repr_con first_fun in let first_fun_kn = try fst (find_Function_infos first_fun).graph_ind with Not_found -> raise No_graph_found in @@ -664,16 +672,18 @@ let build_case_scheme fa = let prop_sort = InProp in let funs_indexes = let this_block_funs_indexes = Array.to_list this_block_funs_indexes in - List.assoc_f Constant.equal (destConst funs) this_block_funs_indexes + List.assoc_f Constant.equal (fst (destConst funs)) this_block_funs_indexes in let ind_fun = let ind = first_fun_kn,funs_indexes in - ind,prop_sort + (ind,Univ.Instance.empty)(*FIXME*),prop_sort in - let scheme_type = (Typing.type_of env sigma ) ((fun (ind,sf) -> Indrec.build_case_analysis_scheme_default env sigma ind sf) ind_fun) in + let sigma, scheme = + (fun (ind,sf) -> Indrec.build_case_analysis_scheme_default env sigma ind sf) ind_fun in + let scheme_type = (Typing.type_of env sigma ) scheme in let sorts = (fun (_,_,x) -> - Termops.new_sort_in_family (Pretyping.interp_elimination_sort x) + Universes.new_sort_in_family (Pretyping.interp_elimination_sort x) ) fa in @@ -690,6 +700,6 @@ let build_case_scheme fa = (Some princ_name) this_block_funs 0 - (prove_princ_for_struct false 0 [|destConst funs|]) + (prove_princ_for_struct false 0 [|fst (destConst funs)|]) in () diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4 index 2dd78d890..3802aa365 100644 --- a/plugins/funind/g_indfun.ml4 +++ b/plugins/funind/g_indfun.ml4 @@ -307,8 +307,11 @@ let rec hdMatchSub inu (test: constr -> bool) : fapp_info list = max_rel = max_rel; onlyvars = List.for_all isVar args } ::subres +let make_eq () = +(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq ()) + let mkEq typ c1 c2 = - mkApp (Coqlib.build_coq_eq(),[| typ; c1; c2|]) + mkApp (make_eq(),[| typ; c1; c2|]) let poseq_unsafe idunsafe cstr gl = @@ -463,10 +466,10 @@ VERNAC COMMAND EXTEND MergeFunind CLASSIFIED AS SIDEFF [ "Mergeschemes" "(" ident(id1) ne_ident_list(cl1) ")" "with" "(" ident(id2) ne_ident_list(cl2) ")" "using" ident(id) ] -> [ - let f1 = Constrintern.interp_constr Evd.empty (Global.env()) - (CRef (Libnames.Ident (Loc.ghost,id1))) in - let f2 = Constrintern.interp_constr Evd.empty (Global.env()) - (CRef (Libnames.Ident (Loc.ghost,id2))) in + let f1,ctx = Constrintern.interp_constr Evd.empty (Global.env()) + (CRef (Libnames.Ident (Loc.ghost,id1),None)) in + let f2,ctx' = Constrintern.interp_constr Evd.empty (Global.env()) + (CRef (Libnames.Ident (Loc.ghost,id2),None)) in let f1type = Typing.type_of (Global.env()) Evd.empty f1 in let f2type = Typing.type_of (Global.env()) Evd.empty f2 in let ar1 = List.length (fst (decompose_prod f1type)) in diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index dd02dfe8d..4544f736c 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -333,8 +333,8 @@ let raw_push_named (na,raw_value,raw_typ) env = match na with | Anonymous -> env | Name id -> - let value = Option.map (Pretyping.understand Evd.empty env) raw_value in - let typ = Pretyping.understand Evd.empty env ~expected_type:Pretyping.IsType raw_typ in + let value = Option.map (fun x-> fst (Pretyping.understand Evd.empty env x)) raw_value in + let typ,ctx = Pretyping.understand Evd.empty env ~expected_type:Pretyping.IsType raw_typ in Environ.push_named (id,value,typ) env @@ -350,7 +350,7 @@ let add_pat_variables pat typ env : Environ.env = with Not_found -> assert false in let constructors = Inductiveops.get_constructors env indf in - let constructor : Inductiveops.constructor_summary = List.find (fun cs -> eq_constructor c cs.Inductiveops.cs_cstr) (Array.to_list constructors) in + let constructor : Inductiveops.constructor_summary = List.find (fun cs -> eq_constructor c (fst cs.Inductiveops.cs_cstr)) (Array.to_list constructors) in let cs_args_types :types list = List.map (fun (_,_,t) -> t) constructor.Inductiveops.cs_args in List.fold_left2 add_pat_variables env patl (List.rev cs_args_types) in @@ -397,7 +397,7 @@ let rec pattern_to_term_and_type env typ = function with Not_found -> assert false in let constructors = Inductiveops.get_constructors env indf in - let constructor = List.find (fun cs -> eq_constructor cs.Inductiveops.cs_cstr constr) (Array.to_list constructors) in + let constructor = List.find (fun cs -> eq_constructor (fst cs.Inductiveops.cs_cstr) constr) (Array.to_list constructors) in let cs_args_types :types list = List.map (fun (_,_,t) -> t) constructor.Inductiveops.cs_args in let _,cstl = Inductiveops.dest_ind_family indf in let csta = Array.of_list cstl in @@ -486,7 +486,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = a pseudo value "v1 ... vn". The "value" of this branch is then simply [res] *) - let rt_as_constr = Pretyping.understand Evd.empty env rt in + let rt_as_constr,ctx = Pretyping.understand Evd.empty env rt in let rt_typ = Typing.type_of env Evd.empty rt_as_constr in let res_raw_type = Detyping.detype false [] (Termops.names_of_rel_context env) rt_typ in let res = fresh_id args_res.to_avoid "_res" in @@ -559,6 +559,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = *) build_entry_lc env funnames avoid (mkGApp(b,args)) | GRec _ -> error "Not handled GRec" + | GProj _ -> error "Not handled GProj" | GProd _ -> error "Cannot apply a type" end (* end of the application treatement *) @@ -594,7 +595,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = and combine the two result *) let v_res = build_entry_lc env funnames avoid v in - let v_as_constr = Pretyping.understand Evd.empty env v in + let v_as_constr,ctx = Pretyping.understand Evd.empty env v in let v_type = Typing.type_of env Evd.empty v_as_constr in let new_env = match n with @@ -610,7 +611,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = let make_discr = make_discr_match brl in build_entry_lc_from_case env funnames make_discr el brl avoid | GIf(_,b,(na,e_option),lhs,rhs) -> - let b_as_constr = Pretyping.understand Evd.empty env b in + let b_as_constr,ctx = Pretyping.understand Evd.empty env b in let b_typ = Typing.type_of env Evd.empty b_as_constr in let (ind,_) = try Inductiveops.find_inductive env Evd.empty b_typ @@ -619,7 +620,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = Printer.pr_glob_constr b ++ str " in " ++ Printer.pr_glob_constr rt ++ str ". try again with a cast") in - let case_pats = build_constructors_of_type ind [] in + let case_pats = build_constructors_of_type (fst ind) [] in assert (Int.equal (Array.length case_pats) 2); let brl = List.map_i @@ -642,7 +643,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = ) nal in - let b_as_constr = Pretyping.understand Evd.empty env b in + let b_as_constr,ctx = Pretyping.understand Evd.empty env b in let b_typ = Typing.type_of env Evd.empty b_as_constr in let (ind,_) = try Inductiveops.find_inductive env Evd.empty b_typ @@ -651,7 +652,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = Printer.pr_glob_constr b ++ str " in " ++ Printer.pr_glob_constr rt ++ str ". try again with a cast") in - let case_pats = build_constructors_of_type ind nal_as_glob_constr in + let case_pats = build_constructors_of_type (fst ind) nal_as_glob_constr in assert (Int.equal (Array.length case_pats) 1); let br = (Loc.ghost,[],[case_pats.(0)],e) @@ -661,6 +662,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = end | GRec _ -> error "Not handled GRec" + | GProj _ -> error "Not handled GProj" | GCast(_,b,_) -> build_entry_lc env funnames avoid b and build_entry_lc_from_case env funname make_discr @@ -689,7 +691,7 @@ and build_entry_lc_from_case env funname make_discr in let types = List.map (fun (case_arg,_) -> - let case_arg_as_constr = Pretyping.understand Evd.empty env case_arg in + let case_arg_as_constr,ctx = Pretyping.understand Evd.empty env case_arg in Typing.type_of env Evd.empty case_arg_as_constr ) el in @@ -844,7 +846,7 @@ let is_res id = let same_raw_term rt1 rt2 = match rt1,rt2 with - | GRef(_,r1), GRef (_,r2) -> Globnames.eq_gr r1 r2 + | GRef(_,r1,_), GRef (_,r2,_) -> Globnames.eq_gr r1 r2 | GHole _, GHole _ -> true | _ -> false let decompose_raw_eq lhs rhs = @@ -894,7 +896,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = let new_t = mkGApp(mkGVar(mk_rel_id this_relname),args'@[res_rt]) in - let t' = Pretyping.understand Evd.empty env new_t in + let t',ctx = Pretyping.understand Evd.empty env new_t in let new_env = Environ.push_rel (n,None,t') env in let new_b,id_to_exclude = rebuild_cons new_env @@ -907,14 +909,14 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = | _ -> (* the first args is the name of the function! *) assert false end - | GApp(loc1,GRef(loc2,eq_as_ref),[ty;GVar(loc3,id);rt]) + | GApp(loc1,GRef(loc2,eq_as_ref,_),[ty;GVar(loc3,id);rt]) when Globnames.eq_gr eq_as_ref (Lazy.force Coqlib.coq_eq_ref) && n == Anonymous -> begin try observe (str "computing new type for eq : " ++ pr_glob_constr rt); let t' = - try Pretyping.understand Evd.empty env t + try fst (Pretyping.understand Evd.empty env t)(*FIXME*) with e when Errors.noncritical e -> raise Continue in let is_in_b = is_free_in id b in @@ -936,17 +938,17 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = in mkGProd(n,t,new_b),id_to_exclude with Continue -> - let jmeq = Globnames.IndRef (destInd (jmeq ())) in - let ty' = Pretyping.understand Evd.empty env ty in + let jmeq = Globnames.IndRef (fst (destInd (jmeq ()))) in + let ty',ctx = Pretyping.understand Evd.empty env ty in let ind,args' = Inductive.find_inductive env ty' in - let mib,_ = Global.lookup_inductive ind in + let mib,_ = Global.lookup_inductive (fst ind) in let nparam = mib.Declarations.mind_nparams in let params,arg' = ((Util.List.chop nparam args')) in let rt_typ = GApp(Loc.ghost, - GRef (Loc.ghost,Globnames.IndRef ind), + GRef (Loc.ghost,Globnames.IndRef (fst ind),None), (List.map (fun p -> Detyping.detype false [] (Termops.names_of_rel_context env) @@ -956,10 +958,10 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = (mkGHole ())))) in let eq' = - GApp(loc1,GRef(loc2,jmeq),[ty;GVar(loc3,id);rt_typ;rt]) + GApp(loc1,GRef(loc2,jmeq,None),[ty;GVar(loc3,id);rt_typ;rt]) in observe (str "computing new type for jmeq : " ++ pr_glob_constr eq'); - let eq'_as_constr = Pretyping.understand Evd.empty env eq' in + let eq'_as_constr,ctx = Pretyping.understand Evd.empty env eq' in observe (str " computing new type for jmeq : done") ; let new_args = match kind_of_term eq'_as_constr with @@ -1007,7 +1009,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = if is_in_b then b else replace_var_by_term id rt b in let new_env = - let t' = Pretyping.understand Evd.empty env eq' in + let t',ctx = Pretyping.understand Evd.empty env eq' in Environ.push_rel (n,None,t') env in let new_b,id_to_exclude = @@ -1024,7 +1026,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = mkGProd(n,t,new_b),id_to_exclude else new_b, Id.Set.add id id_to_exclude *) - | GApp(loc1,GRef(loc2,eq_as_ref),[ty;rt1;rt2]) + | GApp(loc1,GRef(loc2,eq_as_ref,_),[ty;rt1;rt2]) when Globnames.eq_gr eq_as_ref (Lazy.force Coqlib.coq_eq_ref) && n == Anonymous -> begin @@ -1045,7 +1047,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = else raise Continue with Continue -> observe (str "computing new type for prod : " ++ pr_glob_constr rt); - let t' = Pretyping.understand Evd.empty env t in + let t',ctx = Pretyping.understand Evd.empty env t in let new_env = Environ.push_rel (n,None,t') env in let new_b,id_to_exclude = rebuild_cons new_env @@ -1061,7 +1063,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = end | _ -> observe (str "computing new type for prod : " ++ pr_glob_constr rt); - let t' = Pretyping.understand Evd.empty env t in + let t',ctx = Pretyping.understand Evd.empty env t in let new_env = Environ.push_rel (n,None,t') env in let new_b,id_to_exclude = rebuild_cons new_env @@ -1080,7 +1082,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = let not_free_in_t id = not (is_free_in id t) in let new_crossed_types = t :: crossed_types in observe (str "computing new type for lambda : " ++ pr_glob_constr rt); - let t' = Pretyping.understand Evd.empty env t in + let t',ctx = Pretyping.understand Evd.empty env t in match n with | Name id -> let new_env = Environ.push_rel (n,None,t') env in @@ -1102,7 +1104,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = | GLetIn(_,n,t,b) -> begin let not_free_in_t id = not (is_free_in id t) in - let t' = Pretyping.understand Evd.empty env t in + let t',ctx = Pretyping.understand Evd.empty env t in let type_t' = Typing.type_of env Evd.empty t' in let new_env = Environ.push_rel (n,Some t',type_t') env in let new_b,id_to_exclude = @@ -1127,7 +1129,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = args (crossed_types) depth t in - let t' = Pretyping.understand Evd.empty env new_t in + let t',ctx = Pretyping.understand Evd.empty env new_t in let new_env = Environ.push_rel (na,None,t') env in let new_b,id_to_exclude = rebuild_cons new_env @@ -1179,7 +1181,7 @@ let rec compute_cst_params relnames params = function discriminitation ones *) | GSort _ -> params | GHole _ -> params - | GIf _ | GRec _ | GCast _ -> + | GIf _ | GRec _ | GCast _ | GProj _-> raise (UserError("compute_cst_params", str "Not handled case")) and compute_cst_params_from_app acc (params,rtl) = match params,rtl with @@ -1267,12 +1269,12 @@ let do_build_inductive (fun (n,t,is_defined) acc -> if is_defined then - Constrexpr.CLetIn(Loc.ghost,(Loc.ghost, n),Constrextern.extern_glob_constr Id.Set.empty t, + Constrexpr.CLetIn(Loc.ghost,(Loc.ghost, n),with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t, acc) else Constrexpr.CProdN (Loc.ghost, - [[(Loc.ghost,n)],Constrexpr_ops.default_binder_kind,Constrextern.extern_glob_constr Id.Set.empty t], + [[(Loc.ghost,n)],Constrexpr_ops.default_binder_kind,with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t], acc ) ) @@ -1285,7 +1287,8 @@ let do_build_inductive *) let rel_arities = Array.mapi rel_arity funsargs in Util.Array.fold_left2 (fun env rel_name rel_ar -> - Environ.push_named (rel_name,None, Constrintern.interp_constr Evd.empty env rel_ar) env) env relnames rel_arities + Environ.push_named (rel_name,None, + fst (with_full_print (Constrintern.interp_constr Evd.empty env) rel_ar)) env) env relnames rel_arities in (* and of the real constructors*) let constr i res = @@ -1333,12 +1336,12 @@ let do_build_inductive (fun (n,t,is_defined) acc -> if is_defined then - Constrexpr.CLetIn(Loc.ghost,(Loc.ghost, n),Constrextern.extern_glob_constr Id.Set.empty t, + Constrexpr.CLetIn(Loc.ghost,(Loc.ghost, n),with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t, acc) else Constrexpr.CProdN (Loc.ghost, - [[(Loc.ghost,n)],Constrexpr_ops.default_binder_kind,Constrextern.extern_glob_constr Id.Set.empty t], + [[(Loc.ghost,n)],Constrexpr_ops.default_binder_kind,with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t], acc ) ) @@ -1366,8 +1369,7 @@ let do_build_inductive Array.map (List.map (fun (id,t) -> false,((Loc.ghost,id), - Flags.with_option - Flags.raw_print + with_full_print (Constrextern.extern_glob_type Id.Set.empty) ((* zeta_normalize *) t) ) )) @@ -1403,7 +1405,7 @@ let do_build_inductive (* in *) let _time2 = System.get_time () in try - with_full_print (Flags.silently (Command.do_mutual_inductive rel_inds)) true + with_full_print (Flags.silently (Command.do_mutual_inductive rel_inds false)) true with | UserError(s,msg) as e -> let _time3 = System.get_time () in diff --git a/plugins/funind/glob_termops.ml b/plugins/funind/glob_termops.ml index 6a7f326e6..5efaf7954 100644 --- a/plugins/funind/glob_termops.ml +++ b/plugins/funind/glob_termops.ml @@ -10,7 +10,7 @@ open Misctypes Some basic functions to rebuild glob_constr In each of them the location is Loc.ghost *) -let mkGRef ref = GRef(Loc.ghost,ref) +let mkGRef ref = GRef(Loc.ghost,ref,None) let mkGVar id = GVar(Loc.ghost,id) let mkGApp(rt,rtl) = GApp(Loc.ghost,rt,rtl) let mkGLambda(n,t,b) = GLambda(Loc.ghost,n,Explicit,t,b) @@ -180,6 +180,7 @@ let change_vars = | GRec _ -> error "Local (co)fixes are not supported" | GSort _ -> rt | GHole _ -> rt + | GProj _ -> error "Native projections are not supported" (** FIXME *) | GCast(loc,b,c) -> GCast(loc,change_vars mapping b, Miscops.map_cast_type (change_vars mapping) c) @@ -357,6 +358,7 @@ let rec alpha_rt excluded rt = alpha_rt excluded rhs ) | GRec _ -> error "Not handled GRec" + | GProj _ -> error "Native projections are not supported" (** FIXME *) | GSort _ -> rt | GHole _ -> rt | GCast (loc,b,c) -> @@ -407,6 +409,7 @@ let is_free_in id = | GIf(_,cond,_,br1,br2) -> is_free_in cond || is_free_in br1 || is_free_in br2 | GRec _ -> raise (UserError("",str "Not handled GRec")) + | GProj _ -> error "Native projections are not supported" (** FIXME *) | GSort _ -> false | GHole _ -> false | GCast (_,b,(CastConv t|CastVM t|CastNative t)) -> is_free_in b || is_free_in t @@ -503,6 +506,7 @@ let replace_var_by_term x_id term = replace_var_by_pattern rhs ) | GRec _ -> raise (UserError("",str "Not handled GRec")) + | GProj _ -> error "Native projections are not supported" (** FIXME *) | GSort _ -> rt | GHole _ -> rt | GCast(loc,b,c) -> @@ -598,6 +602,7 @@ let ids_of_glob_constr c = | GCases (loc,sty,rtntypopt,tml,brchl) -> List.flatten (List.map (fun (_,idl,patl,c) -> idl @ ids_of_glob_constr [] c) brchl) | GRec _ -> failwith "Fix inside a constructor branch" + | GProj _ -> error "Native projections are not supported" (** FIXME *) | (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _) -> [] in (* build the set *) @@ -656,6 +661,7 @@ let zeta_normalize = zeta_normalize_term rhs ) | GRec _ -> raise (UserError("",str "Not handled GRec")) + | GProj _ -> error "Native projections are not supported" (** FIXME *) | GSort _ -> rt | GHole _ -> rt | GCast(loc,b,c) -> @@ -698,6 +704,7 @@ let expand_as = GIf(loc,expand_as map e,(na,Option.map (expand_as map) po), expand_as map br1, expand_as map br2) | GRec _ -> error "Not handled GRec" + | GProj _ -> error "Native projections are not supported" (** FIXME *) | GCast(loc,b,c) -> GCast(loc,expand_as map b, Miscops.map_cast_type (expand_as map) c) diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index 661e5e486..d98f824e8 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -38,7 +38,7 @@ let functional_induction with_clean c princl pat = | None -> (* No principle is given let's find the good one *) begin match kind_of_term f with - | Const c' -> + | Const (c',u) -> let princ_option = let finfo = (* we first try to find out a graph on f *) try find_Function_infos c' @@ -148,7 +148,7 @@ let build_newrecursive List.fold_left (fun (env,impls) ((_,recname),bl,arityc,_) -> let arityc = Constrexpr_ops.prod_constr_expr arityc bl in - let arity = Constrintern.interp_type sigma env0 arityc in + let arity,ctx = Constrintern.interp_type sigma env0 arityc in let impl = Constrintern.compute_internalization_data env0 Constrintern.Recursive arity [] in (Environ.push_named (recname,None,arity) env, Id.Map.add recname impl impls)) (env0,Constrintern.empty_internalization_env) lnameargsardef in @@ -182,6 +182,7 @@ let is_rec names = | GVar(_,id) -> check_id id names | GRef _ | GEvar _ | GPatVar _ | GSort _ | GHole _ -> false | GCast(_,b,_) -> lookup names b + | GProj _ -> error "GProj not handled" | GRec _ -> error "GRec not handled" | GIf(_,b,_,lhs,rhs) -> (lookup names b) || (lookup names lhs) || (lookup names rhs) @@ -222,7 +223,7 @@ let derive_inversion fix_names = try (* we first transform the fix_names identifier into their corresponding constant *) let fix_names_as_constant = - List.map (fun id -> destConst (Constrintern.global_reference id)) fix_names + List.map (fun id -> fst (destConst (Constrintern.global_reference id))) fix_names in (* Then we check that the graphs have been defined @@ -239,7 +240,7 @@ let derive_inversion fix_names = Ensures by : register_built i*) (List.map - (fun id -> destInd (Constrintern.global_reference (mk_rel_id id))) + (fun id -> fst (destInd (Constrintern.global_reference (mk_rel_id id)))) fix_names ) with e when Errors.noncritical e -> @@ -326,9 +327,8 @@ let generate_principle on_error let _ = List.map_i (fun i x -> - let princ = destConst (Indrec.lookup_eliminator (ind_kn,i) (InProp)) in - let princ_type = Typeops.type_of_constant (Global.env()) princ - in + let princ = Indrec.lookup_eliminator (ind_kn,i) (InProp) in + let princ_type = Global.type_of_global_unsafe princ in Functional_principles_types.generate_functional_principle interactive_proof princ_type @@ -351,10 +351,10 @@ let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexp match fixpoint_exprl with | [((_,fname),_,bl,ret_type,body),_] when not is_rec -> let body = match body with | Some body -> body | None -> user_err_loc (Loc.ghost,"Function",str "Body of Function must be given") in - Command.do_definition fname (Decl_kinds.Global,Decl_kinds.Definition) + Command.do_definition fname (Decl_kinds.Global,(*FIXME*)false,Decl_kinds.Definition) bl None body (Some ret_type) (fun _ _ -> ()) | _ -> - Command.do_fixpoint Global fixpoint_exprl + Command.do_fixpoint Global false(*FIXME*) fixpoint_exprl let generate_correction_proof_wf f_ref tcc_lemma_ref is_mes functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation @@ -385,7 +385,7 @@ let register_wf ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas let f_app_args = Constrexpr.CAppExpl (Loc.ghost, - (None,(Ident (Loc.ghost,fname))) , + (None,(Ident (Loc.ghost,fname)),None) , (List.map (function | _,Anonymous -> assert false @@ -399,7 +399,7 @@ let register_wf ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas [(f_app_args,None);(body,None)]) in let eq = Constrexpr_ops.prod_constr_expr unbounded_eq args in - let hook f_ref tcc_lemma_ref functional_ref eq_ref rec_arg_num rec_arg_type + let hook (f_ref,_) tcc_lemma_ref (functional_ref,_) (eq_ref,_) rec_arg_num rec_arg_type nb_args relation = try pre_hook @@ -536,7 +536,7 @@ let rebuild_bl (aux,assoc) bl typ = rebuild_bl (aux,assoc) bl typ let recompute_binder_list (fixpoint_exprl : (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) = let fixl,ntns = Command.extract_fixpoint_components false fixpoint_exprl in - let ((_,_,typel),_) = Command.interp_fixpoint fixl ntns in + let ((_,_,typel),_,_) = Command.interp_fixpoint fixl ntns in let constr_expr_typel = with_full_print (List.map (Constrextern.extern_constr false (Global.env ()))) typel in let fixpoint_exprl_with_new_bl = @@ -631,10 +631,10 @@ let do_generate_principle on_error register_built interactive_proof let rec add_args id new_args b = match b with - | CRef r -> + | CRef (r,_) -> begin match r with | Libnames.Ident(loc,fname) when Id.equal fname id -> - CAppExpl(Loc.ghost,(None,r),new_args) + CAppExpl(Loc.ghost,(None,r,None),new_args) | _ -> b end | CFix _ | CCoFix _ -> anomaly ~label:"add_args " (Pp.str "todo") @@ -648,12 +648,12 @@ let rec add_args id new_args b = add_args id new_args b1) | CLetIn(loc,na,b1,b2) -> CLetIn(loc,na,add_args id new_args b1,add_args id new_args b2) - | CAppExpl(loc,(pf,r),exprl) -> + | CAppExpl(loc,(pf,r,us),exprl) -> begin match r with | Libnames.Ident(loc,fname) when Id.equal fname id -> - CAppExpl(loc,(pf,r),new_args@(List.map (add_args id new_args) exprl)) - | _ -> CAppExpl(loc,(pf,r),List.map (add_args id new_args) exprl) + CAppExpl(loc,(pf,r,us),new_args@(List.map (add_args id new_args) exprl)) + | _ -> CAppExpl(loc,(pf,r,us),List.map (add_args id new_args) exprl) end | CApp(loc,(pf,b),bl) -> CApp(loc,(pf,add_args id new_args b), @@ -767,11 +767,10 @@ let make_graph (f_ref:global_reference) = | Some body -> let env = Global.env () in let extern_body,extern_type = - with_full_print - (fun () -> + with_full_print (fun () -> (Constrextern.extern_constr false env body, Constrextern.extern_type false env - (Typeops.type_of_constant_type env c_body.const_type) + ((*FIXNE*) c_body.const_type) ) ) () @@ -792,7 +791,7 @@ let make_graph (f_ref:global_reference) = | Constrexpr.LocalRawAssum (nal,_,_) -> List.map (fun (loc,n) -> - CRef(Libnames.Ident(loc, Nameops.out_name n))) + CRef(Libnames.Ident(loc, Nameops.out_name n),None)) nal ) nal_tas diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index 5c37dcec3..8cccb0bed 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -114,7 +114,7 @@ let const_of_id id = let def_of_const t = match (Term.kind_of_term t) with Term.Const sp -> - (try (match Declareops.body_of_constant (Global.lookup_constant sp) with + (try (match Environ.constant_opt_value_in (Global.env()) sp with | Some c -> c | _ -> assert false) with Not_found -> assert false) @@ -146,7 +146,7 @@ let get_locality = function | Local -> true | Global -> false -let save with_clean id const (locality,kind) hook = +let save with_clean id const (locality,_,kind) hook = let l,r = match locality with | Discharge when Lib.sections_are_opened () -> let k = Kindops.logical_kind_of_goal_kind kind in @@ -177,7 +177,8 @@ let get_proof_clean do_reduce = let with_full_print f a = let old_implicit_args = Impargs.is_implicit_args () and old_strict_implicit_args = Impargs.is_strict_implicit_args () - and old_contextual_implicit_args = Impargs.is_contextual_implicit_args () in + and old_contextual_implicit_args = Impargs.is_contextual_implicit_args () + in let old_rawprint = !Flags.raw_print in Flags.raw_print := true; Impargs.make_implicit_args false; @@ -259,8 +260,8 @@ let cache_Function (_,finfos) = let load_Function _ = cache_Function let subst_Function (subst,finfos) = - let do_subst_con c = fst (Mod_subst.subst_con subst c) - and do_subst_ind (kn,i) = (Mod_subst.subst_ind subst kn,i) + let do_subst_con c = Mod_subst.subst_constant subst c + and do_subst_ind i = Mod_subst.subst_ind subst i in let function_constant' = do_subst_con finfos.function_constant in let graph_ind' = do_subst_ind finfos.graph_ind in @@ -336,7 +337,7 @@ let pr_info f_info = str "function_constant_type := " ++ (try Printer.pr_lconstr - (Global.type_of_global (ConstRef f_info.function_constant)) + (Global.type_of_global_unsafe (ConstRef f_info.function_constant)) with e when Errors.noncritical e -> mt ()) ++ fnl () ++ str "equation_lemma := " ++ pr_ocst f_info.equation_lemma ++ fnl () ++ str "completeness_lemma :=" ++ pr_ocst f_info.completeness_lemma ++ fnl () ++ diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli index 0e8b22deb..6e8b79a6b 100644 --- a/plugins/funind/indfun_common.mli +++ b/plugins/funind/indfun_common.mli @@ -58,7 +58,7 @@ val get_proof_clean : bool -> -(* [with_full_print f a] applies [f] to [a] in full printing environment +(* [with_full_print f a] applies [f] to [a] in full printing environment. This function preserves the print settings *) diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index 7c8f5714e..897c8765b 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -112,7 +112,9 @@ let id_to_constr id = let generate_type g_to_f f graph i = (*i we deduce the number of arguments of the function and its returned type from the graph i*) - let graph_arity = Inductive.type_of_inductive (Global.env()) (Global.lookup_inductive (destInd graph)) in + let gr,u = destInd graph in + let graph_arity = Inductive.type_of_inductive (Global.env()) + (Global.lookup_inductive gr, u) in let ctxt,_ = decompose_prod_assum graph_arity in let fun_ctxt,res_type = match ctxt with @@ -138,8 +140,11 @@ let generate_type g_to_f f graph i = the hypothesis [res = fv] can then be computed We will need to lift it by one in order to use it as a conclusion i*) + let make_eq () = +(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq ()) + in let res_eq_f_of_args = - mkApp(Coqlib.build_coq_eq (),[|lift 2 res_type;mkRel 1;mkRel 2|]) + mkApp(make_eq (),[|lift 2 res_type;mkRel 1;mkRel 2|]) in (*i The hypothesis [graph\ x_1\ldots x_n\ res] can then be computed @@ -166,7 +171,7 @@ let generate_type g_to_f f graph i = WARNING: while convertible, [type_of body] and [type] can be non equal *) let find_induction_principle f = - let f_as_constant = match kind_of_term f with + let f_as_constant,u = match kind_of_term f with | Const c' -> c' | _ -> error "Must be used with a function" in @@ -205,6 +210,11 @@ let rec generate_fresh_id x avoid i = let id = Namegen.next_ident_away_in_goal x avoid in id::(generate_fresh_id x (id::avoid) (pred i)) +let make_eq () = +(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq ()) +let make_eq_refl () = +(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq_refl ()) + (* [prove_fun_correct functional_induction funs_constr graphs_constr schemes lemmas_types_infos i ] is the tactic used to prove correctness lemma. @@ -237,7 +247,7 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem \[fun (x_1:t_1)\ldots(x_n:t_n)=> fun fv => fun res => res = fv \rightarrow graph\ x_1\ldots x_n\ res\] *) (* we the get the definition of the graphs block *) - let graph_ind = destInd graphs_constr.(i) in + let graph_ind,u = destInd graphs_constr.(i) in let kn = fst graph_ind in let mib,_ = Global.lookup_inductive graph_ind in (* and the principle to use in this lemma in $\zeta$ normal form *) @@ -267,8 +277,8 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem branches in (* before building the full intro pattern for the principle *) - let eq_ind = Coqlib.build_coq_eq () in - let eq_construct = mkConstruct((destInd eq_ind),1) in + let eq_ind = make_eq () in + let eq_construct = mkConstructUi (destInd eq_ind, 1) in (* The next to referencies will be used to find out which constructor to apply in each branch *) let ind_number = ref 0 and min_constr_number = ref 0 in @@ -731,7 +741,7 @@ let rec intros_with_rewrite g = observe_tac "intros_with_rewrite" intros_with_rewrite_aux g and intros_with_rewrite_aux : tactic = fun g -> - let eq_ind = Coqlib.build_coq_eq () in + let eq_ind = make_eq () in match kind_of_term (pf_concl g) with | Prod(_,t,t') -> begin @@ -830,7 +840,7 @@ let rec reflexivity_with_destruct_cases g = | _ -> Proofview.V82.of_tactic reflexivity with e when Errors.noncritical e -> Proofview.V82.of_tactic reflexivity in - let eq_ind = Coqlib.build_coq_eq () in + let eq_ind = make_eq () in let discr_inject = Tacticals.onAllHypsAndConcl ( fun sc g -> @@ -936,7 +946,7 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = let rewrite_tac j ids : tactic = let graph_def = graphs.(j) in let infos = - try find_Function_infos (destConst funcs.(j)) + try find_Function_infos (fst (destConst funcs.(j))) with Not_found -> error "No graph found" in if infos.is_general @@ -962,7 +972,7 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = thin ids ] else - unfold_in_concl [(Locus.AllOccurrences, Names.EvalConstRef (destConst f))] + unfold_in_concl [(Locus.AllOccurrences, Names.EvalConstRef (fst (destConst f)))] in (* The proof of each branche itself *) let ind_number = ref 0 in @@ -1026,7 +1036,7 @@ let derive_correctness make_scheme functional_induction (funs: constant list) (g let lemmas_types_infos = Util.Array.map2_i (fun i f_constr graph -> - let const_of_f = destConst f_constr in + let const_of_f,u = destConst f_constr in let (type_of_lemma_ctxt,type_of_lemma_concl) as type_info = generate_type false const_of_f graph i in @@ -1065,22 +1075,22 @@ let derive_correctness make_scheme functional_induction (funs: constant list) (g i*) let lem_id = mk_correct_id f_id in Lemmas.start_proof lem_id - (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem)) - (fst lemmas_types_infos.(i)) + (Decl_kinds.Global,false(*FIXME*),(Decl_kinds.Proof Decl_kinds.Theorem)) + (fst lemmas_types_infos.(i), (*FIXME*)Univ.ContextSet.empty) (fun _ _ -> ()); ignore (Pfedit.by (Proofview.V82.tactic (observe_tac ("prove correctness ("^(Id.to_string f_id)^")") (proving_tac i)))); do_save (); let finfo = find_Function_infos f_as_constant in - let lem_cst = destConst (Constrintern.global_reference lem_id) in + let lem_cst = fst (destConst (Constrintern.global_reference lem_id)) in update_Function {finfo with correctness_lemma = Some lem_cst} ) funs; let lemmas_types_infos = Util.Array.map2_i (fun i f_constr graph -> - let const_of_f = destConst f_constr in + let const_of_f = fst (destConst f_constr) in let (type_of_lemma_ctxt,type_of_lemma_concl) as type_info = generate_type true const_of_f graph i in @@ -1092,19 +1102,21 @@ let derive_correctness make_scheme functional_induction (funs: constant list) (g funs_constr graphs_constr in - let kn,_ as graph_ind = destInd graphs_constr.(0) in + let kn,_ as graph_ind = fst (destInd graphs_constr.(0)) in let mib,mip = Global.lookup_inductive graph_ind in - let schemes = - Array.of_list + let sigma, scheme = (Indrec.build_mutual_induction_scheme (Global.env ()) Evd.empty (Array.to_list (Array.mapi - (fun i _ -> (kn,i),true,InType) + (fun i _ -> ((kn,i),Univ.Instance.empty)(*FIXME*),true,InType) mib.Declarations.mind_packets ) ) ) in + let schemes = + Array.of_list scheme + in let proving_tac = prove_fun_complete funs_constr mib.Declarations.mind_packets schemes lemmas_types_infos in @@ -1116,15 +1128,12 @@ let derive_correctness make_scheme functional_induction (funs: constant list) (g i*) let lem_id = mk_complete_id f_id in Lemmas.start_proof lem_id - (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem)) - (fst lemmas_types_infos.(i)) + (Decl_kinds.Global,false(*FIXME*),(Decl_kinds.Proof Decl_kinds.Theorem)) + (fst lemmas_types_infos.(i), (*FIXME*)Univ.ContextSet.empty) (fun _ _ -> ()); - ignore (Pfedit.by - (Proofview.V82.tactic (observe_tac ("prove completeness ("^(Id.to_string f_id)^")") - (proving_tac i)))); do_save (); let finfo = find_Function_infos f_as_constant in - let lem_cst = destConst (Constrintern.global_reference lem_id) in + let lem_cst,u = destConst (Constrintern.global_reference lem_id) in update_Function {finfo with completeness_lemma = Some lem_cst} ) funs) @@ -1142,7 +1151,7 @@ let revert_graph kn post_tac hid g = let typ = pf_type_of g (mkVar hid) in match kind_of_term typ with | App(i,args) when isInd i -> - let ((kn',num) as ind') = destInd i in + let ((kn',num) as ind'),u = destInd i in if MutInd.equal kn kn' then (* We have generated a graph hypothesis so that we must change it if we can *) let info = @@ -1192,7 +1201,7 @@ let functional_inversion kn hid fconst f_correct : tactic = let old_ids = List.fold_right Id.Set.add (pf_ids_of_hyps g) Id.Set.empty in let type_of_h = pf_type_of g (mkVar hid) in match kind_of_term type_of_h with - | App(eq,args) when eq_constr eq (Coqlib.build_coq_eq ()) -> + | App(eq,args) when eq_constr eq (make_eq ()) -> let pre_tac,f_args,res = match kind_of_term args.(1),kind_of_term args.(2) with | App(f,f_args),_ when eq_constr f fconst -> @@ -1244,12 +1253,12 @@ let invfun qhyp f g = (fun hid -> Proofview.V82.tactic begin fun g -> let hyp_typ = pf_type_of g (mkVar hid) in match kind_of_term hyp_typ with - | App(eq,args) when eq_constr eq (Coqlib.build_coq_eq ()) -> + | App(eq,args) when eq_constr eq (make_eq ()) -> begin let f1,_ = decompose_app args.(1) in try if not (isConst f1) then failwith ""; - let finfos = find_Function_infos (destConst f1) in + let finfos = find_Function_infos (fst (destConst f1)) in let f_correct = mkConst(Option.get finfos.correctness_lemma) and kn = fst finfos.graph_ind in @@ -1258,7 +1267,7 @@ let invfun qhyp f g = try let f2,_ = decompose_app args.(2) in if not (isConst f2) then failwith ""; - let finfos = find_Function_infos (destConst f2) in + let finfos = find_Function_infos (fst (destConst f2)) in let f_correct = mkConst(Option.get finfos.correctness_lemma) and kn = fst finfos.graph_ind in diff --git a/plugins/funind/merge.ml b/plugins/funind/merge.ml index ac54e44cc..d0497f6f6 100644 --- a/plugins/funind/merge.ml +++ b/plugins/funind/merge.ml @@ -70,7 +70,7 @@ let isVarf f x = in global environment. *) let ident_global_exist id = try - let ans = CRef (Libnames.Ident (Loc.ghost,id)) in + let ans = CRef (Libnames.Ident (Loc.ghost,id), None) in let _ = ignore (Constrintern.intern_constr (Global.env()) ans) in true with e when Errors.noncritical e -> false @@ -134,16 +134,12 @@ let prNamedRLDecl s lc = let showind (id:Id.t) = let cstrid = Constrintern.global_reference id in let ind1,cstrlist = Inductiveops.find_inductive (Global.env()) Evd.empty cstrid in - let mib1,ib1 = Inductive.lookup_mind_specif (Global.env()) ind1 in + let mib1,ib1 = Inductive.lookup_mind_specif (Global.env()) (fst ind1) in List.iter (fun (nm, optcstr, tp) -> print_string (string_of_name nm^":"); prconstr tp; print_string "\n") ib1.mind_arity_ctxt; - (match ib1.mind_arity with - | Monomorphic x -> - Printf.printf "arity :"; prconstr x.mind_user_arity - | Polymorphic x -> - Printf.printf "arity : universe?"); + Printf.printf "arity :"; prconstr ib1.mind_arity.mind_user_arity; Array.iteri (fun i x -> Printf.printf"type constr %d :" i ; prconstr x) ib1.mind_user_lc @@ -888,7 +884,7 @@ let merge_inductive (ind1: inductive) (ind2: inductive) let indexpr = glob_constr_list_to_inductive_expr prms1 prms2 mib1 mib2 shift_prm rawlist in (* Declare inductive *) let indl,_,_ = Command.extract_mutual_inductive_declaration_components [(indexpr,[])] in - let mie,impls = Command.interp_mutual_inductive indl [] true (* means: not coinductive *) in + let mie,impls = Command.interp_mutual_inductive indl [] false (*FIXMEnon-poly *) true (* means: not coinductive *) in (* Declare the mutual inductive block with its associated schemes *) ignore (Command.declare_mutual_inductive_with_eliminations Declare.UserVerbose mie impls) @@ -961,7 +957,7 @@ let funify_branches relinfo nfuns branch = | _ -> assert false in let is_dom c = match kind_of_term c with - | Ind((u,_)) | Construct((u,_),_) -> MutInd.equal u mut_induct + | Ind(((u,_),_)) | Construct(((u,_),_),_) -> MutInd.equal u mut_induct | _ -> false in let _dom_i c = assert (is_dom c); diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 614886073..96bf4c921 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -52,29 +52,21 @@ let find_reference sl s = let dp = Names.DirPath.make (List.rev_map Id.of_string sl) in locate (make_qualid dp (Id.of_string s)) -let (declare_fun : Id.t -> logical_kind -> constr -> global_reference) = - fun f_id kind value -> - let ce = {const_entry_body = Future.from_val - (value, Declareops.no_seff); - const_entry_secctx = None; - const_entry_type = None; - const_entry_opaque = false; - const_entry_inline_code = false; - const_entry_feedback = None; - } in - ConstRef(declare_constant f_id (DefinitionEntry ce, kind));; +let declare_fun f_id kind ?(ctx=Univ.UContext.empty) value = + let ce = definition_entry ~univs:ctx value (*FIXME *) in + ConstRef(declare_constant f_id (DefinitionEntry ce, kind));; let defined () = Lemmas.save_proof (Vernacexpr.Proved (false,None)) let def_of_const t = match (kind_of_term t) with Const sp -> - (try (match body_of_constant (Global.lookup_constant sp) with + (try (match constant_opt_value_in (Global.env ()) sp with | Some c -> c | _ -> raise Not_found) with Not_found -> anomaly (str "Cannot find definition of constant " ++ - (Id.print (Label.to_id (con_label sp)))) + (Id.print (Label.to_id (con_label (fst sp))))) ) |_ -> assert false @@ -83,6 +75,7 @@ let type_of_const t = Const sp -> Typeops.type_of_constant (Global.env()) sp |_ -> assert false +let constr_of_global = Universes.constr_of_global let constant sl s = constr_of_global (find_reference sl s) @@ -188,7 +181,7 @@ let (value_f:constr list -> global_reference -> constr) = let glob_body = GCases (d0,RegularStyle,None, - [GApp(d0, GRef(d0,fterm), List.rev_map (fun x_id -> GVar(d0, x_id)) rev_x_id_l), + [GApp(d0, GRef(d0,fterm,None), List.rev_map (fun x_id -> GVar(d0, x_id)) rev_x_id_l), (Anonymous,None)], [d0, [v_id], [PatCstr(d0,(destIndRef (delayed_force coq_sig_ref),1), @@ -197,7 +190,7 @@ let (value_f:constr list -> global_reference -> constr) = Anonymous)], GVar(d0,v_id)]) in - let body = understand Evd.empty env glob_body in + let body = fst (understand Evd.empty env glob_body)(*FIXME*) in it_mkLambda_or_LetIn body context let (declare_f : Id.t -> logical_kind -> constr list -> global_reference -> global_reference) = @@ -302,6 +295,7 @@ let check_not_nested forbidden e = | Lambda(_,t,b) -> check_not_nested t;check_not_nested b | LetIn(_,v,t,b) -> check_not_nested t;check_not_nested b;check_not_nested v | App(f,l) -> check_not_nested f;Array.iter check_not_nested l + | Proj (p,c) -> check_not_nested c | Const _ -> () | Ind _ -> () | Construct _ -> () @@ -412,6 +406,7 @@ let treat_case forbid_new_ids to_intros finalize_tac nb_lam e infos : tactic = let rec travel_aux jinfo continuation_tac (expr_info:constr infos) = match kind_of_term expr_info.info with | CoFix _ | Fix _ -> error "Function cannot treat local fixpoint or cofixpoint" + | Proj _ -> error "Function cannot treat projections" | LetIn(na,b,t,e) -> begin let new_continuation_tac = @@ -640,7 +635,16 @@ let terminate_letin (na,b,t,e) expr_info continuation_tac info = in continuation_tac {info with info = new_e; forbidden_ids = new_forbidden} +let pf_type c tac gl = + let evars, ty = Typing.e_type_of (pf_env gl) (project gl) c in + tclTHEN (Refiner.tclEVARS evars) (tac ty) gl +let pf_typel l tac = + let rec aux tys l = + match l with + | [] -> tac (List.rev tys) + | hd :: tl -> pf_type hd (fun ty -> aux (ty::tys) tl) + in aux [] l (* This is like the previous one except that it also rewrite on all hypotheses except the ones given in the first argument. All the @@ -660,12 +664,13 @@ let mkDestructEq : let type_of_expr = pf_type_of g expr in let new_hyps = mkApp(Lazy.force refl_equal, [|type_of_expr; expr|]):: to_revert_constr in + pf_typel new_hyps (fun _ -> tclTHENLIST [Simple.generalize new_hyps; (fun g2 -> change_in_concl None (pattern_occs [Locus.AllOccurrencesBut [1], expr] (pf_env g2) Evd.empty (pf_concl g2)) g2); - Proofview.V82.of_tactic (simplest_case expr)], to_revert + Proofview.V82.of_tactic (simplest_case expr)]), to_revert let terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos g = @@ -1167,7 +1172,7 @@ let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_a let get_current_subgoals_types () = let p = Proof_global.give_me_the_proof () in let { Evd.it=sgs ; sigma=sigma } = Proof.V82.subgoals p in - List.map (Goal.V82.abstract_type sigma) sgs + sigma, List.map (Goal.V82.abstract_type sigma) sgs let build_and_l l = let and_constr = Coqlib.build_coq_and () in @@ -1225,12 +1230,12 @@ let clear_goals = let build_new_goal_type () = - let sub_gls_types = get_current_subgoals_types () in - (* Pp.msgnl (str "sub_gls_types1 := " ++ Pp.prlist_with_sep (fun () -> Pp.fnl () ++ Pp.fnl ()) Printer.pr_lconstr sub_gls_types); *) + let sigma, sub_gls_types = get_current_subgoals_types () in + (* Pp.msgnl (str "sub_gls_types1 := " ++ Util.prlist_with_sep (fun () -> Pp.fnl () ++ Pp.fnl ()) Printer.pr_lconstr sub_gls_types); *) let sub_gls_types = clear_goals sub_gls_types in (* Pp.msgnl (str "sub_gls_types2 := " ++ Pp.prlist_with_sep (fun () -> Pp.fnl () ++ Pp.fnl ()) Printer.pr_lconstr sub_gls_types); *) let res = build_and_l sub_gls_types in - res + sigma, res let is_opaque_constant c = let cb = Global.lookup_constant c in @@ -1239,7 +1244,7 @@ let is_opaque_constant c = | Declarations.Undef _ -> true | Declarations.Def _ -> false -let open_new_goal (build_proof:tactic -> tactic -> unit) using_lemmas ref_ goal_name (gls_type,decompose_and_tac,nb_goal) = +let open_new_goal build_proof ctx using_lemmas ref_ goal_name (gls_type,decompose_and_tac,nb_goal) = (* Pp.msgnl (str "gls_type := " ++ Printer.pr_lconstr gls_type); *) let current_proof_name = get_current_proof_name () in let name = match goal_name with @@ -1265,7 +1270,7 @@ let open_new_goal (build_proof:tactic -> tactic -> unit) using_lemmas ref_ goal_ let lid = ref [] in let h_num = ref (-1) in Proof_global.discard_all (); - build_proof + build_proof (Univ.ContextSet.empty) ( fun gls -> let hid = next_ident_away_in_goal h_id (pf_ids_of_hyps gls) in tclTHENSEQ @@ -1312,8 +1317,8 @@ let open_new_goal (build_proof:tactic -> tactic -> unit) using_lemmas ref_ goal_ in Lemmas.start_proof na - (Decl_kinds.Global, Decl_kinds.Proof Decl_kinds.Lemma) - gls_type + (Decl_kinds.Global, false (* FIXME *), Decl_kinds.Proof Decl_kinds.Lemma) + (gls_type, ctx) hook; if Indfun_common.is_strict_tcc () then @@ -1330,7 +1335,7 @@ let open_new_goal (build_proof:tactic -> tactic -> unit) using_lemmas ref_ goal_ (fun c -> tclTHENSEQ [Proofview.V82.of_tactic intros; - Simple.apply (interp_constr Evd.empty (Global.env()) c); + Simple.apply (fst (interp_constr Evd.empty (Global.env()) c)) (*FIXME*); tclCOMPLETE (Proofview.V82.of_tactic Auto.default_auto) ] ) @@ -1354,22 +1359,24 @@ let com_terminate relation rec_arg_num thm_name using_lemmas - nb_args + nb_args ctx hook = - let start_proof (tac_start:tactic) (tac_end:tactic) = + let ctx = Univ.ContextSet.of_context ctx in + let start_proof ctx (tac_start:tactic) (tac_end:tactic) = let (evmap, env) = Lemmas.get_current_context() in Lemmas.start_proof thm_name - (Global, Proof Lemma) ~sign:(Environ.named_context_val env) - (compute_terminate_type nb_args fonctional_ref) hook; + (Global, false (* FIXME *), Proof Lemma) ~sign:(Environ.named_context_val env) + (compute_terminate_type nb_args fonctional_ref, ctx) hook; ignore (by (Proofview.V82.tactic (observe_tac (str "starting_tac") tac_start))); ignore (by (Proofview.V82.tactic (observe_tac (str "whole_start") (whole_start tac_end nb_args is_mes fonctional_ref input_type relation rec_arg_num )))) in - start_proof tclIDTAC tclIDTAC; + start_proof ctx tclIDTAC tclIDTAC; try - let new_goal_type = build_new_goal_type () in - open_new_goal start_proof using_lemmas tcc_lemma_ref + let sigma, new_goal_type = build_new_goal_type () in + open_new_goal start_proof (Evd.get_universe_context_set sigma) + using_lemmas tcc_lemma_ref (Some tcc_lemma_name) (new_goal_type); with Failure "empty list of subgoals!" -> @@ -1384,7 +1391,7 @@ let start_equation (f:global_reference) (term_f:global_reference) (cont_tactic:Id.t list -> tactic) g = let ids = pf_ids_of_hyps g in let terminate_constr = constr_of_global term_f in - let nargs = nb_prod (type_of_const terminate_constr) in + let nargs = nb_prod (fst (type_of_const terminate_constr)) (*FIXME*) in let x = n_x_id ids nargs in tclTHENLIST [ h_intros x; @@ -1406,8 +1413,8 @@ let (com_eqn : int -> Id.t -> let (evmap, env) = Lemmas.get_current_context() in let f_constr = constr_of_global f_ref in let equation_lemma_type = subst1 f_constr equation_lemma_type in - (Lemmas.start_proof eq_name (Global, Proof Lemma) - ~sign:(Environ.named_context_val env) equation_lemma_type (fun _ _ -> ()); + (Lemmas.start_proof eq_name (Global, false, Proof Lemma) + ~sign:(Environ.named_context_val env) (equation_lemma_type, (*FIXME*)Univ.ContextSet.empty) (fun _ _ -> ()); ignore (by (Proofview.V82.tactic (start_equation f_ref terminate_ref (fun x -> @@ -1445,13 +1452,15 @@ let (com_eqn : int -> Id.t -> let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num eq generate_induction_principle using_lemmas : unit = - let function_type = interp_constr Evd.empty (Global.env()) type_of_f in - let env = push_named (function_name,None,function_type) (Global.env()) in + let env = Global.env() in + let evd = ref (Evd.from_env env) in + let function_type = interp_type_evars evd env type_of_f in + let env = push_named (function_name,None,function_type) env in (* Pp.msgnl (str "function type := " ++ Printer.pr_lconstr function_type); *) - let equation_lemma_type = - nf_betaiotazeta - (interp_constr Evd.empty env ~impls:rec_impls eq) - in + let ty = interp_type_evars evd env ~impls:rec_impls eq in + let evm, nf = Evarutil.nf_evars_and_universes !evd in + let equation_lemma_type = nf_betaiotazeta (nf ty) in + let function_type = nf function_type in (* Pp.msgnl (str "lemma type := " ++ Printer.pr_lconstr equation_lemma_type ++ fnl ()); *) let res_vars,eq' = decompose_prod equation_lemma_type in let env_eq' = Environ.push_rel_context (List.map (fun (x,y) -> (x,None,y)) res_vars) env in @@ -1471,13 +1480,14 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num let equation_id = add_suffix function_name "_equation" in let functional_id = add_suffix function_name "_F" in let term_id = add_suffix function_name "_terminate" in - let functional_ref = declare_fun functional_id (IsDefinition Decl_kinds.Definition) res in + let ctx = Evd.universe_context evm in + let functional_ref = declare_fun functional_id (IsDefinition Decl_kinds.Definition) ~ctx res in let env_with_pre_rec_args = push_rel_context(List.map (function (x,t) -> (x,None,t)) pre_rec_args) env in let relation = - interp_constr + fst (*FIXME*)(interp_constr Evd.empty env_with_pre_rec_args - r + r) in let tcc_lemma_name = add_suffix function_name "_tcc" in let tcc_lemma_constr = ref None in @@ -1524,6 +1534,5 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num term_id using_lemmas (List.length res_vars) - hook) + ctx hook) () - diff --git a/plugins/funind/recdef.mli b/plugins/funind/recdef.mli index 2ef685203..f60eedbe6 100644 --- a/plugins/funind/recdef.mli +++ b/plugins/funind/recdef.mli @@ -12,9 +12,9 @@ bool -> Constrintern.internalization_env -> Constrexpr.constr_expr -> Constrexpr.constr_expr -> - int -> Constrexpr.constr_expr -> (Names.constant -> + int -> Constrexpr.constr_expr -> (Term.pconstant -> Term.constr option ref -> - Names.constant -> - Names.constant -> int -> Term.types -> int -> Term.constr -> 'a) -> Constrexpr.constr_expr list -> unit + Term.pconstant -> + Term.pconstant -> int -> Term.types -> int -> Term.constr -> 'a) -> Constrexpr.constr_expr list -> unit diff --git a/plugins/micromega/OrderedRing.v b/plugins/micromega/OrderedRing.v index b260feab1..2246af64d 100644 --- a/plugins/micromega/OrderedRing.v +++ b/plugins/micromega/OrderedRing.v @@ -85,9 +85,9 @@ Notation "x < y" := (rlt x y). Add Relation R req - reflexivity proved by sor.(SORsetoid).(@Equivalence_Reflexive _ _ ) - symmetry proved by sor.(SORsetoid).(@Equivalence_Symmetric _ _ ) - transitivity proved by sor.(SORsetoid).(@Equivalence_Transitive _ _ ) + reflexivity proved by sor.(SORsetoid).(@Equivalence_Reflexive _ _) + symmetry proved by sor.(SORsetoid).(@Equivalence_Symmetric _ _) + transitivity proved by sor.(SORsetoid).(@Equivalence_Transitive _ _) as sor_setoid. diff --git a/plugins/micromega/RingMicromega.v b/plugins/micromega/RingMicromega.v index 68add5b3d..fb16c55c2 100644 --- a/plugins/micromega/RingMicromega.v +++ b/plugins/micromega/RingMicromega.v @@ -57,7 +57,7 @@ Variables ceqb cleb : C -> C -> bool. Variable phi : C -> R. (* Power coefficients *) -Variable E : Set. (* the type of exponents *) +Variable E : Type. (* the type of exponents *) Variable pow_phi : N -> E. Variable rpow : R -> E -> R. @@ -78,9 +78,9 @@ Record SORaddon := mk_SOR_addon { Variable addon : SORaddon. Add Relation R req - reflexivity proved by sor.(SORsetoid).(@Equivalence_Reflexive _ _ ) - symmetry proved by sor.(SORsetoid).(@Equivalence_Symmetric _ _ ) - transitivity proved by sor.(SORsetoid).(@Equivalence_Transitive _ _ ) + reflexivity proved by sor.(SORsetoid).(@Equivalence_Reflexive _ _) + symmetry proved by sor.(SORsetoid).(@Equivalence_Symmetric _ _) + transitivity proved by sor.(SORsetoid).(@Equivalence_Transitive _ _) as micomega_sor_setoid. Add Morphism rplus with signature req ==> req ==> req as rplus_morph. @@ -414,7 +414,7 @@ Proof. simpl ; intros. destruct (nth_in_or_default n l (Pc cO, Equal)). (* index is in bounds *) - apply H ; congruence. + apply H. congruence. (* index is out-of-bounds *) inversion H0. rewrite e. simpl. diff --git a/plugins/micromega/ZMicromega.v b/plugins/micromega/ZMicromega.v index d8ab6fd30..78837d4cd 100644 --- a/plugins/micromega/ZMicromega.v +++ b/plugins/micromega/ZMicromega.v @@ -317,7 +317,7 @@ Qed. Require Import QArith. -Inductive ZArithProof : Type := +Inductive ZArithProof := | DoneProof | RatProof : ZWitness -> ZArithProof -> ZArithProof | CutProof : ZWitness -> ZArithProof -> ZArithProof diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index 9515c5de9..d11454b27 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -536,10 +536,10 @@ struct let get_left_construct term = match Term.kind_of_term term with - | Term.Construct(_,i) -> (i,[| |]) + | Term.Construct((_,i),_) -> (i,[| |]) | Term.App(l,rst) -> (match Term.kind_of_term l with - | Term.Construct(_,i) -> (i,rst) + | Term.Construct((_,i),_) -> (i,rst) | _ -> raise ParseError ) | _ -> raise ParseError @@ -833,8 +833,8 @@ struct let parse_zop (op,args) = match kind_of_term op with - | Const x -> (assoc_const op zop_table, args.(0) , args.(1)) - | Ind(n,0) -> + | Const (x,_) -> (assoc_const op zop_table, args.(0) , args.(1)) + | Ind((n,0),_) -> if Constr.equal op (Lazy.force coq_Eq) && Constr.equal args.(0) (Lazy.force coq_Z) then (Mc.OpEq, args.(1), args.(2)) else raise ParseError @@ -842,8 +842,8 @@ struct let parse_rop (op,args) = match kind_of_term op with - | Const x -> (assoc_const op rop_table, args.(0) , args.(1)) - | Ind(n,0) -> + | Const (x,_) -> (assoc_const op rop_table, args.(0) , args.(1)) + | Ind((n,0),_) -> if Constr.equal op (Lazy.force coq_Eq) && Constr.equal args.(0) (Lazy.force coq_R) then (Mc.OpEq, args.(1), args.(2)) else raise ParseError diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index 9b851447c..9b12c5eb3 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -170,7 +170,7 @@ let hide_constr,find_constr,clear_constr_tables,dump_tables = let l = ref ([]:(constr * (Id.t * Id.t * bool)) list) in (fun h id eg b -> l := (h,(id,eg,b)):: !l), (fun h -> - try List.assoc_f Constr.equal h !l with Not_found -> failwith "find_contr"), + try List.assoc_f eq_constr_nounivs h !l with Not_found -> failwith "find_contr"), (fun () -> l := []), (fun () -> !l) @@ -350,7 +350,7 @@ let coq_iff = lazy (constant "iff") (* For unfold *) let evaluable_ref_of_constr s c = match kind_of_term (Lazy.force c) with - | Const kn when Tacred.is_evaluable (Global.env()) (EvalConstRef kn) -> + | Const (kn,u) when Tacred.is_evaluable (Global.env()) (EvalConstRef kn) -> EvalConstRef kn | _ -> anomaly ~label:"Coq_omega" (Pp.str (s^" is not an evaluable constant")) @@ -367,15 +367,16 @@ let mk_var v = mkVar (Id.of_string v) let mk_plus t1 t2 = mkApp (Lazy.force coq_Zplus, [| t1; t2 |]) let mk_times t1 t2 = mkApp (Lazy.force coq_Zmult, [| t1; t2 |]) let mk_minus t1 t2 = mkApp (Lazy.force coq_Zminus, [| t1;t2 |]) -let mk_eq t1 t2 = mkApp (build_coq_eq (), [| Lazy.force coq_Z; t1; t2 |]) +let mk_eq t1 t2 = mkApp (Universes.constr_of_global (build_coq_eq ()), + [| Lazy.force coq_Z; t1; t2 |]) let mk_le t1 t2 = mkApp (Lazy.force coq_Zle, [| t1; t2 |]) let mk_gt t1 t2 = mkApp (Lazy.force coq_Zgt, [| t1; t2 |]) let mk_inv t = mkApp (Lazy.force coq_Zopp, [| t |]) let mk_and t1 t2 = mkApp (build_coq_and (), [| t1; t2 |]) let mk_or t1 t2 = mkApp (build_coq_or (), [| t1; t2 |]) let mk_not t = mkApp (build_coq_not (), [| t |]) -let mk_eq_rel t1 t2 = mkApp (build_coq_eq (), - [| Lazy.force coq_comparison; t1; t2 |]) +let mk_eq_rel t1 t2 = mkApp (Universes.constr_of_global (build_coq_eq ()), + [| Lazy.force coq_comparison; t1; t2 |]) let mk_inj t = mkApp (Lazy.force coq_Z_of_nat, [| t |]) let mk_integer n = @@ -419,7 +420,7 @@ type result = let destructurate_prop t = let c, args = decompose_app t in match kind_of_term c, args with - | _, [_;_;_] when eq_constr c (build_coq_eq ()) -> Kapp (Eq,args) + | _, [_;_;_] when eq_constr c (Universes.constr_of_global (build_coq_eq ())) -> Kapp (Eq,args) | _, [_;_] when eq_constr c (Lazy.force coq_neq) -> Kapp (Neq,args) | _, [_;_] when eq_constr c (Lazy.force coq_Zne) -> Kapp (Zne,args) | _, [_;_] when eq_constr c (Lazy.force coq_Zle) -> Kapp (Zle,args) @@ -436,11 +437,11 @@ let destructurate_prop t = | _, [_;_] when eq_constr c (Lazy.force coq_lt) -> Kapp (Lt,args) | _, [_;_] when eq_constr c (Lazy.force coq_ge) -> Kapp (Ge,args) | _, [_;_] when eq_constr c (Lazy.force coq_gt) -> Kapp (Gt,args) - | Const sp, args -> + | Const (sp,_), args -> Kapp (Other (string_of_path (path_of_global (ConstRef sp))),args) - | Construct csp , args -> + | Construct (csp,_) , args -> Kapp (Other (string_of_path (path_of_global (ConstructRef csp))), args) - | Ind isp, args -> + | Ind (isp,_), args -> Kapp (Other (string_of_path (path_of_global (IndRef isp))),args) | Var id,[] -> Kvar id | Prod (Anonymous,typ,body), [] -> Kimp(typ,body) @@ -1081,7 +1082,8 @@ let replay_history tactic_normalisation = let p_initial = [P_APP 2;P_TYPE] in let tac = shuffle_cancel p_initial e1.body in let solve_le = - let not_sup_sup = mkApp (build_coq_eq (), [| + let not_sup_sup = mkApp (Universes.constr_of_global (build_coq_eq ()), + [| Lazy.force coq_comparison; Lazy.force coq_Gt; Lazy.force coq_Gt |]) diff --git a/plugins/quote/quote.ml b/plugins/quote/quote.ml index 9ee16a582..ea459e551 100644 --- a/plugins/quote/quote.ml +++ b/plugins/quote/quote.ml @@ -196,9 +196,9 @@ let coerce_meta_in n = let compute_lhs typ i nargsi = match kind_of_term typ with - | Ind(sp,0) -> + | Ind((sp,0),u) -> let argsi = Array.init nargsi (fun j -> mkMeta (nargsi - j)) in - mkApp (mkConstruct ((sp,0),i+1), argsi) + mkApp (mkConstructU (((sp,0),i+1),u), argsi) | _ -> i_can't_do_that () (*s This function builds the pattern from the RHS. Recursive calls are @@ -221,7 +221,7 @@ let compute_rhs bodyi index_of_f = let compute_ivs f cs gl = let cst = try destConst f with DestKO -> i_can't_do_that () in - let body = Environ.constant_value (Global.env()) cst in + let body = Environ.constant_value_in (Global.env()) cst in match decomp_term body with | Fix(([| len |], 0), ([| name |], [| typ |], [| body2 |])) -> let (args3, body3) = decompose_lam body2 in diff --git a/plugins/romega/ReflOmegaCore.v b/plugins/romega/ReflOmegaCore.v index ab424c223..7e4475d40 100644 --- a/plugins/romega/ReflOmegaCore.v +++ b/plugins/romega/ReflOmegaCore.v @@ -1284,7 +1284,7 @@ Qed. (* Extraire une hypothèse de la liste *) Definition nth_hyps (n : nat) (l : hyps) := nth n l TrueTerm. - +Unset Printing Notations. Theorem nth_valid : forall (ep : list Prop) (e : list int) (i : nat) (l : hyps), interp_hyps ep e l -> interp_proposition ep e (nth_hyps i l). diff --git a/plugins/romega/const_omega.ml b/plugins/romega/const_omega.ml index 5416e936c..689462704 100644 --- a/plugins/romega/const_omega.ml +++ b/plugins/romega/const_omega.ml @@ -30,11 +30,11 @@ let string_of_global r = let destructurate t = let c, args = Term.decompose_app t in match Term.kind_of_term c, args with - | Term.Const sp, args -> + | Term.Const (sp,_), args -> Kapp (string_of_global (Globnames.ConstRef sp), args) - | Term.Construct csp , args -> + | Term.Construct (csp,_) , args -> Kapp (string_of_global (Globnames.ConstructRef csp), args) - | Term.Ind isp, args -> + | Term.Ind (isp,_), args -> Kapp (string_of_global (Globnames.IndRef isp), args) | Term.Var id,[] -> Kvar(Names.Id.to_string id) | Term.Prod (Names.Anonymous,typ,body), [] -> Kimp(typ,body) @@ -48,9 +48,9 @@ let dest_const_apply t = let f,args = Term.decompose_app t in let ref = match Term.kind_of_term f with - | Term.Const sp -> Globnames.ConstRef sp - | Term.Construct csp -> Globnames.ConstructRef csp - | Term.Ind isp -> Globnames.IndRef isp + | Term.Const (sp,_) -> Globnames.ConstRef sp + | Term.Construct (csp,_) -> Globnames.ConstructRef csp + | Term.Ind (isp,_) -> Globnames.IndRef isp | _ -> raise Destruct in Nametab.basename_of_global ref, args @@ -210,19 +210,26 @@ let rec mk_nat = function (* Lists *) -let coq_cons = lazy (constant "cons") -let coq_nil = lazy (constant "nil") +let mkListConst c u = + Term.mkConstructU (Globnames.destConstructRef + (Coqlib.gen_reference "" ["Init";"Datatypes"] c), + Univ.Instance.of_array [|u|]) -let mk_list typ l = +let coq_cons univ typ = Term.mkApp (mkListConst "cons" univ, [|typ|]) +let coq_nil univ typ = Term.mkApp (mkListConst "nil" univ, [|typ|]) + +let mk_list univ typ l = let rec loop = function - | [] -> - Term.mkApp (Lazy.force coq_nil, [|typ|]) + | [] -> coq_nil univ typ | (step :: l) -> - Term.mkApp (Lazy.force coq_cons, [|typ; step; loop l |]) in + Term.mkApp (coq_cons univ typ, [| step; loop l |]) in loop l -let mk_plist l = mk_list Term.mkProp l +let mk_plist = + let type1lev = Universes.new_univ_level (Global.current_dirpath ()) in + fun l -> mk_list type1lev Term.mkProp l +let mk_list = mk_list Univ.Level.set let mk_shuffle_list l = mk_list (Lazy.force coq_t_fusion) l diff --git a/plugins/romega/const_omega.mli b/plugins/romega/const_omega.mli index b8db71e40..4ae1cb94c 100644 --- a/plugins/romega/const_omega.mli +++ b/plugins/romega/const_omega.mli @@ -117,6 +117,7 @@ val do_seq : Term.constr -> Term.constr -> Term.constr val do_list : Term.constr list -> Term.constr val mk_nat : int -> Term.constr +(** Precondition: the type of the list is in Set *) val mk_list : Term.constr -> Term.constr list -> Term.constr val mk_plist : Term.types list -> Term.types val mk_shuffle_list : Term.constr list -> Term.constr diff --git a/plugins/rtauto/Bintree.v b/plugins/rtauto/Bintree.v index 98dd257d5..16081ffe1 100644 --- a/plugins/rtauto/Bintree.v +++ b/plugins/rtauto/Bintree.v @@ -198,7 +198,7 @@ Theorem get_Full_Gt : forall S, Full S -> Proof. intros S W;induction W. unfold empty,index,get,contents;intros;apply Tget_Tempty. -unfold index,get,push;simpl contents. +unfold index,get,push. simpl @contents. intros i e;rewrite Tget_Tadd. rewrite (Gt_Psucc _ _ e). unfold get in IHW. @@ -209,7 +209,7 @@ Theorem get_Full_Eq : forall S, Full S -> get (index S) S = PNone. intros [index0 contents0] F. case F. unfold empty,index,get,contents;intros;apply Tget_Tempty. -unfold index,get,push;simpl contents. +unfold push,index,get;simpl @contents. intros a S. rewrite Tget_Tadd. rewrite Psucc_Gt. @@ -231,12 +231,12 @@ Proof. intros i a S F. case_eq (i ?= index S). intro e;rewrite (Pos.compare_eq _ _ e). -destruct S;unfold get,push,index;simpl contents;rewrite Tget_Tadd. +destruct S;unfold get,push,index;simpl @contents;rewrite Tget_Tadd. rewrite Pos.compare_refl;reflexivity. -intros;destruct S;unfold get,push,index;simpl contents;rewrite Tget_Tadd. -simpl index in H;rewrite H;reflexivity. +intros;destruct S;unfold get,push,index;simpl @contents;rewrite Tget_Tadd. +simpl @index in H;rewrite H;reflexivity. intro H;generalize H;clear H. -unfold get,push;simpl index;simpl contents. +unfold get,push;simpl. rewrite Tget_Tadd;intro e;rewrite e. change (get i S=PNone). apply get_Full_Gt;auto. @@ -260,7 +260,7 @@ Qed. Lemma Full_index_one_empty : forall S, Full S -> index S = 1 -> S=empty. intros [ind cont] F one; inversion F. reflexivity. -simpl index in one;assert (h:=Pos.succ_not_1 (index S)). +simpl @index in one;assert (h:=Pos.succ_not_1 (index S)). congruence. Qed. diff --git a/plugins/rtauto/refl_tauto.ml b/plugins/rtauto/refl_tauto.ml index 96758788a..bff574a06 100644 --- a/plugins/rtauto/refl_tauto.ml +++ b/plugins/rtauto/refl_tauto.ml @@ -104,20 +104,20 @@ let rec make_form atom_env gls term = make_atom atom_env (normalize term) | Cast(a,_,_) -> make_form atom_env gls a - | Ind ind -> - if Names.eq_ind ind (Lazy.force li_False) then + | Ind (ind, _) -> + if Names.eq_ind ind (fst (Lazy.force li_False)) then Bot else make_atom atom_env (normalize term) | App(hd,argv) when Int.equal (Array.length argv) 2 -> begin try - let ind = destInd hd in - if Names.eq_ind ind (Lazy.force li_and) then + let ind, _ = destInd hd in + if Names.eq_ind ind (fst (Lazy.force li_and)) then let fa=make_form atom_env gls argv.(0) in let fb=make_form atom_env gls argv.(1) in Conjunct (fa,fb) - else if Names.eq_ind ind (Lazy.force li_or) then + else if Names.eq_ind ind (fst (Lazy.force li_or)) then let fa=make_form atom_env gls argv.(0) in let fb=make_form atom_env gls argv.(1) in Disjunct (fa,fb) diff --git a/plugins/setoid_ring/Field_theory.v b/plugins/setoid_ring/Field_theory.v index 3622c7fe9..2b9dce1b0 100644 --- a/plugins/setoid_ring/Field_theory.v +++ b/plugins/setoid_ring/Field_theory.v @@ -10,6 +10,7 @@ Require Ring. Import Ring_polynom Ring_tac Ring_theory InitialRing Setoid List Morphisms. Require Import ZArith_base. Set Implicit Arguments. +(* Set Universe Polymorphism. *) Section MakeFieldPol. @@ -278,6 +279,21 @@ apply radd_ext. [ ring | now rewrite rdiv_simpl ]. Qed. +Theorem rdiv3 r1 r2 r3 r4 : + ~ r2 == 0 -> + ~ r4 == 0 -> + r1 / r2 - r3 / r4 == (r1 * r4 - r3 * r2) / (r2 * r4). +Proof. +intros H2 H4. +assert (~ r2 * r4 == 0) by (apply field_is_integral_domain; trivial). +transitivity (r1 / r2 + - (r3 / r4)); auto. +transitivity (r1 / r2 + - r3 / r4); auto. +transitivity ((r1 * r4 + - r3 * r2) / (r2 * r4)). +apply rdiv2; auto. +f_equiv. +transitivity (r1 * r4 + - (r3 * r2)); auto. +Qed. + Theorem rdiv5 a b : - (a / b) == - a / b. Proof. now rewrite !rdiv_def, ropp_mul_l. @@ -696,6 +712,7 @@ Fixpoint PEsimp (e : PExpr C) : PExpr C := | _ => e end%poly. +<<<<<<< .merge_file_5Z3Qpn Theorem PEsimp_ok e : (PEsimp e === e)%poly. Proof. induction e; simpl. @@ -708,6 +725,32 @@ induction e; simpl. - rewrite NPEmul_ok. now f_equiv. - rewrite NPEopp_ok. now f_equiv. - rewrite NPEpow_ok. now f_equiv. +======= +Theorem PExpr_simp_correct: + forall l e, NPEeval l (PExpr_simp e) == NPEeval l e. +clear eq_sym. +intros l e; elim e; simpl; auto. +intros e1 He1 e2 He2. +transitivity (NPEeval l (PEadd (PExpr_simp e1) (PExpr_simp e2))); auto. +apply NPEadd_correct. +simpl; auto. +intros e1 He1 e2 He2. +transitivity (NPEeval l (PEsub (PExpr_simp e1) (PExpr_simp e2))). auto. +apply NPEsub_correct. +simpl; auto. +intros e1 He1 e2 He2. +transitivity (NPEeval l (PEmul (PExpr_simp e1) (PExpr_simp e2))); auto. +apply NPEmul_correct. +simpl; auto. +intros e1 He1. +transitivity (NPEeval l (PEopp (PExpr_simp e1))); auto. +apply NPEopp_correct. +simpl; auto. +intros e1 He1 n;simpl. +rewrite NPEpow_correct;simpl. +repeat rewrite pow_th.(rpow_pow_N). +rewrite He1;auto. +>>>>>>> .merge_file_U4r9lJ Qed. @@ -961,6 +1004,7 @@ Fixpoint split_aux e1 p e2 {struct e1}: rsplit := end end%poly. +<<<<<<< .merge_file_5Z3Qpn Lemma split_aux_ok1 e1 p e2 : (let res := match isIn e1 p e2 1 with | Some (N0,e3) => mk_rsplit 1 (e1 ^^ Npos p) e3 @@ -971,6 +1015,20 @@ Lemma split_aux_ok1 e1 p e2 : e1 ^ Npos p === left res * common res /\ e2 === right res * common res)%poly. Proof. +======= +Lemma split_aux_correct_1 : forall l e1 p e2, + let res := match isIn e1 p e2 xH with + | Some (N0,e3) => mk_rsplit (PEc cI) (NPEpow e1 (Npos p)) e3 + | Some (Npos q, e3) => mk_rsplit (NPEpow e1 (Npos q)) (NPEpow e1 (Npos (p - q))) e3 + | None => mk_rsplit (NPEpow e1 (Npos p)) (PEc cI) e2 + end in + NPEeval l (PEpow e1 (Npos p)) == NPEeval l (NPEmul (left res) (common res)) + /\ + NPEeval l e2 == NPEeval l (NPEmul (right res) (common res)). +Proof. + intros. unfold res. clear res; generalize (isIn_correct l e1 p e2 xH). + destruct (isIn e1 p e2 1). destruct p0. +>>>>>>> .merge_file_U4r9lJ Opaque NPEpow NPEmul. intros. unfold res;clear res; generalize (isIn_ok e1 p e2 xH). destruct (isIn e1 p e2 1) as [([|p'],e')|]; simpl. @@ -1090,6 +1148,7 @@ Eval compute Theorem Pcond_Fnorm l e : PCond l (condition (Fnorm e)) -> ~ (denum (Fnorm e))@l == 0. Proof. +<<<<<<< .merge_file_5Z3Qpn induction e; simpl condition; rewrite ?PCond_cons, ?PCond_app; simpl denum; intros (Hc1,Hc2) || intros Hc; rewrite ?NPEmul_ok. - simpl. rewrite phi_1; exact rI_neq_rO. @@ -1112,6 +1171,93 @@ induction e; simpl condition; rewrite ?PCond_cons, ?PCond_app; + apply split_nz_r, Hc1. - rewrite NPEpow_ok. apply PEpow_nz, IHe, Hc. Qed. +======= + induction p;simpl. + intro Hp;assert (H1 := @rmul_reg_l _ (pow_pos rmul x p * pow_pos rmul x p) 0 H). + apply IHp. + rewrite (@rmul_reg_l _ (pow_pos rmul x p) 0 IHp). + reflexivity. + rewrite H1. ring. rewrite Hp;ring. + intro Hp;apply IHp. rewrite (@rmul_reg_l _ (pow_pos rmul x p) 0 IHp). + reflexivity. rewrite Hp;ring. trivial. +Qed. + +Theorem Pcond_Fnorm: + forall l e, + PCond l (condition (Fnorm e)) -> ~ NPEeval l ((Fnorm e).(denum)) == 0. +intros l e; elim e. + simpl; intros _ _; rewrite (morph1 CRmorph); exact rI_neq_rO. + simpl; intros _ _; rewrite (morph1 CRmorph); exact rI_neq_rO. + intros e1 Hrec1 e2 Hrec2 Hcond. + simpl in Hcond. + simpl @denum. + rewrite NPEmul_correct. + simpl. + apply field_is_integral_domain. + intros HH; case Hrec1; auto. + apply PCond_app_inv_l with (1 := Hcond). + rewrite (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2))). + rewrite NPEmul_correct; simpl; rewrite HH; ring. + intros HH; case Hrec2; auto. + apply PCond_app_inv_r with (1 := Hcond). + rewrite (split_correct_r l (denum (Fnorm e1)) (denum (Fnorm e2))); auto. + intros e1 Hrec1 e2 Hrec2 Hcond. + simpl @condition in Hcond. + simpl @denum. + rewrite NPEmul_correct. + simpl. + apply field_is_integral_domain. + intros HH; case Hrec1; auto. + apply PCond_app_inv_l with (1 := Hcond). + rewrite (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2))). + rewrite NPEmul_correct; simpl; rewrite HH; ring. + intros HH; case Hrec2; auto. + apply PCond_app_inv_r with (1 := Hcond). + rewrite (split_correct_r l (denum (Fnorm e1)) (denum (Fnorm e2))); auto. + intros e1 Hrec1 e2 Hrec2 Hcond. + simpl in Hcond. + simpl @denum. + rewrite NPEmul_correct. + simpl. + apply field_is_integral_domain. + intros HH; apply Hrec1. + apply PCond_app_inv_l with (1 := Hcond). + rewrite (split_correct_r l (num (Fnorm e2)) (denum (Fnorm e1))). + rewrite NPEmul_correct; simpl; rewrite HH; ring. + intros HH; apply Hrec2. + apply PCond_app_inv_r with (1 := Hcond). + rewrite (split_correct_r l (num (Fnorm e1)) (denum (Fnorm e2))). + rewrite NPEmul_correct; simpl; rewrite HH; ring. + intros e1 Hrec1 Hcond. + simpl in Hcond. + simpl @denum. + auto. + intros e1 Hrec1 Hcond. + simpl in Hcond. + simpl @denum. + apply PCond_cons_inv_l with (1:=Hcond). + intros e1 Hrec1 e2 Hrec2 Hcond. + simpl in Hcond. + simpl @denum. + rewrite NPEmul_correct. + simpl. + apply field_is_integral_domain. + intros HH; apply Hrec1. + specialize PCond_cons_inv_r with (1:=Hcond); intro Hcond1. + apply PCond_app_inv_l with (1 := Hcond1). + rewrite (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2))). + rewrite NPEmul_correct; simpl; rewrite HH; ring. + intros HH; apply PCond_cons_inv_l with (1:=Hcond). + rewrite (split_correct_r l (num (Fnorm e1)) (num (Fnorm e2))). + rewrite NPEmul_correct; simpl; rewrite HH; ring. + simpl;intros e1 Hrec1 n Hcond. + rewrite NPEpow_correct. + simpl;rewrite pow_th.(rpow_pow_N). + destruct n;simpl;intros. + apply AFth.(AF_1_neq_0). apply pow_pos_not_0;auto. +Qed. +Hint Resolve Pcond_Fnorm. +>>>>>>> .merge_file_U4r9lJ (*************************************************************************** @@ -1502,11 +1648,21 @@ Hypothesis ceqb_complete : forall c1 c2, [c1] == [c2] -> ceqb c1 c2 = true. Lemma ceqb_spec' c1 c2 : Bool.reflect ([c1] == [c2]) (ceqb c1 c2). Proof. +<<<<<<< .merge_file_5Z3Qpn assert (H := morph_eq CRmorph c1 c2). assert (H' := @ceqb_complete c1 c2). destruct (ceqb c1 c2); constructor. - now apply H. - intro E. specialize (H' E). discriminate. +======= +intros. +generalize (fun h => X (morph_eq CRmorph _ _ h)). +generalize (@ceqb_complete c1 c2). +case (c1 ?=! c2); auto; intros. +apply X0. +red; intro. +absurd (false = true); auto; discriminate. +>>>>>>> .merge_file_U4r9lJ Qed. Fixpoint Fcons1 (e:PExpr C) (l:list (PExpr C)) {struct e} : list (PExpr C) := @@ -1766,4 +1922,4 @@ End Field. End Complete. Arguments FEO [C]. -Arguments FEI [C].
\ No newline at end of file +Arguments FEI [C]. diff --git a/plugins/setoid_ring/InitialRing.v b/plugins/setoid_ring/InitialRing.v index ca178dd38..07f49cc4f 100644 --- a/plugins/setoid_ring/InitialRing.v +++ b/plugins/setoid_ring/InitialRing.v @@ -15,6 +15,7 @@ Require Import Ring_polynom. Import List. Set Implicit Arguments. +(* Set Universe Polymorphism. *) Import RingSyntax. diff --git a/plugins/setoid_ring/Ring_polynom.v b/plugins/setoid_ring/Ring_polynom.v index 6ffa54866..5ec73950b 100644 --- a/plugins/setoid_ring/Ring_polynom.v +++ b/plugins/setoid_ring/Ring_polynom.v @@ -6,12 +6,14 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) + Set Implicit Arguments. -Require Import Setoid Morphisms BinList BinPos BinNat BinInt. +Require Import Setoid Morphisms. +Require Import BinList BinPos BinNat BinInt. Require Export Ring_theory. - Local Open Scope positive_scope. Import RingSyntax. +(* Set Universe Polymorphism. *) Section MakeRingPol. @@ -678,7 +680,7 @@ Section MakeRingPol. - add_permut. - destruct p; simpl; rewrite ?jump_pred_double; add_permut. - - destr_pos_sub; intros ->;Esimpl. + - destr_pos_sub; intros ->; Esimpl. + rewrite IHP';rsimpl. add_permut. + rewrite IHP', pow_pos_add;simpl;Esimpl. add_permut. + rewrite IHP1, pow_pos_add;rsimpl. add_permut. @@ -796,9 +798,9 @@ Section MakeRingPol. P@l == Q@l + [c] * R@l. Proof. revert l. - induction P as [c0 | j P IH | P1 IH1 i P2 IH2]; intros l; Esimpl. - - assert (H := div_th.(div_eucl_th) c0 c). - destruct cdiv as (q,r). rewrite H; Esimpl. add_permut. + induction P as [c0 | j P IH | P1 IH1 i P2 IH2]; intros l; Esimpl. + - assert (H := div_th.(div_eucl_th) c0 c). + destruct cdiv as (q,r). rewrite H; Esimpl. add_permut. - destr_factor. Esimpl. - destr_factor. Esimpl. add_permut. Qed. @@ -807,11 +809,12 @@ Section MakeRingPol. let (c,M) := cM in let (Q,R) := MFactor P c M in P@l == Q@l + [c] * M@@l * R@l. - Proof. + Proof. destruct cM as (c,M). revert M l. - induction P; destruct M; intros l; simpl; auto; + induction P; destruct M; intros l; simpl; auto; try (case ceqb_spec; intro He); - try (case Pos.compare_spec; intros He); rewrite ?He; + try (case Pos.compare_spec; intros He); + rewrite ?He; destr_factor; simpl; Esimpl. - assert (H := div_th.(div_eucl_th) c0 c). destruct cdiv as (q,r). rewrite H; Esimpl. add_permut. @@ -869,9 +872,9 @@ Section MakeRingPol. Lemma PSubstL1_ok n LM1 P1 l : MPcond LM1 l -> P1@l == (PSubstL1 P1 LM1 n)@l. Proof. - revert P1; induction LM1 as [|(M2,P2) LM2 IH]; simpl; intros. - - reflexivity. - - rewrite <- IH by intuition. now apply PNSubst1_ok. + revert P1; induction LM1 as [|(M2,P2) LM2 IH]; simpl; intros. + - reflexivity. + - rewrite <- IH by intuition; now apply PNSubst1_ok. Qed. Lemma PSubstL_ok n LM1 P1 P2 l : @@ -1483,4 +1486,4 @@ Qed. End MakeRingPol. Arguments PEO [C]. -Arguments PEI [C].
\ No newline at end of file +Arguments PEI [C]. diff --git a/plugins/setoid_ring/Ring_theory.v b/plugins/setoid_ring/Ring_theory.v index 42ce4edca..d56f50bec 100644 --- a/plugins/setoid_ring/Ring_theory.v +++ b/plugins/setoid_ring/Ring_theory.v @@ -28,6 +28,8 @@ Reserved Notation "x == y" (at level 70, no associativity). End RingSyntax. Import RingSyntax. +(* Set Universe Polymorphism. *) + Section Power. Variable R:Type. Variable rI : R. @@ -252,6 +254,7 @@ Section ALMOST_RING. Section SEMI_RING. Variable SReqe : sring_eq_ext radd rmul req. + Add Morphism radd : radd_ext1. exact (SRadd_ext SReqe). Qed. Add Morphism rmul : rmul_ext1. exact (SRmul_ext SReqe). Qed. Variable SRth : semi_ring_theory 0 1 radd rmul req. @@ -503,7 +506,6 @@ Qed. End ALMOST_RING. - Section AddRing. (* Variable R : Type. @@ -528,7 +530,6 @@ Inductive ring_kind : Type := (_ : ring_morph rO rI radd rmul rsub ropp req cO cI cadd cmul csub copp ceqb phi). - End AddRing. diff --git a/plugins/setoid_ring/newring.ml4 b/plugins/setoid_ring/newring.ml4 index 235ee8d72..7ed8e03a9 100644 --- a/plugins/setoid_ring/newring.ml4 +++ b/plugins/setoid_ring/newring.ml4 @@ -74,7 +74,7 @@ and mk_clos_app_but f_map subs f args n = | None -> mk_clos_app_but f_map subs f args (n+1) let interp_map l t = - try Some(List.assoc_f eq_constr t l) with Not_found -> None + try Some(List.assoc_f eq_constr_nounivs t l) with Not_found -> None let protect_maps = ref String.Map.empty let add_map s m = protect_maps := String.Map.add s m !protect_maps @@ -104,7 +104,7 @@ END;; (****************************************************************************) let closed_term t l = - let l = List.map constr_of_global l in + let l = List.map Universes.constr_of_global l in let cs = List.fold_right Quote.ConstrSet.add l Quote.ConstrSet.empty in if Quote.closed_under cs t then tclIDTAC else tclFAIL 0 (mt()) ;; @@ -141,15 +141,24 @@ let _ = add_tacdef false ((Loc.ghost,Id.of_string"ring_closed_term" let ic c = let env = Global.env() and sigma = Evd.empty in - Constrintern.interp_constr sigma env c + Constrintern.interp_open_constr sigma env c + +let ic_unsafe c = (*FIXME remove *) + let env = Global.env() and sigma = Evd.empty in + fst (Constrintern.interp_constr sigma env c) let ty c = Typing.type_of (Global.env()) Evd.empty c -let decl_constant na c = +let decl_constant na ctx c = + let vars = Universes.universes_of_constr c in + let ctx = Universes.restrict_universe_context (Univ.ContextSet.of_context ctx) vars in mkConst(declare_constant (Id.of_string na) (DefinitionEntry - { const_entry_body = c; + { const_entry_body = Future.from_val (c, Declareops.no_seff); const_entry_secctx = None; const_entry_type = None; + const_entry_polymorphic = false; + const_entry_universes = Univ.ContextSet.to_context ctx; + const_entry_proj = None; const_entry_opaque = true; const_entry_inline_code = false; const_entry_feedback = None; @@ -182,7 +191,11 @@ let dummy_goal env = Goal.V82.mk_goal Evd.empty (named_context_val env) mkProp Evd.Store.empty in {Evd.it = gl; Evd.sigma = sigma} -let exec_tactic env n f args = +let constr_of v = match Value.to_constr v with + | Some c -> c + | None -> failwith "Ring.exec_tactic: anomaly" + +let exec_tactic env evd n f args = let lid = List.init n (fun i -> Id.of_string("x"^string_of_int i)) in let res = ref [||] in let get_res ist = @@ -192,13 +205,14 @@ let exec_tactic env n f args = let getter = Tacexp(TacFun(List.map(fun id -> Some id) lid, Tacintern.glob_tactic(tacticIn get_res))) in - let _ = - Proofview.V82.of_tactic (Tacinterp.eval_tactic(ltac_call f (args@[getter]))) (dummy_goal env) in - !res - -let constr_of v = match Value.to_constr v with - | Some c -> c - | None -> failwith "Ring.exec_tactic: anomaly" + let gls = + (fun gl -> + let sigma = gl.Evd.sigma in + tclTHEN (Refiner.tclEVARS (Evd.merge sigma evd)) + (Proofview.V82.of_tactic (Tacinterp.eval_tactic(ltac_call f (args@[getter])))) gl) + (dummy_goal env) in + let evd, nf = Evarutil.nf_evars_and_universes (Refiner.project gls) in + Array.map (fun x -> nf (constr_of x)) !res, Evd.universe_context evd let stdlib_modules = [["Coq";"Setoids";"Setoid"]; @@ -209,6 +223,8 @@ let stdlib_modules = let coq_constant c = lazy (Coqlib.gen_constant_in_modules "Ring" stdlib_modules c) +let coq_reference c = + lazy (Coqlib.gen_reference_in_modules "Ring" stdlib_modules c) let coq_mk_Setoid = coq_constant "Build_Setoid_Theory" let coq_cons = coq_constant "cons" @@ -217,8 +233,15 @@ let coq_None = coq_constant "None" let coq_Some = coq_constant "Some" let coq_eq = coq_constant "eq" +let coq_pcons = coq_reference "cons" +let coq_pnil = coq_reference "nil" + let lapp f args = mkApp(Lazy.force f,args) +let plapp evd f args = + let fc = Evarutil.e_new_global evd (Lazy.force f) in + mkApp(fc,args) + let dest_rel0 t = match kind_of_term t with | App(f,args) when Array.length args >= 2 -> @@ -247,6 +270,8 @@ let plugin_modules = let my_constant c = lazy (Coqlib.gen_constant_in_modules "Ring" plugin_modules c) +let my_reference c = + lazy (Coqlib.gen_reference_in_modules "Ring" plugin_modules c) let new_ring_path = DirPath.make (List.map Id.of_string ["Ring_tac";plugin_dir;"Coq"]) @@ -266,9 +291,9 @@ let pol_cst s = mk_cst [plugin_dir;"Ring_polynom"] s ;; let coq_almost_ring_theory = my_constant "almost_ring_theory" (* setoid and morphism utilities *) -let coq_eq_setoid = my_constant "Eqsth" -let coq_eq_morph = my_constant "Eq_ext" -let coq_eq_smorph = my_constant "Eq_s_ext" +let coq_eq_setoid = my_reference "Eqsth" +let coq_eq_morph = my_reference "Eq_ext" +let coq_eq_smorph = my_reference "Eq_s_ext" (* ring -> almost_ring utilities *) let coq_ring_theory = my_constant "ring_theory" @@ -295,8 +320,8 @@ let ltac_inv_morph_nothing = zltac"inv_morph_nothing" let coq_pow_N_pow_N = my_constant "pow_N_pow_N" (* hypothesis *) -let coq_mkhypo = my_constant "mkhypo" -let coq_hypo = my_constant "hypo" +let coq_mkhypo = my_reference "mkhypo" +let coq_hypo = my_reference "hypo" (* Equality: do not evaluate but make recursive call on both sides *) let map_with_eq arg_map c = @@ -415,14 +440,14 @@ let theory_to_obj : ring_info -> obj = classify_function = (fun x -> Substitute x)} -let setoid_of_relation env a r = - let evm = Evd.empty in +let setoid_of_relation env evd a r = try - lapp coq_mk_Setoid - [|a ; r ; - Rewrite.get_reflexive_proof env evm a r ; - Rewrite.get_symmetric_proof env evm a r ; - Rewrite.get_transitive_proof env evm a r |] + let evm = !evd, Int.Set.empty in + let evm, refl = Rewrite.PropGlobal.get_reflexive_proof env evm a r in + let evm, sym = Rewrite.PropGlobal.get_symmetric_proof env evm a r in + let evm, trans = Rewrite.PropGlobal.get_transitive_proof env evm a r in + evd := fst evm; + lapp coq_mk_Setoid [|a ; r ; refl; sym; trans |] with Not_found -> error "cannot find setoid relation" @@ -435,7 +460,7 @@ let op_smorph r add mul req m1 m2 = (* let default_ring_equality (r,add,mul,opp,req) = *) (* let is_setoid = function *) (* {rel_refl=Some _; rel_sym=Some _;rel_trans=Some _;rel_aeq=rel} -> *) -(* eq_constr req rel (\* Qu: use conversion ? *\) *) +(* eq_constr_nounivs req rel (\* Qu: use conversion ? *\) *) (* | _ -> false in *) (* match default_relation_for_carrier ~filter:is_setoid r with *) (* Leibniz _ -> *) @@ -450,7 +475,7 @@ let op_smorph r add mul req m1 m2 = (* let is_endomorphism = function *) (* { args=args } -> List.for_all *) (* (function (var,Relation rel) -> *) -(* var=None && eq_constr req rel *) +(* var=None && eq_constr_nounivs req rel *) (* | _ -> false) args in *) (* let add_m = *) (* try default_morphism ~filter:is_endomorphism add *) @@ -485,17 +510,19 @@ let op_smorph r add mul req m1 m2 = (* op_smorph r add mul req add_m.lem mul_m.lem) in *) (* (setoid,op_morph) *) -let ring_equality (r,add,mul,opp,req) = +let ring_equality env evd (r,add,mul,opp,req) = match kind_of_term req with - | App (f, [| _ |]) when eq_constr f (Lazy.force coq_eq) -> - let setoid = lapp coq_eq_setoid [|r|] in + | App (f, [| _ |]) when eq_constr_nounivs f (Lazy.force coq_eq) -> + let setoid = plapp evd coq_eq_setoid [|r|] in let op_morph = match opp with - Some opp -> lapp coq_eq_morph [|r;add;mul;opp|] - | None -> lapp coq_eq_smorph [|r;add;mul|] in + Some opp -> plapp evd coq_eq_morph [|r;add;mul;opp|] + | None -> plapp evd coq_eq_smorph [|r;add;mul|] in + let setoid = Typing.solve_evars env evd setoid in + let op_morph = Typing.solve_evars env evd op_morph in (setoid,op_morph) | _ -> - let setoid = setoid_of_relation (Global.env ()) r req in + let setoid = setoid_of_relation (Global.env ()) evd r req in let signature = [Some (r,Some req);Some (r,Some req)],Some(r,Some req) in let add_m, add_m_lem = try Rewrite.default_morphism signature add @@ -532,22 +559,22 @@ let ring_equality (r,add,mul,opp,req) = op_smorph r add mul req add_m_lem mul_m_lem) in (setoid,op_morph) -let build_setoid_params r add mul opp req eqth = +let build_setoid_params env evd r add mul opp req eqth = match eqth with Some th -> th - | None -> ring_equality (r,add,mul,opp,req) + | None -> ring_equality env evd (r,add,mul,opp,req) let dest_ring env sigma th_spec = let th_typ = Retyping.get_type_of env sigma th_spec in match kind_of_term th_typ with App(f,[|r;zero;one;add;mul;sub;opp;req|]) - when eq_constr f (Lazy.force coq_almost_ring_theory) -> + when eq_constr_nounivs f (Lazy.force coq_almost_ring_theory) -> (None,r,zero,one,add,mul,Some sub,Some opp,req) | App(f,[|r;zero;one;add;mul;req|]) - when eq_constr f (Lazy.force coq_semi_ring_theory) -> + when eq_constr_nounivs f (Lazy.force coq_semi_ring_theory) -> (Some true,r,zero,one,add,mul,None,None,req) | App(f,[|r;zero;one;add;mul;sub;opp;req|]) - when eq_constr f (Lazy.force coq_ring_theory) -> + when eq_constr_nounivs f (Lazy.force coq_ring_theory) -> (Some false,r,zero,one,add,mul,Some sub,Some opp,req) | _ -> error "bad ring structure" @@ -557,10 +584,10 @@ let dest_morph env sigma m_spec = match kind_of_term m_typ with App(f,[|r;zero;one;add;mul;sub;opp;req; c;czero;cone;cadd;cmul;csub;copp;ceqb;phi|]) - when eq_constr f (Lazy.force coq_ring_morph) -> + when eq_constr_nounivs f (Lazy.force coq_ring_morph) -> (c,czero,cone,cadd,cmul,Some csub,Some copp,ceqb,phi) | App(f,[|r;zero;one;add;mul;req;c;czero;cone;cadd;cmul;ceqb;phi|]) - when eq_constr f (Lazy.force coq_semi_morph) -> + when eq_constr_nounivs f (Lazy.force coq_semi_morph) -> (c,czero,cone,cadd,cmul,None,None,ceqb,phi) | _ -> error "bad morphism structure" @@ -591,18 +618,22 @@ let interp_cst_tac env sigma rk kind (zero,one,add,mul,opp) cst_tac = let t = ArgArg(Loc.ghost,Lazy.force ltac_inv_morph_nothing) in TacArg(Loc.ghost,TacCall(Loc.ghost,t,[])) -let make_hyp env c = - let t = Retyping.get_type_of env Evd.empty c in - lapp coq_mkhypo [|t;c|] - -let make_hyp_list env lH = - let carrier = Lazy.force coq_hypo in - List.fold_right - (fun c l -> lapp coq_cons [|carrier; (make_hyp env c); l|]) lH - (lapp coq_nil [|carrier|]) - -let interp_power env pow = - let carrier = Lazy.force coq_hypo in +let make_hyp env evd c = + let t = Retyping.get_type_of env !evd c in + plapp evd coq_mkhypo [|t;c|] + +let make_hyp_list env evd lH = + let carrier = Evarutil.e_new_global evd (Lazy.force coq_hypo) in + let l = + List.fold_right + (fun c l -> plapp evd coq_pcons [|carrier; (make_hyp env evd c); l|]) lH + (plapp evd coq_pnil [|carrier|]) + in + let l' = Typing.solve_evars env evd l in + Evarutil.nf_evars_universes !evd l' + +let interp_power env evd pow = + let carrier = Evarutil.e_new_global evd (Lazy.force coq_hypo) in match pow with | None -> let t = ArgArg(Loc.ghost, Lazy.force ltac_inv_morph_nothing) in @@ -613,47 +644,47 @@ let interp_power env pow = | CstTac t -> Tacintern.glob_tactic t | Closed lc -> closed_term_ast (List.map Smartlocate.global_with_alias lc) in - let spec = make_hyp env (ic spec) in + let spec = make_hyp env evd (ic_unsafe spec) in (tac, lapp coq_Some [|carrier; spec|]) -let interp_sign env sign = - let carrier = Lazy.force coq_hypo in +let interp_sign env evd sign = + let carrier = Evarutil.e_new_global evd (Lazy.force coq_hypo) in match sign with | None -> lapp coq_None [|carrier|] | Some spec -> - let spec = make_hyp env (ic spec) in + let spec = make_hyp env evd (ic_unsafe spec) in lapp coq_Some [|carrier;spec|] (* Same remark on ill-typed terms ... *) -let interp_div env div = - let carrier = Lazy.force coq_hypo in +let interp_div env evd div = + let carrier = Evarutil.e_new_global evd (Lazy.force coq_hypo) in match div with | None -> lapp coq_None [|carrier|] | Some spec -> - let spec = make_hyp env (ic spec) in + let spec = make_hyp env evd (ic_unsafe spec) in lapp coq_Some [|carrier;spec|] (* Same remark on ill-typed terms ... *) -let add_theory name rth eqth morphth cst_tac (pre,post) power sign div = +let add_theory name (sigma,rth) eqth morphth cst_tac (pre,post) power sign div = check_required_library (cdir@["Ring_base"]); let env = Global.env() in - let sigma = Evd.empty in let (kind,r,zero,one,add,mul,sub,opp,req) = dest_ring env sigma rth in - let (sth,ext) = build_setoid_params r add mul opp req eqth in - let (pow_tac, pspec) = interp_power env power in - let sspec = interp_sign env sign in - let dspec = interp_div env div in + let evd = ref sigma in + let (sth,ext) = build_setoid_params env evd r add mul opp req eqth in + let (pow_tac, pspec) = interp_power env evd power in + let sspec = interp_sign env evd sign in + let dspec = interp_div env evd div in let rk = reflect_coeff morphth in - let params = - exec_tactic env 5 (zltac "ring_lemmas") + let params,ctx = + exec_tactic env !evd 5 (zltac "ring_lemmas") (List.map carg[sth;ext;rth;pspec;sspec;dspec;rk]) in - let lemma1 = constr_of params.(3) in - let lemma2 = constr_of params.(4) in + let lemma1 = params.(3) in + let lemma2 = params.(4) in let lemma1 = - decl_constant (Id.to_string name^"_ring_lemma1") (Future.from_val ( lemma1,Declareops.no_seff)) in + decl_constant (Id.to_string name^"_ring_lemma1") ctx (Future.from_val ( lemma1,Declareops.no_seff)) in let lemma2 = - decl_constant (Id.to_string name^"_ring_lemma2") (Future.from_val ( lemma2,Declareops.no_seff)) in + decl_constant (Id.to_string name^"_ring_lemma2") ctx (Future.from_val ( lemma2,Declareops.no_seff)) in let cst_tac = interp_cst_tac env sigma morphth kind (zero,one,add,mul,opp) cst_tac in let pretac = @@ -670,9 +701,9 @@ let add_theory name rth eqth morphth cst_tac (pre,post) power sign div = { ring_carrier = r; ring_req = req; ring_setoid = sth; - ring_ext = constr_of params.(1); - ring_morph = constr_of params.(2); - ring_th = constr_of params.(0); + ring_ext = params.(1); + ring_morph = params.(2); + ring_th = params.(0); ring_cst_tac = cst_tac; ring_pow_tac = pow_tac; ring_lemma1 = lemma1; @@ -692,16 +723,11 @@ type 'constr ring_mod = | Sign_spec of Constrexpr.constr_expr | Div_spec of Constrexpr.constr_expr -let ic_coeff_spec = function - | Computational t -> Computational (ic t) - | Morphism t -> Morphism (ic t) - | Abstract -> Abstract - VERNAC ARGUMENT EXTEND ring_mod - | [ "decidable" constr(eq_test) ] -> [ Ring_kind(Computational eq_test) ] + | [ "decidable" constr(eq_test) ] -> [ Ring_kind(Computational (ic_unsafe eq_test)) ] | [ "abstract" ] -> [ Ring_kind Abstract ] - | [ "morphism" constr(morph) ] -> [ Ring_kind(Morphism morph) ] + | [ "morphism" constr(morph) ] -> [ Ring_kind(Morphism (ic_unsafe morph)) ] | [ "constants" "[" tactic(cst_tac) "]" ] -> [ Const_tac(CstTac cst_tac) ] | [ "closed" "[" ne_global_list(l) "]" ] -> [ Const_tac(Closed l) ] | [ "preprocess" "[" tactic(pre) "]" ] -> [ Pre_tac pre ] @@ -732,11 +758,11 @@ let process_ring_mods l = | Const_tac t -> set_once "tactic recognizing constants" cst_tac t | Pre_tac t -> set_once "preprocess tactic" pre t | Post_tac t -> set_once "postprocess tactic" post t - | Setoid(sth,ext) -> set_once "setoid" set (ic sth,ic ext) + | Setoid(sth,ext) -> set_once "setoid" set (ic_unsafe sth,ic_unsafe ext) | Pow_spec(t,spec) -> set_once "power" power (t,spec) | Sign_spec t -> set_once "sign" sign t | Div_spec t -> set_once "div" div t) l; - let k = match !kind with Some k -> ic_coeff_spec k | None -> Abstract in + let k = match !kind with Some k -> k | None -> Abstract in (k, !set, !cst_tac, !pre, !post, !power, !sign, !div) VERNAC COMMAND EXTEND AddSetoidRing CLASSIFIED AS SIDEFF @@ -762,10 +788,11 @@ let make_args_list rl t = | [] -> let (_,t1,t2) = dest_rel0 t in [t1;t2] | _ -> rl -let make_term_list carrier rl = - List.fold_right - (fun x l -> lapp coq_cons [|carrier;x;l|]) rl - (lapp coq_nil [|carrier|]) +let make_term_list env evd carrier rl = + let l = List.fold_right + (fun x l -> plapp evd coq_pcons [|carrier;x;l|]) rl + (plapp evd coq_pnil [|carrier|]) + in Typing.solve_evars env evd l let ltac_ring_structure e = let req = carg e.ring_req in @@ -786,12 +813,15 @@ let ring_lookup (f:glob_tactic_expr) lH rl t = Proofview.Goal.raw_enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in - let rl = make_args_list rl t in - let e = find_ring_structure env sigma rl in - let rl = carg (make_term_list e.ring_carrier rl) in - let lH = carg (make_hyp_list env lH) in - let ring = ltac_ring_structure e in - ltac_apply f (ring@[lH;rl]) + try (* find_ring_strucure can raise an exception *) + let evdref = ref sigma in + let rl = make_args_list rl t in + let e = find_ring_structure env sigma rl in + let rl = carg (make_term_list env evdref e.ring_carrier rl) in + let lH = carg (make_hyp_list env evdref lH) in + let ring = ltac_ring_structure e in + Proofview.tclTHEN (Proofview.V82.tclEVARS !evdref) (ltac_apply f (ring@[lH;rl])) + with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e end TACTIC EXTEND ring_lookup @@ -850,26 +880,26 @@ let _ = Redexpr.declare_reduction "simpl_field_expr" let afield_theory = my_constant "almost_field_theory" let field_theory = my_constant "field_theory" let sfield_theory = my_constant "semi_field_theory" -let af_ar = my_constant"AF_AR" -let f_r = my_constant"F_R" -let sf_sr = my_constant"SF_SR" -let dest_field env sigma th_spec = - let th_typ = Retyping.get_type_of env sigma th_spec in +let af_ar = my_reference"AF_AR" +let f_r = my_reference"F_R" +let sf_sr = my_reference"SF_SR" +let dest_field env evd th_spec = + let th_typ = Retyping.get_type_of env !evd th_spec in match kind_of_term th_typ with | App(f,[|r;zero;one;add;mul;sub;opp;div;inv;req|]) - when eq_constr f (Lazy.force afield_theory) -> - let rth = lapp af_ar + when eq_constr_nounivs f (Lazy.force afield_theory) -> + let rth = plapp evd af_ar [|r;zero;one;add;mul;sub;opp;div;inv;req;th_spec|] in (None,r,zero,one,add,mul,Some sub,Some opp,div,inv,req,rth) | App(f,[|r;zero;one;add;mul;sub;opp;div;inv;req|]) - when eq_constr f (Lazy.force field_theory) -> + when eq_constr_nounivs f (Lazy.force field_theory) -> let rth = - lapp f_r + plapp evd f_r [|r;zero;one;add;mul;sub;opp;div;inv;req;th_spec|] in (Some false,r,zero,one,add,mul,Some sub,Some opp,div,inv,req,rth) | App(f,[|r;zero;one;add;mul;div;inv;req|]) - when eq_constr f (Lazy.force sfield_theory) -> - let rth = lapp sf_sr + when eq_constr_nounivs f (Lazy.force sfield_theory) -> + let rth = plapp evd sf_sr [|r;zero;one;add;mul;div;inv;req;th_spec|] in (Some true,r,zero,one,add,mul,None,None,div,inv,req,rth) | _ -> error "bad field structure" @@ -960,12 +990,12 @@ let ftheory_to_obj : field_info -> obj = subst_function = subst_th; classify_function = (fun x -> Substitute x) } -let field_equality r inv req = +let field_equality evd r inv req = match kind_of_term req with - | App (f, [| _ |]) when eq_constr f (Lazy.force coq_eq) -> - mkApp((Coqlib.build_coq_eq_data()).congr,[|r;r;inv|]) + | App (f, [| _ |]) when eq_constr_nounivs f (Lazy.force coq_eq) -> + mkApp(Universes.constr_of_global (Coqlib.build_coq_eq_data()).congr,[|r;r;inv|]) | _ -> - let _setoid = setoid_of_relation (Global.env ()) r req in + let _setoid = setoid_of_relation (Global.env ()) evd r req in let signature = [Some (r,Some req)],Some(r,Some req) in let inv_m, inv_m_lem = try Rewrite.default_morphism signature inv @@ -973,36 +1003,41 @@ let field_equality r inv req = error "field inverse should be declared as a morphism" in inv_m_lem -let add_field_theory name fth eqth morphth cst_tac inj (pre,post) power sign odiv = +let add_field_theory name (sigma,fth) eqth morphth cst_tac inj (pre,post) power sign odiv = check_required_library (cdir@["Field_tac"]); let env = Global.env() in - let sigma = Evd.empty in + let evd = ref sigma in let (kind,r,zero,one,add,mul,sub,opp,div,inv,req,rth) = - dest_field env sigma fth in - let (sth,ext) = build_setoid_params r add mul opp req eqth in + dest_field env evd fth in + let (sth,ext) = build_setoid_params env evd r add mul opp req eqth in let eqth = Some(sth,ext) in - let _ = add_theory name rth eqth morphth cst_tac (None,None) power sign odiv in - let (pow_tac, pspec) = interp_power env power in - let sspec = interp_sign env sign in - let dspec = interp_div env odiv in - let inv_m = field_equality r inv req in + let _ = add_theory name (!evd,rth) eqth morphth cst_tac (None,None) power sign odiv in + let (pow_tac, pspec) = interp_power env evd power in + let sspec = interp_sign env evd sign in + let dspec = interp_div env evd odiv in + let inv_m = field_equality evd r inv req in let rk = reflect_coeff morphth in - let params = - exec_tactic env 9 (field_ltac"field_lemmas") + let params,ctx = + exec_tactic env !evd 9 (field_ltac"field_lemmas") (List.map carg[sth;ext;inv_m;fth;pspec;sspec;dspec;rk]) in - let lemma1 = constr_of params.(3) in - let lemma2 = constr_of params.(4) in - let lemma3 = constr_of params.(5) in - let lemma4 = constr_of params.(6) in + let lemma1 = params.(3) in + let lemma2 = params.(4) in + let lemma3 = params.(5) in + let lemma4 = params.(6) in let cond_lemma = match inj with | Some thm -> mkApp(constr_of params.(8),[|thm|]) | None -> constr_of params.(7) in - let lemma1 = decl_constant (Id.to_string name^"_field_lemma1") (Future.from_val (lemma1,Declareops.no_seff)) in - let lemma2 = decl_constant (Id.to_string name^"_field_lemma2") (Future.from_val (lemma2,Declareops.no_seff)) in - let lemma3 = decl_constant (Id.to_string name^"_field_lemma3") (Future.from_val (lemma3,Declareops.no_seff)) in - let lemma4 = decl_constant (Id.to_string name^"_field_lemma4") (Future.from_val (lemma4,Declareops.no_seff)) in - let cond_lemma = decl_constant (Id.to_string name^"_lemma5") (Future.from_val (cond_lemma,Declareops.no_seff)) in + let lemma1 = decl_constant (Id.to_string name^"_field_lemma1") + ctx (Future.from_val (lemma1,Declareops.no_seff)) in + let lemma2 = decl_constant (Id.to_string name^"_field_lemma2") + ctx (Future.from_val (lemma2,Declareops.no_seff)) in + let lemma3 = decl_constant (Id.to_string name^"_field_lemma3") + ctx (Future.from_val (lemma3,Declareops.no_seff)) in + let lemma4 = decl_constant (Id.to_string name^"_field_lemma4") + ctx (Future.from_val (lemma4,Declareops.no_seff)) in + let cond_lemma = decl_constant (Id.to_string name^"_lemma5") + ctx (Future.from_val (cond_lemma,Declareops.no_seff)) in let cst_tac = interp_cst_tac env sigma morphth kind (zero,one,add,mul,opp) cst_tac in let pretac = @@ -1053,12 +1088,12 @@ let process_field_mods l = set_once "tactic recognizing constants" cst_tac t | Ring_mod(Pre_tac t) -> set_once "preprocess tactic" pre t | Ring_mod(Post_tac t) -> set_once "postprocess tactic" post t - | Ring_mod(Setoid(sth,ext)) -> set_once "setoid" set (ic sth,ic ext) + | Ring_mod(Setoid(sth,ext)) -> set_once "setoid" set (ic_unsafe sth,ic_unsafe ext) | Ring_mod(Pow_spec(t,spec)) -> set_once "power" power (t,spec) | Ring_mod(Sign_spec t) -> set_once "sign" sign t | Ring_mod(Div_spec t) -> set_once "div" div t - | Inject i -> set_once "infinite property" inj (ic i)) l; - let k = match !kind with Some k -> ic_coeff_spec k | None -> Abstract in + | Inject i -> set_once "infinite property" inj (ic_unsafe i)) l; + let k = match !kind with Some k -> k | None -> Abstract in (k, !set, !inj, !cst_tac, !pre, !post, !power, !sign, !div) VERNAC COMMAND EXTEND AddSetoidField CLASSIFIED AS SIDEFF @@ -1094,12 +1129,15 @@ let field_lookup (f:glob_tactic_expr) lH rl t = Proofview.Goal.raw_enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in - let rl = make_args_list rl t in - let e = find_field_structure env sigma rl in - let rl = carg (make_term_list e.field_carrier rl) in - let lH = carg (make_hyp_list env lH) in - let field = ltac_field_structure e in - ltac_apply f (field@[lH;rl]) + try + let evdref = ref sigma in + let rl = make_args_list rl t in + let e = find_field_structure env sigma rl in + let rl = carg (make_term_list env evdref e.field_carrier rl) in + let lH = carg (make_hyp_list env evdref lH) in + let field = ltac_field_structure e in + Proofview.tclTHEN (Proofview.V82.tclEVARS !evdref) (ltac_apply f (field@[lH;rl])) + with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e end diff --git a/plugins/syntax/ascii_syntax.ml b/plugins/syntax/ascii_syntax.ml index 790e1970b..5c060c3d6 100644 --- a/plugins/syntax/ascii_syntax.ml +++ b/plugins/syntax/ascii_syntax.ml @@ -37,9 +37,9 @@ let interp_ascii dloc p = let rec aux n p = if Int.equal n 0 then [] else let mp = p mod 2 in - GRef (dloc,if Int.equal mp 0 then glob_false else glob_true) + GRef (dloc,if Int.equal mp 0 then glob_false else glob_true,None) :: (aux (n-1) (p/2)) in - GApp (dloc,GRef(dloc,force glob_Ascii), aux 8 p) + GApp (dloc,GRef(dloc,force glob_Ascii,None), aux 8 p) let interp_ascii_string dloc s = let p = @@ -55,12 +55,12 @@ let interp_ascii_string dloc s = let uninterp_ascii r = let rec uninterp_bool_list n = function | [] when Int.equal n 0 -> 0 - | GRef (_,k)::l when Globnames.eq_gr k glob_true -> 1+2*(uninterp_bool_list (n-1) l) - | GRef (_,k)::l when Globnames.eq_gr k glob_false -> 2*(uninterp_bool_list (n-1) l) + | GRef (_,k,_)::l when Globnames.eq_gr k glob_true -> 1+2*(uninterp_bool_list (n-1) l) + | GRef (_,k,_)::l when Globnames.eq_gr k glob_false -> 2*(uninterp_bool_list (n-1) l) | _ -> raise Non_closed_ascii in try let aux = function - | GApp (_,GRef (_,k),l) when Globnames.eq_gr k (force glob_Ascii) -> uninterp_bool_list 8 l + | GApp (_,GRef (_,k,_),l) when Globnames.eq_gr k (force glob_Ascii) -> uninterp_bool_list 8 l | _ -> raise Non_closed_ascii in Some (aux r) with @@ -76,4 +76,4 @@ let _ = Notation.declare_string_interpreter "char_scope" (ascii_path,ascii_module) interp_ascii_string - ([GRef (Loc.ghost,static_glob_Ascii)], uninterp_ascii_string, true) + ([GRef (Loc.ghost,static_glob_Ascii,None)], uninterp_ascii_string, true) diff --git a/plugins/syntax/nat_syntax.ml b/plugins/syntax/nat_syntax.ml index c3dad0a10..bad099d4f 100644 --- a/plugins/syntax/nat_syntax.ml +++ b/plugins/syntax/nat_syntax.ml @@ -30,8 +30,8 @@ let nat_of_int dloc n = strbrk "working with large numbers in nat (observed threshold " ++ strbrk "may vary from 5000 to 70000 depending on your system " ++ strbrk "limits and on the command executed)."); - let ref_O = GRef (dloc, glob_O) in - let ref_S = GRef (dloc, glob_S) in + let ref_O = GRef (dloc, glob_O, None) in + let ref_S = GRef (dloc, glob_S, None) in let rec mk_nat acc n = if n <> zero then mk_nat (GApp (dloc,ref_S, [acc])) (sub_1 n) @@ -50,8 +50,8 @@ let nat_of_int dloc n = exception Non_closed_number let rec int_of_nat = function - | GApp (_,GRef (_,s),[a]) when Globnames.eq_gr s glob_S -> add_1 (int_of_nat a) - | GRef (_,z) when Globnames.eq_gr z glob_O -> zero + | GApp (_,GRef (_,s,_),[a]) when Globnames.eq_gr s glob_S -> add_1 (int_of_nat a) + | GRef (_,z,_) when Globnames.eq_gr z glob_O -> zero | _ -> raise Non_closed_number let uninterp_nat p = @@ -67,4 +67,4 @@ let _ = Notation.declare_numeral_interpreter "nat_scope" (nat_path,datatypes_module_name) nat_of_int - ([GRef (Loc.ghost,glob_S); GRef (Loc.ghost,glob_O)], uninterp_nat, true) + ([GRef (Loc.ghost,glob_S,None); GRef (Loc.ghost,glob_O,None)], uninterp_nat, true) diff --git a/plugins/syntax/numbers_syntax.ml b/plugins/syntax/numbers_syntax.ml index 8e09c974a..a6b3d9038 100644 --- a/plugins/syntax/numbers_syntax.ml +++ b/plugins/syntax/numbers_syntax.ml @@ -83,9 +83,9 @@ exception Non_closed (* parses a *non-negative* integer (from bigint.ml) into an int31 wraps modulo 2^31 *) let int31_of_pos_bigint dloc n = - let ref_construct = GRef (dloc, int31_construct) in - let ref_0 = GRef (dloc, int31_0) in - let ref_1 = GRef (dloc, int31_1) in + let ref_construct = GRef (dloc, int31_construct, None) in + let ref_0 = GRef (dloc, int31_0, None) in + let ref_1 = GRef (dloc, int31_1, None) in let rec args counter n = if counter <= 0 then [] @@ -110,12 +110,12 @@ let bigint_of_int31 = let rec args_parsing args cur = match args with | [] -> cur - | (GRef (_,b))::l when eq_gr b int31_0 -> args_parsing l (mult_2 cur) - | (GRef (_,b))::l when eq_gr b int31_1 -> args_parsing l (add_1 (mult_2 cur)) + | (GRef (_,b,_))::l when eq_gr b int31_0 -> args_parsing l (mult_2 cur) + | (GRef (_,b,_))::l when eq_gr b int31_1 -> args_parsing l (add_1 (mult_2 cur)) | _ -> raise Non_closed in function - | GApp (_, GRef (_, c), args) when eq_gr c int31_construct -> args_parsing args zero + | GApp (_, GRef (_, c, _), args) when eq_gr c int31_construct -> args_parsing args zero | _ -> raise Non_closed let uninterp_int31 i = @@ -128,7 +128,7 @@ let uninterp_int31 i = let _ = Notation.declare_numeral_interpreter int31_scope (int31_path, int31_module) interp_int31 - ([GRef (Loc.ghost, int31_construct)], + ([GRef (Loc.ghost, int31_construct, None)], uninterp_int31, true) @@ -159,8 +159,8 @@ let height bi = (* n must be a non-negative integer (from bigint.ml) *) let word_of_pos_bigint dloc hght n = - let ref_W0 = GRef (dloc, zn2z_W0) in - let ref_WW = GRef (dloc, zn2z_WW) in + let ref_W0 = GRef (dloc, zn2z_W0, None) in + let ref_WW = GRef (dloc, zn2z_WW, None) in let rec decomp hgt n = if hgt <= 0 then int31_of_pos_bigint dloc n @@ -176,7 +176,7 @@ let word_of_pos_bigint dloc hght n = let bigN_of_pos_bigint dloc n = let h = height n in - let ref_constructor = GRef (dloc, bigN_constructor h) in + let ref_constructor = GRef (dloc, bigN_constructor h, None) in let word = word_of_pos_bigint dloc h n in let args = if h < n_inlined then [word] @@ -199,14 +199,14 @@ let interp_bigN dloc n = let bigint_of_word = let rec get_height rc = match rc with - | GApp (_,GRef(_,c), [_;lft;rght]) when eq_gr c zn2z_WW -> + | GApp (_,GRef(_,c,_), [_;lft;rght]) when eq_gr c zn2z_WW -> 1+max (get_height lft) (get_height rght) | _ -> 0 in let rec transform hght rc = match rc with - | GApp (_,GRef(_,c),_) when eq_gr c zn2z_W0-> zero - | GApp (_,GRef(_,c), [_;lft;rght]) when eq_gr c zn2z_WW-> + | GApp (_,GRef(_,c,_),_) when eq_gr c zn2z_W0-> zero + | GApp (_,GRef(_,c,_), [_;lft;rght]) when eq_gr c zn2z_WW-> let new_hght = hght-1 in add (mult (rank new_hght) (transform new_hght lft)) @@ -236,7 +236,7 @@ let uninterp_bigN rc = let bigN_list_of_constructors = let rec build i = if i < n_inlined+1 then - GRef (Loc.ghost, bigN_constructor i)::(build (i+1)) + GRef (Loc.ghost, bigN_constructor i,None)::(build (i+1)) else [] in @@ -253,8 +253,8 @@ let _ = Notation.declare_numeral_interpreter bigN_scope (*** Parsing for bigZ in digital notation ***) let interp_bigZ dloc n = - let ref_pos = GRef (dloc, bigZ_pos) in - let ref_neg = GRef (dloc, bigZ_neg) in + let ref_pos = GRef (dloc, bigZ_pos, None) in + let ref_neg = GRef (dloc, bigZ_neg, None) in if is_pos_or_zero n then GApp (dloc, ref_pos, [bigN_of_pos_bigint dloc n]) else @@ -262,8 +262,8 @@ let interp_bigZ dloc n = (* pretty printing functions for bigZ *) let bigint_of_bigZ = function - | GApp (_, GRef(_,c), [one_arg]) when eq_gr c bigZ_pos -> bigint_of_bigN one_arg - | GApp (_, GRef(_,c), [one_arg]) when eq_gr c bigZ_neg -> + | GApp (_, GRef(_,c,_), [one_arg]) when eq_gr c bigZ_pos -> bigint_of_bigN one_arg + | GApp (_, GRef(_,c,_), [one_arg]) when eq_gr c bigZ_neg -> let opp_val = bigint_of_bigN one_arg in if equal opp_val zero then raise Non_closed @@ -282,19 +282,19 @@ let uninterp_bigZ rc = let _ = Notation.declare_numeral_interpreter bigZ_scope (bigZ_path, bigZ_module) interp_bigZ - ([GRef (Loc.ghost, bigZ_pos); - GRef (Loc.ghost, bigZ_neg)], + ([GRef (Loc.ghost, bigZ_pos, None); + GRef (Loc.ghost, bigZ_neg, None)], uninterp_bigZ, true) (*** Parsing for bigQ in digital notation ***) let interp_bigQ dloc n = - let ref_z = GRef (dloc, bigQ_z) in + let ref_z = GRef (dloc, bigQ_z, None) in GApp (dloc, ref_z, [interp_bigZ dloc n]) let uninterp_bigQ rc = try match rc with - | GApp (_, GRef(_,c), [one_arg]) when eq_gr c bigQ_z -> + | GApp (_, GRef(_,c,_), [one_arg]) when eq_gr c bigQ_z -> Some (bigint_of_bigZ one_arg) | _ -> None (* we don't pretty-print yet fractions *) with Non_closed -> None @@ -303,5 +303,5 @@ let uninterp_bigQ rc = let _ = Notation.declare_numeral_interpreter bigQ_scope (bigQ_path, bigQ_module) interp_bigQ - ([GRef (Loc.ghost, bigQ_z)], uninterp_bigQ, + ([GRef (Loc.ghost, bigQ_z, None)], uninterp_bigQ, true) diff --git a/plugins/syntax/r_syntax.ml b/plugins/syntax/r_syntax.ml index 545f205db..dac70c673 100644 --- a/plugins/syntax/r_syntax.ml +++ b/plugins/syntax/r_syntax.ml @@ -42,24 +42,24 @@ let four = mult_2 two (* Unary representation of strictly positive numbers *) let rec small_r dloc n = - if equal one n then GRef (dloc, glob_R1) - else GApp(dloc,GRef (dloc,glob_Rplus), - [GRef (dloc, glob_R1);small_r dloc (sub_1 n)]) + if equal one n then GRef (dloc, glob_R1, None) + else GApp(dloc,GRef (dloc,glob_Rplus, None), + [GRef (dloc, glob_R1, None);small_r dloc (sub_1 n)]) let r_of_posint dloc n = - let r1 = GRef (dloc, glob_R1) in + let r1 = GRef (dloc, glob_R1, None) in let r2 = small_r dloc two in let rec r_of_pos n = if less_than n four then small_r dloc n else let (q,r) = div2_with_rest n in - let b = GApp(dloc,GRef(dloc,glob_Rmult),[r2;r_of_pos q]) in - if r then GApp(dloc,GRef(dloc,glob_Rplus),[r1;b]) else b in - if not (Bigint.equal n zero) then r_of_pos n else GRef(dloc,glob_R0) + let b = GApp(dloc,GRef(dloc,glob_Rmult,None),[r2;r_of_pos q]) in + if r then GApp(dloc,GRef(dloc,glob_Rplus,None),[r1;b]) else b in + if not (Bigint.equal n zero) then r_of_pos n else GRef(dloc,glob_R0,None) let r_of_int dloc z = if is_strictly_neg z then - GApp (dloc, GRef(dloc,glob_Ropp), [r_of_posint dloc (neg z)]) + GApp (dloc, GRef(dloc,glob_Ropp,None), [r_of_posint dloc (neg z)]) else r_of_posint dloc z @@ -71,33 +71,33 @@ let bignat_of_r = (* for numbers > 1 *) let rec bignat_of_pos = function (* 1+1 *) - | GApp (_,GRef (_,p), [GRef (_,o1); GRef (_,o2)]) + | GApp (_,GRef (_,p,_), [GRef (_,o1,_); GRef (_,o2,_)]) when Globnames.eq_gr p glob_Rplus && Globnames.eq_gr o1 glob_R1 && Globnames.eq_gr o2 glob_R1 -> two (* 1+(1+1) *) - | GApp (_,GRef (_,p1), [GRef (_,o1); - GApp(_,GRef (_,p2),[GRef(_,o2);GRef(_,o3)])]) + | GApp (_,GRef (_,p1,_), [GRef (_,o1,_); + GApp(_,GRef (_,p2,_),[GRef(_,o2,_);GRef(_,o3,_)])]) when Globnames.eq_gr p1 glob_Rplus && Globnames.eq_gr p2 glob_Rplus && Globnames.eq_gr o1 glob_R1 && Globnames.eq_gr o2 glob_R1 && Globnames.eq_gr o3 glob_R1 -> three (* (1+1)*b *) - | GApp (_,GRef (_,p), [a; b]) when Globnames.eq_gr p glob_Rmult -> + | GApp (_,GRef (_,p,_), [a; b]) when Globnames.eq_gr p glob_Rmult -> if not (Bigint.equal (bignat_of_pos a) two) then raise Non_closed_number; mult_2 (bignat_of_pos b) (* 1+(1+1)*b *) - | GApp (_,GRef (_,p1), [GRef (_,o); GApp (_,GRef (_,p2),[a;b])]) + | GApp (_,GRef (_,p1,_), [GRef (_,o,_); GApp (_,GRef (_,p2,_),[a;b])]) when Globnames.eq_gr p1 glob_Rplus && Globnames.eq_gr p2 glob_Rmult && Globnames.eq_gr o glob_R1 -> if not (Bigint.equal (bignat_of_pos a) two) then raise Non_closed_number; add_1 (mult_2 (bignat_of_pos b)) | _ -> raise Non_closed_number in let bignat_of_r = function - | GRef (_,a) when Globnames.eq_gr a glob_R0 -> zero - | GRef (_,a) when Globnames.eq_gr a glob_R1 -> one + | GRef (_,a,_) when Globnames.eq_gr a glob_R0 -> zero + | GRef (_,a,_) when Globnames.eq_gr a glob_R1 -> one | r -> bignat_of_pos r in bignat_of_r let bigint_of_r = function - | GApp (_,GRef (_,o), [a]) when Globnames.eq_gr o glob_Ropp -> + | GApp (_,GRef (_,o,_), [a]) when Globnames.eq_gr o glob_Ropp -> let n = bignat_of_r a in if Bigint.equal n zero then raise Non_closed_number; neg n @@ -109,11 +109,12 @@ let uninterp_r p = with Non_closed_number -> None +let mkGRef gr = GRef (Loc.ghost,gr,None) + let _ = Notation.declare_numeral_interpreter "R_scope" (r_path,["Coq";"Reals";"Rdefinitions"]) r_of_int - ([GRef(Loc.ghost,glob_Ropp);GRef(Loc.ghost,glob_R0); - GRef(Loc.ghost,glob_Rplus);GRef(Loc.ghost,glob_Rmult); - GRef(Loc.ghost,glob_R1)], + (List.map mkGRef + [glob_Ropp;glob_R0;glob_Rplus;glob_Rmult;glob_R1], uninterp_r, false) diff --git a/plugins/syntax/string_syntax.ml b/plugins/syntax/string_syntax.ml index 54206b453..2e696f391 100644 --- a/plugins/syntax/string_syntax.ml +++ b/plugins/syntax/string_syntax.ml @@ -32,8 +32,8 @@ open Lazy let interp_string dloc s = let le = String.length s in let rec aux n = - if n = le then GRef (dloc, force glob_EmptyString) else - GApp (dloc,GRef (dloc, force glob_String), + if n = le then GRef (dloc, force glob_EmptyString, None) else + GApp (dloc,GRef (dloc, force glob_String, None), [interp_ascii dloc (int_of_char s.[n]); aux (n+1)]) in aux 0 @@ -41,11 +41,11 @@ let uninterp_string r = try let b = Buffer.create 16 in let rec aux = function - | GApp (_,GRef (_,k),[a;s]) when eq_gr k (force glob_String) -> + | GApp (_,GRef (_,k,_),[a;s]) when eq_gr k (force glob_String) -> (match uninterp_ascii a with | Some c -> Buffer.add_char b (Char.chr c); aux s | _ -> raise Non_closed_string) - | GRef (_,z) when eq_gr z (force glob_EmptyString) -> + | GRef (_,z,_) when eq_gr z (force glob_EmptyString) -> Some (Buffer.contents b) | _ -> raise Non_closed_string @@ -57,6 +57,6 @@ let _ = Notation.declare_string_interpreter "string_scope" (string_path,["Coq";"Strings";"String"]) interp_string - ([GRef (Loc.ghost,static_glob_String); - GRef (Loc.ghost,static_glob_EmptyString)], + ([GRef (Loc.ghost,static_glob_String,None); + GRef (Loc.ghost,static_glob_EmptyString,None)], uninterp_string, true) diff --git a/plugins/syntax/z_syntax.ml b/plugins/syntax/z_syntax.ml index 67e54c017..5131a5f38 100644 --- a/plugins/syntax/z_syntax.ml +++ b/plugins/syntax/z_syntax.ml @@ -41,9 +41,9 @@ let glob_xO = ConstructRef path_of_xO let glob_xH = ConstructRef path_of_xH let pos_of_bignat dloc x = - let ref_xI = GRef (dloc, glob_xI) in - let ref_xH = GRef (dloc, glob_xH) in - let ref_xO = GRef (dloc, glob_xO) in + let ref_xI = GRef (dloc, glob_xI, None) in + let ref_xH = GRef (dloc, glob_xH, None) in + let ref_xO = GRef (dloc, glob_xO, None) in let rec pos_of x = match div2_with_rest x with | (q,false) -> GApp (dloc, ref_xO,[pos_of q]) @@ -65,9 +65,9 @@ let interp_positive dloc n = (**********************************************************************) let rec bignat_of_pos = function - | GApp (_, GRef (_,b),[a]) when Globnames.eq_gr b glob_xO -> mult_2(bignat_of_pos a) - | GApp (_, GRef (_,b),[a]) when Globnames.eq_gr b glob_xI -> add_1(mult_2(bignat_of_pos a)) - | GRef (_, a) when Globnames.eq_gr a glob_xH -> Bigint.one + | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_xO -> mult_2(bignat_of_pos a) + | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_xI -> add_1(mult_2(bignat_of_pos a)) + | GRef (_, a, _) when Globnames.eq_gr a glob_xH -> Bigint.one | _ -> raise Non_closed_number let uninterp_positive p = @@ -83,9 +83,9 @@ let uninterp_positive p = let _ = Notation.declare_numeral_interpreter "positive_scope" (positive_path,binnums) interp_positive - ([GRef (Loc.ghost, glob_xI); - GRef (Loc.ghost, glob_xO); - GRef (Loc.ghost, glob_xH)], + ([GRef (Loc.ghost, glob_xI, None); + GRef (Loc.ghost, glob_xO, None); + GRef (Loc.ghost, glob_xH, None)], uninterp_positive, true) @@ -104,9 +104,9 @@ let n_path = make_path binnums "N" let n_of_binnat dloc pos_or_neg n = if not (Bigint.equal n zero) then - GApp(dloc, GRef (dloc,glob_Npos), [pos_of_bignat dloc n]) + GApp(dloc, GRef (dloc,glob_Npos,None), [pos_of_bignat dloc n]) else - GRef (dloc, glob_N0) + GRef (dloc, glob_N0, None) let error_negative dloc = user_err_loc (dloc, "interp_N", str "No negative numbers in type \"N\".") @@ -120,8 +120,8 @@ let n_of_int dloc n = (**********************************************************************) let bignat_of_n = function - | GApp (_, GRef (_,b),[a]) when Globnames.eq_gr b glob_Npos -> bignat_of_pos a - | GRef (_, a) when Globnames.eq_gr a glob_N0 -> Bigint.zero + | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_Npos -> bignat_of_pos a + | GRef (_, a,_) when Globnames.eq_gr a glob_N0 -> Bigint.zero | _ -> raise Non_closed_number let uninterp_n p = @@ -134,8 +134,8 @@ let uninterp_n p = let _ = Notation.declare_numeral_interpreter "N_scope" (n_path,binnums) n_of_int - ([GRef (Loc.ghost, glob_N0); - GRef (Loc.ghost, glob_Npos)], + ([GRef (Loc.ghost, glob_N0, None); + GRef (Loc.ghost, glob_Npos, None)], uninterp_n, true) @@ -157,18 +157,18 @@ let z_of_int dloc n = if not (Bigint.equal n zero) then let sgn, n = if is_pos_or_zero n then glob_POS, n else glob_NEG, Bigint.neg n in - GApp(dloc, GRef (dloc,sgn), [pos_of_bignat dloc n]) + GApp(dloc, GRef (dloc,sgn,None), [pos_of_bignat dloc n]) else - GRef (dloc, glob_ZERO) + GRef (dloc, glob_ZERO, None) (**********************************************************************) (* Printing Z via scopes *) (**********************************************************************) let bigint_of_z = function - | GApp (_, GRef (_,b),[a]) when Globnames.eq_gr b glob_POS -> bignat_of_pos a - | GApp (_, GRef (_,b),[a]) when Globnames.eq_gr b glob_NEG -> Bigint.neg (bignat_of_pos a) - | GRef (_, a) when Globnames.eq_gr a glob_ZERO -> Bigint.zero + | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_POS -> bignat_of_pos a + | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_NEG -> Bigint.neg (bignat_of_pos a) + | GRef (_, a, _) when Globnames.eq_gr a glob_ZERO -> Bigint.zero | _ -> raise Non_closed_number let uninterp_z p = @@ -182,8 +182,8 @@ let uninterp_z p = let _ = Notation.declare_numeral_interpreter "Z_scope" (z_path,binnums) z_of_int - ([GRef (Loc.ghost, glob_ZERO); - GRef (Loc.ghost, glob_POS); - GRef (Loc.ghost, glob_NEG)], + ([GRef (Loc.ghost, glob_ZERO, None, None); + GRef (Loc.ghost, glob_POS, None, None); + GRef (Loc.ghost, glob_NEG, None, None)], uninterp_z, true) diff --git a/plugins/xml/cic2acic.ml b/plugins/xml/cic2acic.ml index bf46065d0..bbaef1e70 100644 --- a/plugins/xml/cic2acic.ml +++ b/plugins/xml/cic2acic.ml @@ -190,6 +190,7 @@ module CPropRetyping = let typeur sigma metamap = let rec type_of env cstr= match Term.kind_of_term cstr with + | T.Proj _ -> assert false | T.Meta n -> (try T.strip_outer_cast (Int.List.assoc n metamap) with Not_found -> Errors.anomaly ~label:"type_of" (Pp.str "this is not a well-typed term")) @@ -202,9 +203,7 @@ let typeur sigma metamap = ty with Not_found -> Errors.anomaly ~label:"type_of" (str "variable " ++ Id.print id ++ str " unbound")) - | T.Const c -> - let cb = Environ.lookup_constant c env in - Typeops.type_of_constant_type env (cb.Declarations.const_type) + | T.Const c -> Typeops.type_of_constant_in env c | T.Evar ev -> Evd.existential_type sigma ev | T.Ind ind -> Inductiveops.type_of_inductive env ind | T.Construct cstr -> Inductiveops.type_of_constructor env cstr @@ -355,7 +354,7 @@ Pp.msg_debug (Pp.(++) (Pp.str "BUG: this subterm was not visited during the doub {DoubleTypeInference.synthesized = Reductionops.nf_beta evar_map (CPropRetyping.get_type_of env evar_map - (Termops.refresh_universes tt)) ; + ((* Termops.refresh_universes *) tt)) ; DoubleTypeInference.expected = None} in let innersort = @@ -484,7 +483,8 @@ print_endline "PASSATO" ; flush stdout ; (* Now that we have all the auxiliary functions we *) (* can finally proceed with the main case analysis. *) match Term.kind_of_term tt with - Term.Rel n -> + | Term.Proj _ -> assert false + | Term.Rel n -> let id = match List.nth (Environ.rel_context env) (n - 1) with (Names.Name id,_,_) -> id @@ -670,7 +670,7 @@ print_endline "PASSATO" ; flush stdout ; explicit_substitute_and_eta_expand_if_required h (Array.to_list t) t' compute_result_if_eta_expansion_not_required - | Term.Const kn -> + | Term.Const (kn,u) -> Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ; if is_a_Prop innersort && expected_available then add_inner_type fresh_id'' ; @@ -681,7 +681,7 @@ print_endline "PASSATO" ; flush stdout ; explicit_substitute_and_eta_expand_if_required tt [] (List.map snd subst') compute_result_if_eta_expansion_not_required - | Term.Ind (kn,i) -> + | Term.Ind ((kn,i),u) -> let compute_result_if_eta_expansion_not_required _ _ = Acic.AInd (fresh_id'', subst, (uri_of_kernel_name (Inductive kn)), i) in @@ -689,7 +689,7 @@ print_endline "PASSATO" ; flush stdout ; explicit_substitute_and_eta_expand_if_required tt [] (List.map snd subst') compute_result_if_eta_expansion_not_required - | Term.Construct ((kn,i),j) -> + | Term.Construct (((kn,i),j),u) -> Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ; if is_a_Prop innersort && expected_available then add_inner_type fresh_id'' ; diff --git a/plugins/xml/doubleTypeInference.ml b/plugins/xml/doubleTypeInference.ml index d54308165..c8717e008 100644 --- a/plugins/xml/doubleTypeInference.ml +++ b/plugins/xml/doubleTypeInference.ml @@ -64,7 +64,7 @@ let double_type_of env sigma cstr expectedty subterms_to_types = T.Meta n -> Errors.error "DoubleTypeInference.double_type_of: found a non-instanciated goal" - + | T.Proj _ -> assert false | T.Evar ((n,l) as ev) -> let ty = Unshare.unshare (Evd.existential_type sigma ev) in let jty = execute env sigma ty None in @@ -99,7 +99,7 @@ let double_type_of env sigma cstr expectedty subterms_to_types = Typeops.judge_of_variable env id | T.Const c -> - E.make_judge cstr (Typeops.type_of_constant env c) + E.make_judge cstr (fst (Typeops.type_of_constant env c)) | T.Ind ind -> E.make_judge cstr (Inductiveops.type_of_inductive env ind) @@ -112,15 +112,14 @@ let double_type_of env sigma cstr expectedty subterms_to_types = Reduction.whd_betadeltaiota env (Retyping.get_type_of env sigma c) in let cj = execute env sigma c (Some expectedtype) in let pj = execute env sigma p None in - let (expectedtypes,_,_) = + let (expectedtypes,_) = let indspec = Inductive.find_rectype env cj.Environ.uj_type in Inductive.type_case_branches env indspec pj cj.Environ.uj_val in let lfj = execute_array env sigma lf (Array.map (function x -> Some x) expectedtypes) in - let (j,_) = Typeops.judge_of_case env ci pj cj lfj in - j + Typeops.judge_of_case env ci pj cj lfj | T.Fix ((vn,i as vni),recdef) -> let (_,tys,_ as recdef') = execute_recdef env sigma recdef in @@ -141,10 +140,10 @@ let double_type_of env sigma cstr expectedty subterms_to_types = (*CSC: again once Judicael will introduce his non-bugged algebraic *) (*CSC: universes. *) (try - Typeops.judge_of_type u + (*FIXME*) (Typeops.judge_of_type u) with _ -> (* Successor of a non universe-variable universe anomaly *) Pp.msg_warning (Pp.str "Universe refresh performed!!!"); - Typeops.judge_of_type (Termops.new_univ ()) + (*FIXME*) (Typeops.judge_of_type (Universes.new_univ Names.empty_dirpath)) ) | T.App (f,args) -> @@ -165,7 +164,7 @@ let double_type_of env sigma cstr expectedty subterms_to_types = Array.of_list (aux j.Environ.uj_type (Array.to_list args)) in let jl = execute_array env sigma args expected_args in - let (j,_) = Typeops.judge_of_apply env j jl in + let j = Typeops.judge_of_apply env j jl in j | T.Lambda (name,c1,c2) -> @@ -212,7 +211,7 @@ let double_type_of env sigma cstr expectedty subterms_to_types = let cj = execute env sigma c (Some (Reductionops.nf_beta sigma t)) in let tj = execute env sigma t None in let tj = type_judgment env sigma tj in - let j, _ = Typeops.judge_of_cast env cj k tj in + let j = Typeops.judge_of_cast env cj k tj in j in let synthesized = E.j_type judgement in diff --git a/plugins/xml/xmlcommand.ml b/plugins/xml/xmlcommand.ml index 5f26e2bac..3d655920b 100644 --- a/plugins/xml/xmlcommand.ml +++ b/plugins/xml/xmlcommand.ml @@ -175,16 +175,17 @@ let find_hyps t = | Term.Meta _ | Term.Evar _ | Term.Sort _ -> l + | Term.Proj _ -> ignore(Errors.todo "Proj in find_hyps"); assert false | Term.Cast (te,_, ty) -> aux (aux l te) ty | Term.Prod (_,s,t) -> aux (aux l s) t | Term.Lambda (_,s,t) -> aux (aux l s) t | Term.LetIn (_,s,_,t) -> aux (aux l s) t | Term.App (he,tl) -> Array.fold_left (fun i x -> aux i x) (aux l he) tl - | Term.Const con -> + | Term.Const (con, _) -> let hyps = (Global.lookup_constant con).Declarations.const_hyps in map_and_filter l hyps @ l - | Term.Ind ind - | Term.Construct (ind,_) -> + | Term.Ind (ind,_) + | Term.Construct ((ind,_),_) -> let hyps = (fst (Global.lookup_inductive ind)).Declarations.mind_hyps in map_and_filter l hyps @ l | Term.Case (_,t1,t2,b) -> @@ -243,8 +244,8 @@ let mk_inductive_obj sp mib packs variables nparams hyps finite = let {Declarations.mind_consnames=consnames ; Declarations.mind_typename=typename } = p in - let arity = Inductive.type_of_inductive (Global.env()) (mib,p) in - let lc = Inductiveops.arities_of_constructors (Global.env ()) (sp,!tyno) in + let arity = Inductive.type_of_inductive (Global.env()) ((mib,p),Univ.Instance.empty)(*FIXME*) in + let lc = Inductiveops.arities_of_constructors (Global.env ()) ((sp,!tyno),Univ.Instance.empty)(*FIXME*) in let cons = (Array.fold_right (fun (name,lc) i -> (name,lc)::i) (Array.mapi @@ -379,7 +380,7 @@ let print internal glob_ref kind xml_library_root = let val0 = Declareops.body_of_constant cb in let typ = cb.Declarations.const_type in let hyps = cb.Declarations.const_hyps in - let typ = Typeops.type_of_constant_type (Global.env()) typ in + let typ = (* Typeops.type_of_constant_type (Global.env()) *) typ in Cic2acic.Constant kn,mk_constant_obj id val0 typ variables hyps | Globnames.IndRef (kn,_) -> let mib = Global.lookup_mind kn in diff --git a/pretyping/arguments_renaming.ml b/pretyping/arguments_renaming.ml index 4562c5aa5..be22030ce 100644 --- a/pretyping/arguments_renaming.ml +++ b/pretyping/arguments_renaming.ml @@ -41,12 +41,12 @@ let section_segment_of_reference = function | ConstRef con -> Lib.section_segment_of_constant con | IndRef (kn,_) | ConstructRef ((kn,_),_) -> Lib.section_segment_of_mutual_inductive kn - | _ -> [] + | _ -> [], Univ.UContext.empty let discharge_rename_args = function | _, (ReqGlobal (c, names), _ as req) -> (try - let vars = section_segment_of_reference c in + let vars,_ = section_segment_of_reference c in let c' = pop_global_reference c in let var_names = List.map (fun (id, _,_,_) -> Name id) vars in let names' = List.map (fun l -> var_names @ l) names in @@ -87,22 +87,24 @@ let rename_type ty ref = with Not_found -> ty let rename_type_of_constant env c = - let ty = Typeops.type_of_constant env c in - rename_type ty (ConstRef c) + let ty = Typeops.type_of_constant_in env c in + rename_type ty (ConstRef (fst c)) let rename_type_of_inductive env ind = let ty = Inductiveops.type_of_inductive env ind in - rename_type ty (IndRef ind) + rename_type ty (IndRef (fst ind)) let rename_type_of_constructor env cstruct = let ty = Inductiveops.type_of_constructor env cstruct in - rename_type ty (ConstructRef cstruct) + rename_type ty (ConstructRef (fst cstruct)) let rename_typing env c = - let j = Typeops.typing env c in - match kind_of_term c with - | Const c -> { j with uj_type = rename_type j.uj_type (ConstRef c) } - | Ind i -> { j with uj_type = rename_type j.uj_type (IndRef i) } - | Construct k -> { j with uj_type = rename_type j.uj_type (ConstructRef k) } - | _ -> j + let j = Typeops.infer env c in + let j' = + match kind_of_term c with + | Const (c,u) -> { j with uj_type = rename_type j.uj_type (ConstRef c) } + | Ind (i,u) -> { j with uj_type = rename_type j.uj_type (IndRef i) } + | Construct (k,u) -> { j with uj_type = rename_type j.uj_type (ConstructRef k) } + | _ -> j + in j' diff --git a/pretyping/arguments_renaming.mli b/pretyping/arguments_renaming.mli index 09b8859e6..6c37f8938 100644 --- a/pretyping/arguments_renaming.mli +++ b/pretyping/arguments_renaming.mli @@ -16,7 +16,7 @@ val rename_arguments : bool -> global_reference -> Name.t list list -> unit (** [Not_found] is raised is no names are defined for [r] *) val arguments_names : global_reference -> Name.t list list -val rename_type_of_constant : env -> constant -> types -val rename_type_of_inductive : env -> inductive -> types -val rename_type_of_constructor : env -> constructor -> types +val rename_type_of_constant : env -> pconstant -> types +val rename_type_of_inductive : env -> pinductive -> types +val rename_type_of_constructor : env -> pconstructor -> types val rename_typing : env -> constr -> unsafe_judgment diff --git a/pretyping/cases.ml b/pretyping/cases.ml index d71499eda..1db3fac52 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -264,7 +264,8 @@ let rec find_row_ind = function | PatCstr(loc,c,_,_) :: _ -> Some (loc,c) let inductive_template evdref env tmloc ind = - let arsign = get_full_arity_sign env ind in + let indu = evd_comb1 (Evd.fresh_inductive_instance env) evdref ind in + let arsign = get_full_arity_sign env indu in let hole_source = match tmloc with | Some loc -> fun i -> (loc, Evar_kinds.TomatchTypeParameter (ind,i)) | None -> fun _ -> (Loc.ghost, Evar_kinds.InternalHole) in @@ -279,7 +280,7 @@ let inductive_template evdref env tmloc ind = | Some b -> (substl subst b::subst,evarl,n+1)) arsign ([],[],1) in - applist (mkInd ind,List.rev evarl) + applist (mkIndU indu,List.rev evarl) let try_find_ind env sigma typ realnames = let (IndType(_,realargs) as ind) = find_rectype env sigma typ in @@ -349,7 +350,7 @@ let coerce_to_indtype typing_fun evdref env matx tomatchl = (* Utils *) let mkExistential env ?(src=(Loc.ghost,Evar_kinds.InternalHole)) evdref = - e_new_evar evdref env ~src:src (new_Type ()) + let e, u = e_new_type_evar evdref univ_flexible_alg env ~src:src in e let evd_comb2 f evdref x y = let (evd',y) = f !evdref x y in @@ -928,13 +929,19 @@ let expand_arg tms (p,ccl) ((_,t),_,na) = let k = length_of_tomatch_type_sign na t in (p+k,liftn_predicate (k-1) (p+1) ccl tms) + +let use_unit_judge evd = + let j, ctx = coq_unit_judge () in + let evd' = Evd.merge_context_set Evd.univ_flexible_alg evd ctx in + evd', j + let adjust_impossible_cases pb pred tomatch submat = match submat with | [] -> begin match kind_of_term (whd_evar !(pb.evdref) pred) with | Evar (evk,_) when snd (evar_source evk !(pb.evdref)) == Evar_kinds.ImpossibleCase -> - let default = (coq_unit_judge ()).uj_type in - pb.evdref := Evd.define evk default !(pb.evdref); + let evd, default = use_unit_judge !(pb.evdref) in + pb.evdref := Evd.define evk default.uj_type evd; (* we add an "assert false" case *) let pats = List.map (fun _ -> PatVar (Loc.ghost,Anonymous)) tomatch in let aliasnames = @@ -1159,7 +1166,7 @@ let build_leaf pb = let build_branch initial current realargs deps (realnames,curname) pb arsign eqns const_info = (* We remember that we descend through constructor C *) let history = - push_history_pattern const_info.cs_nargs const_info.cs_cstr pb.history in + push_history_pattern const_info.cs_nargs (fst const_info.cs_cstr) pb.history in (* We prepare the matching on x1:T1 .. xn:Tn using some heuristic to *) (* build the name x1..xn from the names present in the equations *) @@ -1236,7 +1243,7 @@ let build_branch initial current realargs deps (realnames,curname) pb arsign eqn let cur_alias = lift const_info.cs_nargs current in let ind = appvect ( - applist (mkInd (inductive_of_constructor const_info.cs_cstr), + applist (mkIndU (inductive_of_constructor (fst const_info.cs_cstr), snd const_info.cs_cstr), List.map (lift const_info.cs_nargs) const_info.cs_params), const_info.cs_concl_realargs) in Alias (initial,(aliasname,cur_alias,(ci,ind))) in @@ -1293,7 +1300,7 @@ and match_current pb (initial,tomatch) = let mind,_ = dest_ind_family indf in let cstrs = get_constructors pb.env indf in let arsign, _ = get_arity pb.env indf in - let eqns,onlydflt = group_equations pb mind current cstrs pb.mat in + let eqns,onlydflt = group_equations pb (fst mind) current cstrs pb.mat in let no_cstr = Int.equal (Array.length cstrs) 0 in if (not no_cstr || not (List.is_empty pb.mat)) && onlydflt then compile_all_variables initial tomatch pb @@ -1313,7 +1320,7 @@ and match_current pb (initial,tomatch) = let (pred,typ) = find_predicate pb.caseloc pb.env pb.evdref pred current indt (names,dep) tomatch in - let ci = make_case_info pb.env mind pb.casestyle in + let ci = make_case_info pb.env (fst mind) pb.casestyle in let pred = nf_betaiota !(pb.evdref) pred in let case = mkCase (ci,pred,current,brvals) in Typing.check_allowed_sort pb.env !(pb.evdref) mind current pred; @@ -1594,10 +1601,9 @@ let build_tycon loc env tycon_env subst tycon extenv evdref t = we are in an impossible branch *) let n = rel_context_length (rel_context env) in let n' = rel_context_length (rel_context tycon_env) in - let tt = new_Type () in - let impossible_case_type = - e_new_evar evdref env ~src:(loc,Evar_kinds.ImpossibleCase) tt in - (lift (n'-n) impossible_case_type, tt) + let impossible_case_type, u = + e_new_type_evar evdref univ_flexible_alg env ~src:(loc,Evar_kinds.ImpossibleCase) in + (lift (n'-n) impossible_case_type, mkSort u) | Some t -> let t = abstract_tycon loc tycon_env evdref subst tycon extenv t in let evd,tt = Typing.e_type_of extenv !evdref t in @@ -1621,9 +1627,9 @@ let build_inversion_problem loc env sigma tms t = PatVar (Loc.ghost,Name id), ((id,t)::subst, id::avoid) in let rec reveal_pattern t (subst,avoid as acc) = match kind_of_term (whd_betadeltaiota env sigma t) with - | Construct cstr -> PatCstr (Loc.ghost,cstr,[],Anonymous), acc + | Construct (cstr,u) -> PatCstr (Loc.ghost,cstr,[],Anonymous), acc | App (f,v) when isConstruct f -> - let cstr = destConstruct f in + let cstr,u = destConstruct f in let n = constructor_nrealargs env cstr in let l = List.lastn n (Array.to_list v) in let l,acc = List.fold_map' reveal_pattern l acc in @@ -1707,11 +1713,18 @@ let build_inversion_problem loc env sigma tms t = it = None } } in (* [pb] is the auxiliary pattern-matching serving as skeleton for the return type of the original problem Xi *) + (* let sigma, s = Evd.new_sort_variable sigma in *) +(*FIXME TRY *) + (* let sigma, s = Evd.new_sort_variable univ_flexible sigma in *) + let s' = Retyping.get_sort_of env sigma t in + let sigma, s = Evd.new_sort_variable univ_flexible_alg sigma in + let sigma = Evd.set_leq_sort sigma s' s in let evdref = ref sigma in + (* let ty = evd_comb1 (refresh_universes false) evdref ty in *) let pb = { env = pb_env; evdref = evdref; - pred = new_Type(); + pred = (*ty *) mkSort s; tomatch = sub_tms; history = start_history n; mat = [eqn1;eqn2]; @@ -1744,7 +1757,7 @@ let extract_arity_signature ?(dolift=true) env0 tomatchl tmsign = str"Unexpected type annotation for a term of non inductive type.")) | IsInd (term,IndType(indf,realargs),_) -> let indf' = if dolift then lift_inductive_family n indf else indf in - let (ind,_) = dest_ind_family indf' in + let ((ind,u),_) = dest_ind_family indf' in let nparams_ctxt,nrealargs_ctxt = inductive_nargs_env env0 ind in let arsign = fst (get_arity env0 indf') in let realnal = @@ -1848,7 +1861,11 @@ let prepare_predicate loc typing_fun sigma env tomatchs arsign tycon pred = (* we use two strategies *) let sigma,t = match tycon with | Some t -> sigma,t - | None -> new_type_evar sigma env ~src:(loc, Evar_kinds.CasesType) in + | None -> + let sigma, (t, _) = + new_type_evar univ_flexible_alg sigma env ~src:(loc, Evar_kinds.CasesType) in + sigma, t + in (* First strategy: we build an "inversion" predicate *) let sigma1,pred1 = build_inversion_problem loc env sigma tomatchs t in (* Second strategy: we directly use the evar as a non dependent pred *) @@ -1858,7 +1875,7 @@ let prepare_predicate loc typing_fun sigma env tomatchs arsign tycon pred = | Some rtntyp, _ -> (* We extract the signature of the arity *) let envar = List.fold_right push_rel_context arsign env in - let sigma, newt = new_sort_variable sigma in + let sigma, newt = new_sort_variable univ_flexible_alg sigma in let evdref = ref sigma in let predcclj = typing_fun (mk_tycon (mkSort newt)) envar evdref rtntyp in let sigma = !evdref in @@ -1933,7 +1950,7 @@ let constr_of_pat env evdref arsign pat avoid = with Not_found -> error_case_not_inductive env {uj_val = ty; uj_type = Typing.type_of env !evdref ty} in - let ind, params = dest_ind_family indf in + let (ind,u), params = dest_ind_family indf in if not (eq_ind ind cind) then error_bad_constructor_loc l cstr ind; let cstrs = get_constructors env indf in let ci = cstrs.(i-1) in @@ -1954,7 +1971,7 @@ let constr_of_pat env evdref arsign pat avoid = let args = List.rev args in let patargs = List.rev patargs in let pat' = PatCstr (l, cstr, patargs, alias) in - let cstr = mkConstruct ci.cs_cstr in + let cstr = mkConstructU ci.cs_cstr in let app = applistc cstr (List.map (lift (List.length sign)) params) in let app = applistc app args in let apptype = Retyping.get_type_of env ( !evdref) app in @@ -2010,7 +2027,7 @@ let vars_of_ctx ctx = | Some t' when is_topvar t' -> prev, (GApp (Loc.ghost, - (GRef (Loc.ghost, delayed_force coq_eq_refl_ref)), + (GRef (Loc.ghost, delayed_force coq_eq_refl_ref, None)), [hole; GVar (Loc.ghost, prev)])) :: vars | _ -> match na with @@ -2282,7 +2299,7 @@ let compile_program_cases loc style (typing_function, evdref) tycon env (predopt, tomatchl, eqns) = let typing_fun tycon env = function | Some t -> typing_function tycon env evdref t - | None -> coq_unit_judge () in + | None -> Evarutil.evd_comb0 use_unit_judge evdref in (* We build the matrix of patterns and right-hand side *) let matx = matx_of_eqns env eqns in @@ -2361,7 +2378,7 @@ let compile_program_cases loc style (typing_function, evdref) tycon env let typing_function tycon env evdref = function | Some t -> typing_function tycon env evdref t - | None -> coq_unit_judge () in + | None -> evd_comb0 use_unit_judge evdref in let pb = { env = env; @@ -2435,7 +2452,7 @@ let compile_cases loc style (typing_fun, evdref) tycon env (predopt, tomatchl, e (* A typing function that provides with a canonical term for absurd cases*) let typing_fun tycon env evdref = function | Some t -> typing_fun tycon env evdref t - | None -> coq_unit_judge () in + | None -> evd_comb0 use_unit_judge evdref in let myevdref = ref sigma in diff --git a/pretyping/cbv.ml b/pretyping/cbv.ml index 1334fb285..4c1e3c3af 100644 --- a/pretyping/cbv.ml +++ b/pretyping/cbv.ml @@ -45,7 +45,7 @@ type cbv_value = | LAM of int * (Name.t * constr) list * constr * cbv_value subs | FIXP of fixpoint * cbv_value subs * cbv_value array | COFIXP of cofixpoint * cbv_value subs * cbv_value array - | CONSTR of constructor * cbv_value array + | CONSTR of constructor puniverses * cbv_value array (* type of terms with a hole. This hole can appear only under App or Case. * TOP means the term is considered without context @@ -67,6 +67,7 @@ and cbv_stack = | TOP | APP of cbv_value array * cbv_stack | CASE of constr * constr array * case_info * cbv_value subs * cbv_stack + | PROJ of projection * Declarations.projection_body * cbv_stack (* les vars pourraient etre des constr, cela permet de retarder les lift: utile ?? *) @@ -107,7 +108,7 @@ let contract_cofixp env (i,(_,_,bds as bodies)) = let make_constr_ref n = function | RelKey p -> mkRel (n+p) | VarKey id -> mkVar id - | ConstKey cst -> mkConst cst + | ConstKey cst -> mkConstU cst (* Adds an application list. Collapse APPs! *) let stack_app appl stack = @@ -121,6 +122,7 @@ let rec stack_concat stk1 stk2 = TOP -> stk2 | APP(v,stk1') -> APP(v,stack_concat stk1' stk2) | CASE(c,b,i,s,stk1') -> CASE(c,b,i,s,stack_concat stk1' stk2) + | PROJ (p,pinfo,stk1') -> PROJ (p,pinfo,stack_concat stk1' stk2) (* merge stacks when there is no shifts in between *) let mkSTACK = function @@ -136,7 +138,7 @@ open RedFlags let red_set_ref flags = function | RelKey _ -> red_set flags fDELTA | VarKey id -> red_set flags (fVAR id) - | ConstKey sp -> red_set flags (fCONST sp) + | ConstKey (sp,_) -> red_set flags (fCONST sp) (* Transfer application lists from a value to the stack * useful because fixpoints may be totally applied in several times. @@ -193,6 +195,10 @@ let rec norm_head info env t stack = norm_head info env head (stack_app nargs stack) | Case (ci,p,c,v) -> norm_head info env c (CASE(p,v,ci,env,stack)) | Cast (ct,_,_) -> norm_head info env ct stack + + | Proj (p, c) -> + let pinfo = Option.get ((Environ.lookup_constant p (info_env info)).Declarations.const_proj) in + norm_head info env c (PROJ (p, pinfo, stack)) (* constants, axioms * the first pattern is CRUCIAL, n=0 happens very often: @@ -221,7 +227,7 @@ let rec norm_head info env t stack = (CBN(t,env), stack) (* Considérer une coupure commutative ? *) | Evar ev -> - (match evar_value info ev with + (match evar_value info.i_cache ev with Some c -> norm_head info env c stack | None -> (VAL(0, t), stack)) @@ -279,14 +285,14 @@ and cbv_stack_term info stack env t = cbv_stack_term info stk envf redfix (* constructor in a Case -> IOTA *) - | (CONSTR((sp,n),[||]), APP(args,CASE(_,br,ci,env,stk))) + | (CONSTR(((sp,n),u),[||]), APP(args,CASE(_,br,ci,env,stk))) when red_set (info_flags info) fIOTA -> let cargs = Array.sub args ci.ci_npar (Array.length args - ci.ci_npar) in cbv_stack_term info (stack_app cargs stk) env br.(n-1) (* constructor of arity 0 in a Case -> IOTA *) - | (CONSTR((_,n),[||]), CASE(_,br,_,env,stk)) + | (CONSTR(((_,n),u),[||]), CASE(_,br,_,env,stk)) when red_set (info_flags info) fIOTA -> cbv_stack_term info stk env br.(n-1) @@ -312,6 +318,8 @@ let rec apply_stack info t = function (mkCase (ci, cbv_norm_term info env ty, t, Array.map (cbv_norm_term info env) br)) st + | PROJ (p, pinfo, st) -> + apply_stack info (mkProj (p, t)) st (* performs the reduction on a constr, and returns a constr *) and cbv_norm_term info env t = @@ -348,7 +356,7 @@ and cbv_norm_value info = function (* reduction under binders *) (subs_liftn (Array.length lty) env)) bds)), Array.map (cbv_norm_value info) args) | CONSTR (c,args) -> - mkApp(mkConstruct c, Array.map (cbv_norm_value info) args) + mkApp(mkConstructU c, Array.map (cbv_norm_value info) args) (* with profiling *) let cbv_norm infos constr = diff --git a/pretyping/cbv.mli b/pretyping/cbv.mli index 66aef4d14..adb2ed15d 100644 --- a/pretyping/cbv.mli +++ b/pretyping/cbv.mli @@ -30,12 +30,13 @@ type cbv_value = | LAM of int * (Name.t * constr) list * constr * cbv_value subs | FIXP of fixpoint * cbv_value subs * cbv_value array | COFIXP of cofixpoint * cbv_value subs * cbv_value array - | CONSTR of constructor * cbv_value array + | CONSTR of constructor puniverses * cbv_value array and cbv_stack = | TOP | APP of cbv_value array * cbv_stack | CASE of constr * constr array * case_info * cbv_value subs * cbv_stack + | PROJ of projection * Declarations.projection_body * cbv_stack val shift_value : int -> cbv_value -> cbv_value diff --git a/pretyping/classops.ml b/pretyping/classops.ml index 886e00e83..86b789f7d 100644 --- a/pretyping/classops.ml +++ b/pretyping/classops.ml @@ -44,7 +44,9 @@ type coe_info_typ = { coe_value : constr; coe_type : types; coe_local : bool; + coe_context : Univ.universe_context_set; coe_is_identity : bool; + coe_is_projection : bool; coe_param : int } let coe_info_typ_equal c1 c2 = @@ -52,6 +54,7 @@ let coe_info_typ_equal c1 c2 = eq_constr c1.coe_type c2.coe_type && c1.coe_local == c2.coe_local && c1.coe_is_identity == c2.coe_is_identity && + c1.coe_is_projection == c2.coe_is_projection && Int.equal c1.coe_param c2.coe_param let cl_typ_ord t1 t2 = match t1, t2 with @@ -184,16 +187,16 @@ let coercion_info coe = CoeTypMap.find coe !coercion_tab let coercion_exists coe = CoeTypMap.mem coe !coercion_tab -(* find_class_type : evar_map -> constr -> cl_typ * constr list *) +(* find_class_type : evar_map -> constr -> cl_typ * universe_list * constr list *) let find_class_type sigma t = let t', args = Reductionops.whd_betaiotazeta_stack sigma t in match kind_of_term t' with - | Var id -> CL_SECVAR id, args - | Const sp -> CL_CONST sp, args - | Ind ind_sp -> CL_IND ind_sp, args - | Prod (_,_,_) -> CL_FUN, [] - | Sort _ -> CL_SORT, [] + | Var id -> CL_SECVAR id, Univ.Instance.empty, args + | Const (sp,u) -> CL_CONST sp, u, args + | Ind (ind_sp,u) -> CL_IND ind_sp, u, args + | Prod (_,_,_) -> CL_FUN, Univ.Instance.empty, [] + | Sort _ -> CL_SORT, Univ.Instance.empty, [] | _ -> raise Not_found @@ -201,38 +204,37 @@ let subst_cl_typ subst ct = match ct with CL_SORT | CL_FUN | CL_SECVAR _ -> ct - | CL_CONST kn -> - let kn',t = subst_con subst kn in - if kn' == kn then ct else - fst (find_class_type Evd.empty t) - | CL_IND (kn,i) -> - let kn' = subst_ind subst kn in - if kn' == kn then ct else - CL_IND (kn',i) + | CL_CONST c -> + let c',t = subst_con_kn subst c in + if c' == c then ct else + pi1 (find_class_type Evd.empty t) + | CL_IND i -> + let i' = subst_ind subst i in + if i' == i then ct else CL_IND i' (*CSC: here we should change the datatype for coercions: it should be possible to declare any term as a coercion *) -let subst_coe_typ subst t = fst (subst_global subst t) +let subst_coe_typ subst t = subst_global_reference subst t (* class_of : Term.constr -> int *) let class_of env sigma t = - let (t, n1, i, args) = + let (t, n1, i, u, args) = try - let (cl,args) = find_class_type sigma t in + let (cl, u, args) = find_class_type sigma t in let (i, { cl_param = n1 } ) = class_info cl in - (t, n1, i, args) + (t, n1, i, u, args) with Not_found -> let t = Tacred.hnf_constr env sigma t in - let (cl, args) = find_class_type sigma t in + let (cl, u, args) = find_class_type sigma t in let (i, { cl_param = n1 } ) = class_info cl in - (t, n1, i, args) + (t, n1, i, u, args) in if Int.equal (List.length args) n1 then t, i else raise Not_found let inductive_class_of ind = fst (class_info (CL_IND ind)) -let class_args_of env sigma c = snd (find_class_type sigma c) +let class_args_of env sigma c = pi3 (find_class_type sigma c) let string_of_class = function | CL_FUN -> "Funclass" @@ -261,14 +263,14 @@ let lookup_path_to_sort_from_class s = let apply_on_class_of env sigma t cont = try - let (cl,args) = find_class_type sigma t in + let (cl,u,args) = find_class_type sigma t in let (i, { cl_param = n1 } ) = class_info cl in if not (Int.equal (List.length args) n1) then raise Not_found; t, cont i with Not_found -> (* Is it worth to be more incremental on the delta steps? *) let t = Tacred.hnf_constr env sigma t in - let (cl, args) = find_class_type sigma t in + let (cl, u, args) = find_class_type sigma t in let (i, { cl_param = n1 } ) = class_info cl in if not (Int.equal (List.length args) n1) then raise Not_found; t, cont i @@ -291,7 +293,7 @@ let get_coercion_constructor coe = Reductionops.whd_betadeltaiota_stack (Global.env()) Evd.empty coe.coe_value in match kind_of_term c with - | Construct cstr -> + | Construct (cstr,u) -> (cstr, Inductiveops.constructor_nrealargs (Global.env()) cstr -1) | _ -> raise Not_found @@ -303,8 +305,12 @@ let lookup_pattern_path_between (s,t) = (* coercion_value : coe_index -> unsafe_judgment * bool *) -let coercion_value { coe_value = c; coe_type = t; coe_is_identity = b } = - (make_judge c t, b) +let coercion_value { coe_value = c; coe_type = t; coe_context = ctx; + coe_is_identity = b; coe_is_projection = b' } = + let subst, ctx = Universes.fresh_universe_context_set_instance ctx in + let c' = Vars.subst_univs_level_constr subst c + and t' = Vars.subst_univs_level_constr subst t in + (make_judge c' t', b, b'), ctx (* pretty-print functions are now in Pretty *) (* rajouter une coercion dans le graphe *) @@ -323,9 +329,15 @@ let message_ambig l = (* add_coercion_in_graph : coe_index * cl_index * cl_index -> unit coercion,source,target *) -let different_class_params i j = - (snd (class_info_from_index i)).cl_param > 0 - +let different_class_params i = + let ci = class_info_from_index i in + if (snd ci).cl_param > 0 then true + else + match fst ci with + | CL_IND i -> Global.is_polymorphic (IndRef i) + | CL_CONST c -> Global.is_polymorphic (ConstRef c) + | _ -> false + let add_coercion_in_graph (ic,source,target) = let old_inheritance_graph = !inheritance_graph in let ambig_paths = @@ -333,12 +345,12 @@ let add_coercion_in_graph (ic,source,target) = let try_add_new_path (i,j as ij) p = try if Bijint.Index.equal i j then begin - if different_class_params i j then begin + if different_class_params i then begin let _ = lookup_path_between_class ij in ambig_paths := (ij,p)::!ambig_paths end end else begin - let _ = lookup_path_between_class (i,j) in + let _ = lookup_path_between_class ij in ambig_paths := (ij,p)::!ambig_paths end; false @@ -374,6 +386,7 @@ type coercion = { coercion_type : coe_typ; coercion_local : bool; coercion_is_id : bool; + coercion_is_proj : bool; coercion_source : cl_typ; coercion_target : cl_typ; coercion_params : int; @@ -382,7 +395,7 @@ type coercion = { (* Calcul de l'arité d'une classe *) let reference_arity_length ref = - let t = Global.type_of_global ref in + let t,_ = Universes.type_of_global ref in List.length (fst (Reductionops.splay_arity (Global.env()) Evd.empty t)) let class_params = function @@ -413,11 +426,15 @@ let cache_coercion (_, c) = let () = add_class c.coercion_target in let is, _ = class_info c.coercion_source in let it, _ = class_info c.coercion_target in + let value, ctx = Universes.fresh_global_instance (Global.env()) c.coercion_type in + let typ = Retyping.get_type_of (Global.env ()) Evd.empty value in let xf = - { coe_value = constr_of_global c.coercion_type; - coe_type = Global.type_of_global c.coercion_type; + { coe_value = value; + coe_type = typ; + coe_context = ctx; coe_local = c.coercion_local; coe_is_identity = c.coercion_is_id; + coe_is_projection = c.coercion_is_proj; coe_param = c.coercion_params } in let () = add_new_coercion c.coercion_type xf in add_coercion_in_graph (xf,is,it) @@ -441,7 +458,6 @@ let subst_coercion (subst, c) = if c.coercion_type == coe && c.coercion_source == cls && c.coercion_target == clt then c else { c with coercion_type = coe; coercion_source = cls; coercion_target = clt } - let discharge_cl = function | CL_CONST kn -> CL_CONST (Lib.discharge_con kn) | CL_IND ind -> CL_IND (Lib.discharge_inductive ind) @@ -453,7 +469,7 @@ let discharge_coercion (_, c) = let n = try let ins = Lib.section_instance c.coercion_type in - Array.length ins + Array.length (snd ins) with Not_found -> 0 in let nc = { c with @@ -477,10 +493,16 @@ let inCoercion : coercion -> obj = discharge_function = discharge_coercion } let declare_coercion coef ?(local = false) ~isid ~src:cls ~target:clt ~params:ps = + let isproj = + match coef with + | ConstRef c -> Environ.is_projection c (Global.env ()) + | _ -> false + in let c = { coercion_type = coef; coercion_local = local; coercion_is_id = isid; + coercion_is_proj = isproj; coercion_source = cls; coercion_target = clt; coercion_params = ps; diff --git a/pretyping/classops.mli b/pretyping/classops.mli index 7bde9e910..3251dc4eb 100644 --- a/pretyping/classops.mli +++ b/pretyping/classops.mli @@ -53,9 +53,9 @@ val class_info : cl_typ -> (cl_index * cl_info_typ) val class_info_from_index : cl_index -> cl_typ * cl_info_typ -(** [find_class_type env sigma c] returns the head reference of [c] and its - arguments *) -val find_class_type : evar_map -> types -> cl_typ * constr list +(** [find_class_type env sigma c] returns the head reference of [c], + its universe instance and its arguments *) +val find_class_type : evar_map -> types -> cl_typ * Univ.universe_instance * constr list (** raises [Not_found] if not convertible to a class *) val class_of : env -> evar_map -> types -> types * cl_index @@ -73,7 +73,7 @@ val declare_coercion : (** {6 Access to coercions infos } *) val coercion_exists : coe_typ -> bool -val coercion_value : coe_index -> (unsafe_judgment * bool) +val coercion_value : coe_index -> (unsafe_judgment * bool * bool) Univ.in_universe_context_set (** {6 Lookup functions for coercion paths } *) diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index 1db4119be..43af6ec62 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -34,19 +34,22 @@ exception NoCoercion exception NoCoercionNoUnifier of evar_map * unification_error (* Here, funj is a coercion therefore already typed in global context *) -let apply_coercion_args env argl funj = +let apply_coercion_args env evd check argl funj = + let evdref = ref evd in let rec apply_rec acc typ = function | [] -> { uj_val = applist (j_val funj,argl); uj_type = typ } | h::restl -> (* On devrait pouvoir s'arranger pour qu'on n'ait pas à faire hnf_constr *) - match kind_of_term (whd_betadeltaiota env Evd.empty typ) with + match kind_of_term (whd_betadeltaiota env evd typ) with | Prod (_,c1,c2) -> - (* Typage garanti par l'appel à app_coercion*) + if check && not (e_cumul env evdref (Retyping.get_type_of env evd h) c1) then + anomaly (Pp.str"apply_coercion_args: mismatch between arguments and coercion"); apply_rec (h::acc) (subst1 h c2) restl | _ -> anomaly (Pp.str "apply_coercion_args") in - apply_rec [] funj.uj_type argl + let res = apply_rec [] funj.uj_type argl in + !evdref, res (* appliquer le chemin de coercions de patterns p *) let apply_pattern_coercion loc pat p = @@ -78,10 +81,10 @@ let disc_subset x = match kind_of_term x with | App (c, l) -> (match kind_of_term c with - Ind i -> + Ind (i,_) -> let len = Array.length l in let sigty = delayed_force sig_typ in - if Int.equal len 2 && eq_ind i (destInd sigty) + if Int.equal len 2 && eq_ind i (fst (Term.destInd sigty)) then let (a, b) = pair_of_array l in Some (a, b) @@ -170,11 +173,11 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr) in match (kind_of_term x, kind_of_term y) with | Sort s, Sort s' -> - (match s, s' with - Prop x, Prop y when x == y -> None - | Prop _, Type _ -> None - | Type x, Type y when Univ.Universe.equal x y -> None (* false *) - | _ -> subco ()) + (match s, s' with + | Prop x, Prop y when x == y -> None + | Prop _, Type _ -> None + | Type x, Type y when Univ.Universe.eq x y -> None (* false *) + | _ -> subco ()) | Prod (name, a, b), Prod (name', a', b') -> let name' = Name (Namegen.next_ident_away (Id.of_string "x") (Termops.ids_of_context env)) in let env' = push_rel (name', None, a') env in @@ -195,15 +198,15 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr) | App (c, l), App (c', l') -> (match kind_of_term c, kind_of_term c' with - Ind i, Ind i' -> (* Inductive types *) + Ind (i, u), Ind (i', u') -> (* Inductive types *) let len = Array.length l in let sigT = delayed_force sigT_typ in let prod = delayed_force prod_typ in (* Sigma types *) if Int.equal len (Array.length l') && Int.equal len 2 && eq_ind i i' - && (eq_ind i (destInd sigT) || eq_ind i (destInd prod)) + && (eq_ind i (fst (Term.destInd sigT)) || eq_ind i (fst (Term.destInd prod))) then - if eq_ind i (destInd sigT) + if eq_ind i (fst (Term.destInd sigT)) then begin let (a, pb), (a', pb') = @@ -323,17 +326,25 @@ let saturate_evd env evd = (* appliquer le chemin de coercions p à hj *) let apply_coercion env sigma p hj typ_cl = try - fst (List.fold_left - (fun (ja,typ_cl) i -> - let fv,isid = coercion_value i in - let argl = (class_args_of env sigma typ_cl)@[ja.uj_val] in - let jres = apply_coercion_args env argl fv in - (if isid then - { uj_val = ja.uj_val; uj_type = jres.uj_type } - else - jres), - jres.uj_type) - (hj,typ_cl) p) + let j,t,evd = + List.fold_left + (fun (ja,typ_cl,sigma) i -> + let ((fv,isid,isproj),ctx) = coercion_value i in + let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx in + let argl = (class_args_of env sigma typ_cl)@[ja.uj_val] in + let sigma, jres = + apply_coercion_args env sigma (not (Univ.ContextSet.is_empty ctx)) argl fv + in + (if isid then + { uj_val = ja.uj_val; uj_type = jres.uj_type } + else if isproj then + { uj_val = mkProj (fst (destConst fv.uj_val), ja.uj_val); + uj_type = jres.uj_type } + else + jres), + jres.uj_type,sigma) + (hj,typ_cl,sigma) p + in evd, j with e when Errors.noncritical e -> anomaly (Pp.str "apply_coercion") let inh_app_fun env evd j = @@ -346,7 +357,7 @@ let inh_app_fun env evd j = | _ -> try let t,p = lookup_path_to_fun_from env evd j.uj_type in - (evd,apply_coercion env evd p j t) + apply_coercion env evd p j t with Not_found when Flags.is_program_mode () -> try let evdref = ref evd in @@ -367,7 +378,7 @@ let inh_app_fun resolve_tc env evd j = let inh_tosort_force loc env evd j = try let t,p = lookup_path_to_sort_from env evd j.uj_type in - let j1 = apply_coercion env evd p j t in + let evd,j1 = apply_coercion env evd p j t in let j2 = on_judgment_type (whd_evar evd) j1 in (evd,type_judgment env j2) with Not_found -> @@ -405,16 +416,16 @@ let inh_coerce_to_fail env evd rigidonly v t c1 = then raise NoCoercion else - let v', t' = + let evd, v', t' = try let t2,t1,p = lookup_path_between env evd (t,c1) in match v with Some v -> - let j = + let evd,j = apply_coercion env evd p {uj_val = v; uj_type = t} t2 in - Some j.uj_val, j.uj_type - | None -> None, t + evd, Some j.uj_val, j.uj_type + | None -> evd, None, t with Not_found -> raise NoCoercion in try (the_conv_x_leq env t' c1 evd, v') @@ -466,11 +477,20 @@ let inh_conv_coerce_to_gen resolve_tc rigidonly loc env evd cj t = | NoSubtacCoercion when not resolve_tc -> error_actual_type_loc loc env best_failed_evd cj t e | NoSubtacCoercion -> - let evd = saturate_evd env evd in + let evd' = saturate_evd env evd in try - inh_conv_coerce_to_fail loc env evd rigidonly (Some cj.uj_val) cj.uj_type t + if evd' == evd then + error_actual_type_loc loc env best_failed_evd cj t e + else + inh_conv_coerce_to_fail loc env evd' rigidonly (Some cj.uj_val) cj.uj_type t with NoCoercionNoUnifier (best_failed_evd,e) -> error_actual_type_loc loc env best_failed_evd cj t e + + (* let evd = saturate_evd env evd in *) + (* try *) + (* inh_conv_coerce_to_fail loc env evd rigidonly (Some cj.uj_val) cj.uj_type t *) + (* with NoCoercionNoUnifier (best_failed_evd,e) -> *) + (* error_actual_type_loc loc env best_failed_evd cj t e *) in let val' = match val' with Some v -> v | None -> assert(false) in (evd',{ uj_val = val'; uj_type = t }) diff --git a/pretyping/constrMatching.ml b/pretyping/constrMatching.ml index 45b097c00..243b563d3 100644 --- a/pretyping/constrMatching.ml +++ b/pretyping/constrMatching.ml @@ -63,7 +63,7 @@ let warn_bound_again name = let constrain n (ids, m as x) (names, terms as subst) = try let (ids', m') = Id.Map.find n terms in - if List.equal Id.equal ids ids' && eq_constr m m' then subst + if List.equal Id.equal ids ids' && eq_constr_nounivs m m' then subst else raise PatternMatchingFailure with Not_found -> let () = if Id.Map.mem n names then warn_bound_meta n in @@ -139,9 +139,18 @@ let merge_binding allow_bound_rels stk n cT subst = constrain n c subst let matches_core convert allow_partial_app allow_bound_rels pat c = - let conv = match convert with - | None -> eq_constr - | Some (env,sigma) -> is_conv env sigma in + let convref ref c = + match ref, kind_of_term c with + | VarRef id, Var id' -> Names.id_eq id id' + | ConstRef c, Const (c',_) -> Names.eq_constant c c' + | IndRef i, Ind (i', _) -> Names.eq_ind i i' + | ConstructRef c, Construct (c',u) -> Names.eq_constructor c c' + | _, _ -> (match convert with + | None -> false + | Some (env,sigma) -> + let sigma,c' = Evd.fresh_global env sigma ref in + is_conv env sigma c' c) + in let rec sorec stk subst p t = let cT = strip_outer_cast t in match p,kind_of_term cT with @@ -165,7 +174,7 @@ let matches_core convert allow_partial_app allow_bound_rels pat c = | PVar v1, Var v2 when Id.equal v1 v2 -> subst - | PRef ref, _ when conv (constr_of_global ref) cT -> subst + | PRef ref, _ when convref ref cT -> subst | PRel n1, Rel n2 when Int.equal n1 n2 -> subst @@ -193,8 +202,17 @@ let matches_core convert allow_partial_app allow_bound_rels pat c = else raise PatternMatchingFailure | PApp (c1,arg1), App (c2,arg2) -> - (try Array.fold_left2 (sorec stk) (sorec stk subst c1 c2) arg1 arg2 - with Invalid_argument _ -> raise PatternMatchingFailure) + (match c1, kind_of_term c2 with + | PRef (ConstRef r), Proj _ -> + (let subst = (sorec stk subst (PProj (r,arg1.(0))) c2) in + try Array.fold_left2 (sorec stk) subst (Array.tl arg1) arg2 + with Invalid_argument _ -> raise PatternMatchingFailure) + | _ -> + (try Array.fold_left2 (sorec stk) (sorec stk subst c1 c2) arg1 arg2 + with Invalid_argument _ -> raise PatternMatchingFailure)) + + | PProj (p1,c1), Proj (p2,c2) when eq_constant p1 p2 -> + sorec stk subst c1 c2 | PProd (na1,c1,d1), Prod(na2,c2,d2) -> sorec ((na1,na2,c2)::stk) @@ -367,6 +385,10 @@ let sub_match ?(partial_app=false) ?(closed=true) pat c = let next () = try_aux ((Array.to_list types)@(Array.to_list bodies)) next_mk_ctx next in authorized_occ partial_app closed pat c mk_ctx next + | Proj (p,c') -> + let next_mk_ctx le = mk_ctx (mkProj (p,List.hd le)) in + let next () = try_aux [c'] next_mk_ctx next in + authorized_occ partial_app closed pat c mk_ctx next | Construct _| Ind _|Evar _|Const _ | Rel _|Meta _|Var _|Sort _ -> authorized_occ partial_app closed pat c mk_ctx next diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index 9bc3d68c6..652c5acf9 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -73,10 +73,7 @@ module PrintingInductiveMake = type t = inductive let compare = ind_ord let encode = Test.encode - let subst subst (kn, ints as obj) = - let kn' = subst_ind subst kn in - if kn' == kn then obj else - kn', ints + let subst subst obj = subst_ind subst obj let printer ind = pr_global_env Id.Set.empty (IndRef ind) let key = ["Printing";Test.field] let title = Test.title @@ -373,7 +370,7 @@ let detype_sort = function | Type u -> GType (if !print_universes - then Some (Pp.string_of_ppcmds (Univ.pr_uni u)) + then Some (Pp.string_of_ppcmds (Univ.Universe.pr u)) else None) type binder_kind = BProd | BLambda | BLetIn @@ -384,6 +381,10 @@ type binder_kind = BProd | BLambda | BLetIn let detype_anonymous = ref (fun loc n -> anomaly ~label:"detype" (Pp.str "index to an anonymous variable")) let set_detype_anonymous f = detype_anonymous := f +let option_of_instance l = + if Univ.Instance.is_empty l then None + else Some l + let rec detype (isgoal:bool) avoid env t = match kind_of_term (collapse_appl t) with | Rel n -> @@ -397,7 +398,7 @@ let rec detype (isgoal:bool) avoid env t = (* Meta in constr are not user-parsable and are mapped to Evar *) GEvar (dl, Evar.unsafe_of_int n, None) | Var id -> - (try let _ = Global.lookup_named id in GRef (dl, VarRef id) + (try let _ = Global.lookup_named id in GRef (dl, VarRef id, None) with Not_found -> GVar (dl, id)) | Sort s -> GSort (dl,detype_sort s) | Cast (c1,REVERTcast,c2) when not !Flags.raw_print -> @@ -415,16 +416,26 @@ let rec detype (isgoal:bool) avoid env t = | Lambda (na,ty,c) -> detype_binder isgoal BLambda avoid env na ty c | LetIn (na,b,_,c) -> detype_binder isgoal BLetIn avoid env na b c | App (f,args) -> - GApp (dl,detype isgoal avoid env f, - Array.map_to_list (detype isgoal avoid env) args) - | Const sp -> GRef (dl, ConstRef sp) + let mkapp f' args' = + match f' with + | GApp (dl',f',args'') -> + GApp (dl,f',args''@args') + | _ -> GApp (dl,f',args') + in + mkapp (detype isgoal avoid env f) + (Array.map_to_list (detype isgoal avoid env) args) + (* GApp (dl,detype isgoal avoid env f, *) + (* Array.map_to_list (detype isgoal avoid env) args) *) + | Const (sp,u) -> GRef (dl, ConstRef sp, option_of_instance u) + | Proj (p,c) -> + GProj (dl, p, detype isgoal avoid env c) | Evar (ev,cl) -> GEvar (dl, ev, Some (List.map (detype isgoal avoid env) (Array.to_list cl))) - | Ind ind_sp -> - GRef (dl, IndRef ind_sp) - | Construct cstr_sp -> - GRef (dl, ConstructRef cstr_sp) + | Ind (ind_sp,u) -> + GRef (dl, IndRef ind_sp, option_of_instance u) + | Construct (cstr_sp,u) -> + GRef (dl, ConstructRef cstr_sp, option_of_instance u) | Case (ci,p,c,bl) -> let comp = computable p (ci.ci_pp_info.ind_nargs) in detype_case comp (detype isgoal avoid env) @@ -589,7 +600,7 @@ let rec subst_cases_pattern subst pat = match pat with | PatVar _ -> pat | PatCstr (loc,((kn,i),j),cpl,n) -> - let kn' = subst_ind subst kn + let kn' = subst_mind subst kn and cpl' = List.smartmap (subst_cases_pattern subst) cpl in if kn' == kn && cpl' == cpl then pat else PatCstr (loc,((kn',i),j),cpl',n) @@ -598,7 +609,7 @@ let (f_subst_genarg, subst_genarg_hook) = Hook.make () let rec subst_glob_constr subst raw = match raw with - | GRef (loc,ref) -> + | GRef (loc,ref,u) -> let ref',t = subst_global subst ref in if ref' == ref then raw else detype false [] [] t @@ -613,6 +624,12 @@ let rec subst_glob_constr subst raw = if r' == r && rl' == rl then raw else GApp(loc,r',rl') + | GProj (loc,p,c) -> + let p' = subst_constant subst p in + let c' = subst_glob_constr subst c in + if p' == p && c' == c then raw + else GProj (loc,p',c') + | GLambda (loc,n,bk,r1,r2) -> let r1' = subst_glob_constr subst r1 and r2' = subst_glob_constr subst r2 in if r1' == r1 && r2' == r2 then raw else @@ -635,7 +652,7 @@ let rec subst_glob_constr subst raw = let (n,topt) = x in let topt' = Option.smartmap (fun (loc,(sp,i),y as t) -> - let sp' = subst_ind subst sp in + let sp' = subst_mind subst sp in if sp == sp' then t else (loc,(sp',i),y)) topt in if a == a' && topt == topt' then y else (a',(n,topt'))) rl and branches' = List.smartmap diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index a0542cbb2..594481af3 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -27,41 +27,52 @@ let debug_unification = ref (false) let _ = Goptions.declare_bool_option { Goptions.optsync = true; Goptions.optdepr = false; Goptions.optname = - "Print states sended to Evarconv unification"; + "Print states sent to Evarconv unification"; Goptions.optkey = ["Debug";"Unification"]; Goptions.optread = (fun () -> !debug_unification); Goptions.optwrite = (fun a -> debug_unification:=a); } -let eval_flexible_term ts env c = +let unfold_projection env p c stk = + (match try Some (lookup_projection p env) with Not_found -> None with + | Some pb -> + let s = Stack.Proj (pb.Declarations.proj_npars, pb.Declarations.proj_arg, p) in + Some (c, s :: stk) + | None -> None) + +let eval_flexible_term ts env c stk = match kind_of_term c with - | Const c -> + | Const (c,u as cu) -> if is_transparent_constant ts c - then constant_opt_value env c + then Option.map (fun x -> x, stk) (constant_opt_value_in env cu) else None | Rel n -> - (try let (_,v,_) = lookup_rel n env in Option.map (lift n) v + (try let (_,v,_) = lookup_rel n env in Option.map (fun t -> lift n t, stk) v with Not_found -> None) | Var id -> (try if is_transparent_variable ts id then - let (_,v,_) = lookup_named id env in v + let (_,v,_) = lookup_named id env in Option.map (fun t -> t, stk) v else None with Not_found -> None) - | LetIn (_,b,_,c) -> Some (subst1 b c) - | Lambda _ -> Some c + | LetIn (_,b,_,c) -> Some (subst1 b c, stk) + | Lambda _ -> Some (c, stk) + | Proj (p, c) -> + if is_transparent_constant ts p + then unfold_projection env p c stk + else None | _ -> assert false type flex_kind_of_term = | Rigid - | MaybeFlexible of Constr.t (* reducible but not necessarily reduced *) + | MaybeFlexible of Constr.t * Constr.t Stack.t (* reducible but not necessarily reduced *) | Flexible of existential let flex_kind_of_term ts env c sk = match kind_of_term c with - | LetIn _ | Rel _ | Const _ | Var _ -> - Option.cata (fun x -> MaybeFlexible x) Rigid (eval_flexible_term ts env c) - | Lambda _ when not (Option.is_empty (Stack.decomp sk)) -> MaybeFlexible c + | LetIn _ | Rel _ | Const _ | Var _ | Proj _ -> + Option.cata (fun (x,y) -> MaybeFlexible (x,y)) Rigid (eval_flexible_term ts env c sk) + | Lambda _ when not (Option.is_empty (Stack.decomp sk)) -> MaybeFlexible (c, sk) | Evar ev -> Flexible ev | Lambda _ | Prod _ | Sort _ | Ind _ | Construct _ | CoFix _ -> Rigid | Meta _ -> Rigid @@ -100,36 +111,43 @@ let position_problem l2r = function projection would have been reduced) *) let check_conv_record (t1,sk1) (t2,sk2) = - let proji = global_of_constr t1 in - let canon_s,sk2_effective = - try - match kind_of_term t2 with - Prod (_,a,b) -> (* assert (l2=[]); *) + let (proji, u), arg = Universes.global_app_of_constr t1 in + let canon_s,sk2_effective = + try + match kind_of_term t2 with + Prod (_,a,b) -> (* assert (l2=[]); *) if dependent (mkRel 1) b then raise Not_found else lookup_canonical_conversion (proji, Prod_cs),(Stack.append_app [|a;pop b|] Stack.empty) - | Sort s -> - lookup_canonical_conversion - (proji, Sort_cs (family_of_sort s)),[] - | _ -> - let c2 = global_of_constr t2 in - lookup_canonical_conversion (proji, Const_cs c2),sk2 - with Not_found -> - lookup_canonical_conversion (proji,Default_cs),[] - in - let { o_DEF = c; o_INJ=n; o_TABS = bs; - o_TPARAMS = params; o_NPARAMS = nparams; o_TCOMPS = us } = canon_s in - let params1, c1, extra_args1 = + | Sort s -> + lookup_canonical_conversion + (proji, Sort_cs (family_of_sort s)),[] + | _ -> + let c2 = global_of_constr t2 in + lookup_canonical_conversion (proji, Const_cs c2),sk2 + with Not_found -> + lookup_canonical_conversion (proji,Default_cs),[] + in + let { o_DEF = c; o_CTX = ctx; o_INJ=n; o_TABS = bs; + o_TPARAMS = params; o_NPARAMS = nparams; o_TCOMPS = us } = canon_s in + let params1, c1, extra_args1 = + match arg with + | Some c -> (* A primitive projection applied to c *) + [], c, sk1 + | None -> match Stack.strip_n_app nparams sk1 with | Some (params1, c1,extra_args1) -> params1, c1, extra_args1 | _ -> raise Not_found in - let us2,extra_args2 = - let l_us = List.length us in + let us2,extra_args2 = + let l_us = List.length us in if Int.equal l_us 0 then Stack.empty,sk2_effective else match (Stack.strip_n_app (l_us-1) sk2_effective) with - | None -> raise Not_found - | Some (l',el,s') -> (l'@Stack.append_app [|el|] Stack.empty,s') in - (c,bs,(Stack.append_app_list params Stack.empty,params1),(Stack.append_app_list us Stack.empty,us2),(extra_args1,extra_args2),c1, - (n,Stack.zip(t2,sk2))) + | None -> raise Not_found + | Some (l',el,s') -> (l'@Stack.append_app [|el|] Stack.empty,s') in + let subst, ctx' = Universes.fresh_universe_context_set_instance ctx in + let c' = subst_univs_level_constr subst c in + let bs' = List.map (subst_univs_level_constr subst) bs in + ctx',c',bs',(Stack.append_app_list params Stack.empty,params1),(Stack.append_app_list us Stack.empty,us2),(extra_args1,extra_args2),c1, + (n,Stack.zip(t2,sk2)) (* Precondition: one of the terms of the pb is an uninstantiated evar, * possibly applied to arguments. *) @@ -206,6 +224,9 @@ let ise_stack2 no_app env evd f sk1 sk2 = | Success i'' -> ise_stack2 true i'' q1 q2 | UnifFailure _ as x -> fail x) | UnifFailure _ as x -> fail x) + | Stack.Proj (n1,a1,p1)::q1, Stack.Proj (n2,a2,p2)::q2 -> + if eq_constant p1 p2 then ise_stack2 true i q1 q2 + else fail (UnifFailure (i, NotSameHead)) | Stack.Fix (((li1, i1),(_,tys1,bds1 as recdef1)),a1,_)::q1, Stack.Fix (((li2, i2),(_,tys2,bds2)),a2,_)::q2 -> if Int.equal i1 i2 && Array.equal Int.equal li1 li2 then @@ -259,6 +280,13 @@ let exact_ise_stack2 env evd f sk1 sk2 = ise_stack2 evd (List.rev sk1) (List.rev sk2) else UnifFailure (evd, (* Dummy *) NotSameHead) +let eq_puniverses evd pbty f (x,u) (y,v) = + if f x y then + try + Success (Evd.set_eq_instances evd u v) + with Univ.UniverseInconsistency e -> UnifFailure (evd, UnifUnivInconsistency e) + else UnifFailure (evd, NotSameHead) + let rec evar_conv_x ts env evd pbty term1 term2 = let term1 = whd_head_evar evd term1 in let term2 = whd_head_evar evd term2 in @@ -266,15 +294,19 @@ let rec evar_conv_x ts env evd pbty term1 term2 = could have found, we do it only if the terms are free of evar. Note: incomplete heuristic... *) let ground_test = - if is_ground_term evd term1 && is_ground_term evd term2 then - if is_trans_fconv pbty ts env evd term1 term2 then - Some true - else if is_ground_env evd env then Some false - else None - else None in + if is_ground_term evd term1 && is_ground_term evd term2 then ( + let evd, b = + try infer_conv ~pb:pbty ~ts env evd term1 term2 + with Univ.UniverseInconsistency _ -> evd, false + in + if b then Some (evd, true) + else if is_ground_env evd env then Some (evd, false) + else None) + else None + in match ground_test with - | Some true -> Success evd - | Some false -> UnifFailure (evd,ConversionFailed (env,term1,term2)) + | Some (evd, true) -> Success evd + | Some (evd, false) -> UnifFailure (evd,ConversionFailed (env,term1,term2)) | None -> (* Until pattern-unification is used consistently, use nohdbeta to not destroy beta-redexes that can be used for 1st-order unification *) @@ -392,11 +424,13 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty in ise_try evd [f1; f2] - | Flexible ev1, MaybeFlexible v2 -> flex_maybeflex true ev1 (appr1,csts1) (appr2,csts2) v2 + | Flexible ev1, MaybeFlexible (v2,sk2) -> + flex_maybeflex true ev1 (appr1,csts1) ((term2,sk2),csts2) v2 - | MaybeFlexible v1, Flexible ev2 -> flex_maybeflex false ev2 (appr2,csts2) (appr1,csts1) v1 + | MaybeFlexible (v1,sk1), Flexible ev2 -> + flex_maybeflex false ev2 (appr2,csts2) ((term1,sk1),csts1) v1 - | MaybeFlexible v1, MaybeFlexible v2 -> begin + | MaybeFlexible (v1,sk1), MaybeFlexible (v2,sk2) -> begin match kind_of_term term1, kind_of_term term2 with | LetIn (na,b1,t1,c'1), LetIn (_,b2,_,c'2) -> let f1 i = @@ -414,12 +448,37 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty in ise_try evd [f1; f2] + | Proj (p, c), Proj (p', c') when eq_constant p p' -> + let f1 i = + ise_and i + [(fun i -> evar_conv_x ts env i CONV c c'); + (fun i -> exact_ise_stack2 env i (evar_conv_x ts) sk1 sk2)] + and f2 i = + if is_transparent_constant ts p then + match unfold_projection env p c sk1 with + | Some (c, sk1) -> + let out1 = whd_betaiota_deltazeta_for_iota_state ts env i csts1 (c,sk1) in + evar_eqappr_x ts env i pbty out1 (appr2, csts2) + | None -> assert false + else UnifFailure (i, NotSameHead) + in + ise_try evd [f1; f2] + | _, _ -> - let f1 i = - if eq_constr term1 term2 then - exact_ise_stack2 env i (evar_conv_x ts) sk1 sk2 - else - UnifFailure (i,NotSameHead) + let f1 i = + (* Gather the universe constraints that would make term1 and term2 equal. + If these only involve unifications of flexible universes to other universes, + allow this identification (first-order unification of universes). Otherwise + fallback to unfolding. + *) + let b,univs = eq_constr_universes term1 term2 in + if b then + ise_and i [(fun i -> + try Success (Evd.add_universe_constraints i univs) + with UniversesDiffer -> UnifFailure (i,NotSameHead) + | Univ.UniverseInconsistency p -> UnifFailure (i, UnifUnivInconsistency p)); + (fun i -> exact_ise_stack2 env i (evar_conv_x ts) sk1 sk2)] + else UnifFailure (i,NotSameHead) and f2 i = (try conv_record ts env i (try check_conv_record appr1 appr2 @@ -438,9 +497,11 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty (* false (* immediate solution without Canon Struct *)*) | Lambda _ -> assert (match args with [] -> true | _ -> false); true | LetIn (_,b,_,c) -> is_unnamed - (fst (whd_betaiota_deltazeta_for_iota_state + (fst (whd_betaiota_deltazeta_for_iota_state ts env i Cst_stack.empty (subst1 b c, args))) - | Case _| Fix _| App _| Cast _ -> assert false in + | Fix _ -> true (* Partially applied fix can be the result of a whd call *) + | Proj (p, c) -> true + | Case _ | App _| Cast _ -> assert false in let rhs_is_stuck_and_unnamed () = let applicative_stack = fst (Stack.strip_app sk2) in is_unnamed @@ -475,7 +536,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty | Flexible ev1, Rigid -> flex_rigid true ev1 appr1 appr2 | Rigid, Flexible ev2 -> flex_rigid false ev2 appr2 appr1 - | MaybeFlexible v1, Rigid -> + | MaybeFlexible (v1,sk1), Rigid -> let f3 i = (try conv_record ts env i (check_conv_record appr1 appr2) with Not_found -> UnifFailure (i,NoCanonicalStructure)) @@ -487,14 +548,14 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty in ise_try evd [f3; f4] - | Rigid, MaybeFlexible v2 -> + | Rigid, MaybeFlexible (v2,sk2) -> let f3 i = (try conv_record ts env i (check_conv_record appr2 appr1) with Not_found -> UnifFailure (i,NoCanonicalStructure)) and f4 i = - evar_eqappr_x ts env i pbty (appr1,csts1) - (whd_betaiota_deltazeta_for_iota_state - ts env i (Cst_stack.add_cst term2 csts2) (v2,sk2)) + evar_eqappr_x ts env i pbty (appr1,csts1) + (whd_betaiota_deltazeta_for_iota_state + ts env i (Cst_stack.add_cst term2 csts2) (v2,sk2)) in ise_try evd [f3; f4] @@ -515,8 +576,8 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty then Evd.set_eq_sort evd s1 s2 else Evd.set_leq_sort evd s1 s2 in Success evd' - with Univ.UniverseInconsistency _ -> - UnifFailure (evd,UnifUnivInconsistency) + with Univ.UniverseInconsistency p -> + UnifFailure (evd,UnifUnivInconsistency p) | e when Errors.noncritical e -> UnifFailure (evd,NotSameHead)) | Prod (n,c1,c'1), Prod (_,c2,c'2) when app_empty -> @@ -537,19 +598,19 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty else UnifFailure (evd,NotSameHead) | Const c1, Const c2 -> - if eq_constant c1 c2 then - exact_ise_stack2 env evd (evar_conv_x ts) sk1 sk2 - else UnifFailure (evd,NotSameHead) + ise_and evd + [(fun i -> eq_puniverses i pbty eq_constant c1 c2); + (fun i -> exact_ise_stack2 env i (evar_conv_x ts) sk1 sk2)] | Ind sp1, Ind sp2 -> - if eq_ind sp1 sp2 then - exact_ise_stack2 env evd (evar_conv_x ts) sk1 sk2 - else UnifFailure (evd,NotSameHead) + ise_and evd + [(fun i -> eq_puniverses i pbty eq_ind sp1 sp2); + (fun i -> exact_ise_stack2 env i (evar_conv_x ts) sk1 sk2)] | Construct sp1, Construct sp2 -> - if eq_constructor sp1 sp2 then - exact_ise_stack2 env evd (evar_conv_x ts) sk1 sk2 - else UnifFailure (evd,NotSameHead) + ise_and evd + [(fun i -> eq_puniverses i pbty eq_constructor sp1 sp2); + (fun i -> exact_ise_stack2 env i (evar_conv_x ts) sk1 sk2)] | Fix ((li1, i1),(_,tys1,bds1 as recdef1)), Fix ((li2, i2),(_,tys2,bds2)) -> (* Partially applied fixs *) if Int.equal i1 i2 && Array.equal Int.equal li1 li2 then @@ -583,13 +644,14 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty | _, (Ind _ | Construct _ | Sort _ | Prod _ | CoFix _ | Fix _ | Rel _ | Var _ | Const _) -> UnifFailure (evd,NotSameHead) - | (App _ | Cast _ | Case _), _ -> assert false + | (App _ | Cast _ | Case _ | Proj _), _ -> assert false | (LetIn _| Evar _), _ -> assert false | (Lambda _), _ -> assert false end -and conv_record trs env evd (c,bs,(params,params1),(us,us2),(ts,ts1),c1,(n,t2)) = +and conv_record trs env evd (ctx,c,bs,(params,params1),(us,us2),(ts,ts1),c1,(n,t2)) = + let evd = Evd.merge_context_set Evd.univ_flexible evd ctx in if Reductionops.Stack.compare_shape ts ts1 then let (evd',ks,_) = List.fold_left @@ -614,6 +676,28 @@ and conv_record trs env evd (c,bs,(params,params1),(us,us2),(ts,ts1),c1,(n,t2)) (fun i -> exact_ise_stack2 env i (evar_conv_x trs) ts ts1)] else UnifFailure(evd,(*dummy*)NotSameHead) +and eta_constructor ts env evd ((ind, i), u) l1 csts1 (c, csts2) = + let mib = lookup_mind (fst ind) env in + match mib.Declarations.mind_record with + | Some (exp,projs) when Array.length projs > 0 -> + let pars = mib.Declarations.mind_nparams in + (try + let l1' = Stack.tail pars l1 in + if Environ.is_projection projs.(0) env then + let sk2 = + let term = Stack.zip c in + List.map (fun p -> mkProj (p, term)) (Array.to_list projs) + in + exact_ise_stack2 env evd (evar_conv_x ts) l1' + (Stack.append_app_list sk2 Stack.empty) + else raise (Failure "") + with Failure _ -> UnifFailure(evd,NotSameHead)) + | _ -> UnifFailure (evd,NotSameHead) + +(* Profiling *) +(* let evar_conv_xkey = Profile.declare_profile "evar_conv_x";; *) +(* let evar_conv_x = Profile.profile6 evar_conv_xkey evar_conv_x *) + (* We assume here |l1| <= |l2| *) let first_order_unification ts env evd (ev1,l1) (term2,l2) = @@ -846,7 +930,7 @@ let apply_conversion_problem_heuristic ts env evd pbty t1 t2 = (* Some head evar have been instantiated, or unknown kind of problem *) evar_conv_x ts env evd pbty t1 t2 -let check_problems_are_solved evd = +let check_problems_are_solved env evd = match snd (extract_all_conv_pbs evd) with | (pbty,env,t1,t2)::_ -> Pretype_errors.error_cannot_unify env evd (t1, t2) | _ -> () @@ -890,10 +974,16 @@ let rec solve_unconstrained_evars_with_canditates ts evd = let evd = aux (List.rev l) in solve_unconstrained_evars_with_canditates ts evd -let solve_unconstrained_impossible_cases evd = +let solve_unconstrained_impossible_cases env evd = Evd.fold_undefined (fun evk ev_info evd' -> match ev_info.evar_source with - | _,Evar_kinds.ImpossibleCase -> Evd.define evk (j_type (coq_unit_judge ())) evd' + | _,Evar_kinds.ImpossibleCase -> + let j, ctx = coq_unit_judge () in + let evd' = Evd.merge_context_set Evd.univ_flexible_alg evd' ctx in + let ty = j_type j in + let conv_algo = evar_conv_x full_transparent_state in + let evd' = check_evar_instance evd' evk ty conv_algo in + Evd.define evk ty evd' | _ -> evd') evd evd let consider_remaining_unif_problems env @@ -925,8 +1015,8 @@ let consider_remaining_unif_problems env in let (evd,pbs) = extract_all_conv_pbs evd in let heuristic_solved_evd = aux evd pbs false [] in - check_problems_are_solved heuristic_solved_evd; - solve_unconstrained_impossible_cases heuristic_solved_evd + check_problems_are_solved env heuristic_solved_evd; + solve_unconstrained_impossible_cases env heuristic_solved_evd (* Main entry points *) diff --git a/pretyping/evarconv.mli b/pretyping/evarconv.mli index 3eb01439e..c99929b5e 100644 --- a/pretyping/evarconv.mli +++ b/pretyping/evarconv.mli @@ -38,12 +38,12 @@ val consider_remaining_unif_problems : env -> ?ts:transparent_state -> evar_map (** Check all pending unification problems are solved and raise an error otherwise *) -val check_problems_are_solved : evar_map -> unit +val check_problems_are_solved : env -> evar_map -> unit (** Check if a canonical structure is applicable *) val check_conv_record : constr * types Stack.t -> constr * types Stack.t -> - constr * constr list * (constr Stack.t * constr Stack.t) * + Univ.universe_context_set * constr * constr list * (constr Stack.t * constr Stack.t) * (constr Stack.t * types Stack.t) * (constr Stack.t * types Stack.t) * constr * (int * constr) diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index 4f982114a..b3c65ebaf 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -26,6 +26,24 @@ let normalize_evar evd ev = | Evar (evk,args) -> (evk,args) | _ -> assert false +let refresh_universes dir evd t = + let evdref = ref evd in + let modified = ref false in + let rec refresh t = match kind_of_term t with + | Sort (Type u as s) when Univ.universe_level u = None || + Evd.is_sort_variable evd s = None -> + (modified := true; + (* s' will appear in the term, it can't be algebraic *) + let s' = evd_comb0 (new_sort_variable Evd.univ_flexible) evdref in + evdref := + (if dir then set_leq_sort !evdref s' s else + set_leq_sort !evdref s s'); + mkSort s') + | Prod (na,u,v) -> mkProd (na,u,refresh v) + | _ -> t in + let t' = refresh t in + if !modified then !evdref, t' else evd, t + (************************) (* Unification results *) (************************) @@ -416,8 +434,8 @@ let make_projectable_subst aliases sigma evi args = let a',args = decompose_app_vect a in match kind_of_term a' with | Construct cstr -> - let l = try Constrmap.find cstr cstrs with Not_found -> [] in - Constrmap.add cstr ((args,id)::l) cstrs + let l = try Constrmap.find (fst cstr) cstrs with Not_found -> [] in + Constrmap.add (fst cstr) ((args,id)::l) cstrs | _ -> cstrs in (rest,Id.Map.add id [a,normalize_alias_opt aliases a,id] all,cstrs) | Some c, a::rest -> @@ -450,6 +468,7 @@ let make_projectable_subst aliases sigma evi args = let define_evar_from_virtual_equation define_fun env evd t_in_env sign filter inst_in_env = let ty_t_in_env = Retyping.get_type_of env evd t_in_env in + let evd,ty_t_in_env = refresh_universes false evd ty_t_in_env in let evd,evar_in_env = new_evar_instance sign evd ty_t_in_env ~filter inst_in_env in let t_in_env = whd_evar evd t_in_env in let evd = define_fun env evd None (destEvar evar_in_env) t_in_env in @@ -955,7 +974,7 @@ exception CannotProject of Filter.t option let rec is_constrainable_in k (ev,(fv_rels,fv_ids) as g) t = let f,args = decompose_app_vect t in match kind_of_term f with - | Construct (ind,_) -> + | Construct ((ind,_),u) -> let n = Inductiveops.inductive_nparams ind in if n > Array.length args then true (* We don't try to be more clever *) else @@ -1012,10 +1031,26 @@ let project_evar_on_evar g env evd aliases k2 (evk1,argsv1 as ev1) (evk2,argsv2 else raise (CannotProject filter1) +exception IllTypedInstance of env * types * types + +let check_evar_instance evd evk1 body conv_algo = + let evi = Evd.find evd evk1 in + let evenv = evar_env evi in + (* FIXME: The body might be ill-typed when this is called from w_merge *) + (* This happens in practice, cf MathClasses build failure on 2013-3-15 *) + let ty = + try Retyping.get_type_of ~lax:true evenv evd body + with Retyping.RetypeError _ -> error "Ill-typed evar instance" + in + match conv_algo evenv evd Reduction.CUMUL ty evi.evar_concl with + | Success evd -> evd + | UnifFailure _ -> raise (IllTypedInstance (evenv,ty,evi.evar_concl)) + let solve_evar_evar_l2r f g env evd aliases pbty ev1 (evk2,_ as ev2) = try let evd,body = project_evar_on_evar g env evd aliases 0 ev1 ev2 in - Evd.define evk2 body evd + let evd' = Evd.define evk2 body evd in + check_evar_instance evd' evk2 body g with EvarSolvedOnTheFly (evd,c) -> f env evd pbty ev2 c @@ -1037,27 +1072,39 @@ let solve_evar_evar ?(force=false) f g env evd pbty (evk1,args1 as ev1) (evk2,ar with CannotProject filter2 -> postpone_evar_evar f env evd pbty filter1 ev1 filter2 ev2 +let solve_evar_evar ?(force=false) f g env evd pbty (evk1,args1 as ev1) (evk2,args2 as ev2) = + let evi = Evd.find evd evk1 in + try + (* ?X : ΠΔ. Type i = ?Y : ΠΔ'. Type j. + The body of ?X and ?Y just has to be of type ΠΔ. Type k for some k <= i, j. *) + let evienv = Evd.evar_env evi in + let ctx, i = Reduction.dest_arity evienv evi.evar_concl in + let evi2 = Evd.find evd evk2 in + let evi2env = Evd.evar_env evi2 in + let ctx', j = Reduction.dest_arity evi2env evi2.evar_concl in + if i == j || Evd.check_eq evd (univ_of_sort i) (univ_of_sort j) + then (* Shortcut, i = j *) + solve_evar_evar ~force f g env evd pbty ev1 ev2 + else + let evd, k = Evd.new_sort_variable univ_flexible_alg evd in + let evd, ev3 = + Evarutil.new_pure_evar evd (Evd.evar_hyps evi) + ~src:evi.evar_source ~filter:evi.evar_filter + ?candidates:evi.evar_candidates (it_mkProd_or_LetIn (mkSort k) ctx) + in + let evd = Evd.set_leq_sort (Evd.set_leq_sort evd k i) k j in + solve_evar_evar ~force f g env + (solve_evar_evar ~force f g env evd None (ev3,args1) ev1) + pbty (ev3,args1) ev2 + with Reduction.NotArity -> + solve_evar_evar ~force f g env evd None ev1 ev2 + type conv_fun = env -> evar_map -> conv_pb -> constr -> constr -> unification_result type conv_fun_bool = env -> evar_map -> conv_pb -> constr -> constr -> bool -exception IllTypedInstance of env * types * types - -let check_evar_instance evd evk1 body conv_algo = - let evi = Evd.find evd evk1 in - let evenv = evar_env evi in - (* FIXME: The body might be ill-typed when this is called from w_merge *) - (* This happens in practice, cf MathClasses build failure on 2013-3-15 *) - let ty = - try Retyping.get_type_of ~lax:true evenv evd body - with Retyping.RetypeError _ -> error "Ill-typed evar instance" - in - match conv_algo evenv evd Reduction.CUMUL ty evi.evar_concl with - | Success evd -> evd - | UnifFailure _ -> raise (IllTypedInstance (evenv,ty,evi.evar_concl)) - (* Solve pbs ?e[t1..tn] = ?e[u1..un] which arise often in fixpoint * definitions. We try to unify the ti with the ui pairwise. The pairs * that don't unify are discarded (i.e. ?e is redefined so that it does not @@ -1137,6 +1184,9 @@ exception NotEnoughInformationEvarEvar of constr exception OccurCheckIn of evar_map * constr exception MetaOccurInBodyInternal +let fast_stats = ref 0 +let not_fast_stats = ref 0 + let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = let aliases = make_alias_map env in let evdref = ref evd in @@ -1224,7 +1274,8 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = (* Try to project (a restriction of) the left evar ... *) try let evd,body = project_evar_on_evar conv_algo env' evd aliases 0 ev'' ev' in - Evd.define evk' body evd + let evd = Evd.define evk' body evd in + check_evar_instance evd evk' body conv_algo with | EvarSolvedOnTheFly _ -> assert false (* ev has no candidates *) | CannotProject filter'' -> @@ -1237,7 +1288,7 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = match let c,args = decompose_app_vect t in match kind_of_term c with - | Construct cstr when noccur_between 1 k t -> + | Construct (cstr,u) when noccur_between 1 k t -> (* This is common case when inferring the return clause of match *) (* (currently rudimentary: we do not treat the case of multiple *) (* possible inversions; we do not treat overlap with a possible *) @@ -1268,6 +1319,19 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = map_constr_with_full_binders (fun d (env,k) -> push_rel d env, k+1) imitate envk t in + let _fast rhs = + let filter_ctxt = evar_filtered_context evi in + let names = ref Idset.empty in + let rec is_id_subst ctxt s = + match ctxt, s with + | ((id, _, _) :: ctxt'), (c :: s') -> + names := Idset.add id !names; + isVarId id c && is_id_subst ctxt' s' + | [], [] -> true + | _ -> false in + is_id_subst filter_ctxt (Array.to_list argsv) && + closed0 rhs && + Idset.subset (collect_vars rhs) !names in let rhs = whd_beta evd rhs (* heuristic *) in let fast rhs = let filter_ctxt = evar_filtered_context evi in @@ -1296,7 +1360,7 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = * context "hyps" and not referring to itself. *) -and evar_define conv_algo ?(choose=false) env evd pbty (evk,argsv as ev) rhs = +and evar_define conv_algo ?(choose=false) ?(dir=false) env evd pbty (evk,argsv as ev) rhs = match kind_of_term rhs with | Evar (evk2,argsv2 as ev2) -> if Evar.equal evk evk2 then @@ -1315,7 +1379,7 @@ and evar_define conv_algo ?(choose=false) env evd pbty (evk,argsv as ev) rhs = (* so we recheck acyclicity *) if occur_evar evk body then raise (OccurCheckIn (evd',body)); (* needed only if an inferred type *) - let body = refresh_universes body in + let evd', body = refresh_universes dir evd' body in (* Cannot strictly type instantiations since the unification algorithm * does not unify applications from left to right. * e.g problem f x == g y yields x==y and f==g (in that order) @@ -1399,8 +1463,9 @@ let reconsider_conv_pbs conv_algo evd = let solve_simple_eqn conv_algo ?(choose=false) env evd (pbty,(evk1,args1 as ev1),t2) = try let t2 = whd_betaiota evd t2 in (* includes whd_evar *) - let evd = evar_define conv_algo ~choose env evd pbty ev1 t2 in - reconsider_conv_pbs conv_algo evd + let dir = match pbty with Some d -> d | None -> false in + let evd = evar_define conv_algo ~choose ~dir env evd pbty ev1 t2 in + reconsider_conv_pbs conv_algo evd with | NotInvertibleUsingOurAlgorithm t -> UnifFailure (evd,NotClean (ev1,t)) diff --git a/pretyping/evarsolve.mli b/pretyping/evarsolve.mli index 5d0063c47..7276669bf 100644 --- a/pretyping/evarsolve.mli +++ b/pretyping/evarsolve.mli @@ -31,9 +31,11 @@ type conv_fun = type conv_fun_bool = env -> evar_map -> conv_pb -> constr -> constr -> bool -val evar_define : conv_fun -> ?choose:bool -> env -> evar_map -> +val evar_define : conv_fun -> ?choose:bool -> ?dir:bool -> env -> evar_map -> bool option -> existential -> constr -> evar_map +val refresh_universes : bool -> evar_map -> types -> evar_map * types + val solve_refl : ?can_drop:bool -> conv_fun_bool -> env -> evar_map -> bool option -> existential_key -> constr array -> constr array -> evar_map diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml index 1605ef7cf..908e59227 100644 --- a/pretyping/evarutil.ml +++ b/pretyping/evarutil.ml @@ -21,6 +21,27 @@ open Evd open Reductionops open Pretype_errors +let evd_comb0 f evdref = + let (evd',x) = f !evdref in + evdref := evd'; + x + +let evd_comb1 f evdref x = + let (evd',y) = f !evdref x in + evdref := evd'; + y + +let evd_comb2 f evdref x y = + let (evd',z) = f !evdref x y in + evdref := evd'; + z + +let e_new_global evdref x = + evd_comb1 (Evd.fresh_global (Global.env())) evdref x + +let new_global evd x = + Evd.fresh_global (Global.env()) evd x + (****************************************************) (* Expanding/testing/exposing existential variables *) (****************************************************) @@ -37,6 +58,8 @@ let rec flush_and_check_evars sigma c = | Some c -> flush_and_check_evars sigma c) | _ -> map_constr (flush_and_check_evars sigma) c +(* let nf_evar_key = Profile.declare_profile "nf_evar" *) +(* let nf_evar = Profile.profile2 nf_evar_key Reductionops.nf_evar *) let nf_evar = Reductionops.nf_evar let j_nf_evar sigma j = { uj_val = nf_evar sigma j.uj_val; @@ -60,24 +83,38 @@ let env_nf_betaiotaevar sigma env = (fun d e -> push_rel (map_rel_declaration (Reductionops.nf_betaiota sigma) d) e) env +let nf_evars_universes evm = + Universes.nf_evars_and_universes_opt_subst (Reductionops.safe_evar_value evm) + (Evd.universe_subst evm) + +let nf_evars_and_universes evm = + let evm = Evd.nf_constraints evm in + evm, nf_evars_universes evm + +let e_nf_evars_and_universes evdref = + evdref := Evd.nf_constraints !evdref; + nf_evars_universes !evdref, Evd.universe_subst !evdref + +let nf_evar_map_universes evm = + let evm = Evd.nf_constraints evm in + let subst = Evd.universe_subst evm in + if Univ.LMap.is_empty subst then evm, nf_evar evm + else + let f = nf_evars_universes evm in + Evd.raw_map (fun _ -> map_evar_info f) evm, f + let nf_named_context_evar sigma ctx = - Context.map_named_context (Reductionops.nf_evar sigma) ctx + Context.map_named_context (nf_evar sigma) ctx let nf_rel_context_evar sigma ctx = - Context.map_rel_context (Reductionops.nf_evar sigma) ctx + Context.map_rel_context (nf_evar sigma) ctx let nf_env_evar sigma env = let nc' = nf_named_context_evar sigma (Environ.named_context env) in let rel' = nf_rel_context_evar sigma (Environ.rel_context env) in push_rel_context rel' (reset_with_named_context (val_of_named_context nc') env) -let nf_evar_info evc info = - { info with - evar_concl = Reductionops.nf_evar evc info.evar_concl; - evar_hyps = map_named_val (Reductionops.nf_evar evc) info.evar_hyps; - evar_body = match info.evar_body with - | Evar_empty -> Evar_empty - | Evar_defined c -> Evar_defined (Reductionops.nf_evar evc c) } +let nf_evar_info evc info = map_evar_info (nf_evar evc) info let nf_evar_map evm = Evd.raw_map (fun _ evi -> nf_evar_info evm evi) evm @@ -89,7 +126,7 @@ let nf_evar_map_undefined evm = (* Auxiliary functions for the conversion algorithms modulo evars *) -let has_undefined_evars_or_sorts evd t = +let has_undefined_evars or_sorts evd t = let rec has_ev t = match kind_of_term t with | Evar (ev,args) -> @@ -98,13 +135,16 @@ let has_undefined_evars_or_sorts evd t = has_ev c; Array.iter has_ev args | Evar_empty -> raise NotInstantiatedEvar) - | Sort s when is_sort_variable evd s -> raise Not_found + | Sort (Type _) (*FIXME could be finer, excluding Prop and Set universes *) when or_sorts -> + raise Not_found + | Ind (_,l) | Const (_,l) | Construct (_,l) + when l <> Univ.Instance.empty && or_sorts -> raise Not_found | _ -> iter_constr has_ev t in try let _ = has_ev t in false with (Not_found | NotInstantiatedEvar) -> true let is_ground_term evd t = - not (has_undefined_evars_or_sorts evd t) + not (has_undefined_evars true evd t) let is_ground_env evd env = let is_ground_decl = function @@ -333,9 +373,21 @@ let new_evar evd env ?src ?filter ?candidates typ = | Some filter -> Filter.filter_list filter instance in new_evar_instance sign evd typ' ?src ?filter ?candidates instance -let new_type_evar ?src ?filter evd env = - let evd', s = new_sort_variable evd in - new_evar evd' env ?src ?filter (mkSort s) +let new_type_evar ?src ?filter rigid evd env = + let evd', s = new_sort_variable rigid evd in + let evd', e = new_evar evd' env ?src ?filter (mkSort s) in + evd', (e, s) + + (* The same using side-effect *) +let e_new_evar evdref env ?(src=(Loc.ghost,Evar_kinds.InternalHole)) ?filter ?candidates ty = + let (evd',ev) = new_evar !evdref env ~src:src ?filter ?candidates ty in + evdref := evd'; + ev + +let e_new_type_evar evdref ?src ?filter rigid env = + let evd', c = new_type_evar ?src ?filter rigid !evdref env in + evdref := evd'; + c (* The same using side-effect *) let e_new_evar evdref env ?(src=default_source) ?filter ?candidates ty = @@ -470,7 +522,6 @@ let clear_hyps_in_evi evdref hyps concl ids = in (nhyps,nconcl) - (** The following functions return the set of evars immediately contained in the object, including defined evars *) @@ -597,6 +648,7 @@ let check_evars env initial_sigma sigma c = | _ -> iter_constr proc_rec c in proc_rec c + (****************************************) (* Operations on value/type constraints *) (****************************************) @@ -639,15 +691,25 @@ let define_pure_evar_as_product evd evk = let evi = Evd.find_undefined evd evk in let evenv = evar_env evi in let id = next_ident_away idx (ids_of_named_context (evar_context evi)) in - let evd1,dom = new_type_evar evd evenv ~filter:(evar_filter evi) in + let s = destSort evi.evar_concl in + let evd1,(dom,u1) = new_type_evar univ_flexible_alg evd evenv ~filter:(evar_filter evi) in let evd2,rng = let newenv = push_named (id, None, dom) evenv in let src = evar_source evk evd1 in let filter = Filter.extend 1 (evar_filter evi) in - new_type_evar evd1 newenv ~src ~filter in + if is_prop_sort s then + (* Impredicative product, conclusion must fall in [Prop]. *) + new_evar evd1 newenv evi.evar_concl ~src ~filter + else + let evd3, (rng, srng) = + new_type_evar univ_flexible_alg evd1 newenv ~src ~filter in + let prods = Univ.sup (univ_of_sort u1) (univ_of_sort srng) in + let evd3 = Evd.set_leq_sort evd3 (Type prods) s in + evd3, rng + in let prod = mkProd (Name id, dom, subst_var id rng) in let evd3 = Evd.define evk prod evd2 in - evd3,prod + evd3,prod (* Refine an applied evar to a product and returns its instantiation *) @@ -707,15 +769,18 @@ let rec evar_absorb_arguments env evd (evk,args as ev) = function (* Refining an evar to a sort *) let define_evar_as_sort evd (ev,args) = - let evd, s = new_sort_variable evd in - Evd.define ev (mkSort s) evd, s + let evd, u = new_univ_variable univ_rigid evd in + let evi = Evd.find_undefined evd ev in + let s = Type u in + let evd' = Evd.define ev (mkSort s) evd in + Evd.set_leq_sort evd' (Type (Univ.super u)) (destSort evi.evar_concl), s (* We don't try to guess in which sort the type should be defined, since any type has type Type. May cause some trouble, but not so far... *) let judge_of_new_Type evd = - let evd', s = new_univ_variable evd in - evd', Typeops.judge_of_type s + let evd', s = new_univ_variable univ_rigid evd in + evd', { uj_val = mkSort (Type s); uj_type = mkSort (Type (Univ.super s)) } (* Propagation of constraints through application and abstraction: Given a type constraint on a functional term, returns the type diff --git a/pretyping/evarutil.mli b/pretyping/evarutil.mli index f41f1ec86..b860ce337 100644 --- a/pretyping/evarutil.mli +++ b/pretyping/evarutil.mli @@ -39,7 +39,16 @@ val e_new_evar : (** Create a new Type existential variable, as we keep track of them during type-checking and unification. *) val new_type_evar : - ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> evar_map -> env -> evar_map * constr + ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> rigid -> evar_map -> env -> + evar_map * (constr * sorts) + +val e_new_type_evar : evar_map ref -> + ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> rigid -> env -> constr * sorts + +(** Polymorphic constants *) + +val new_global : evar_map -> Globnames.global_reference -> evar_map * constr +val e_new_global : evar_map ref -> Globnames.global_reference -> constr (** Create a fresh evar in a context different from its definition context: [new_evar_instance sign evd ty inst] creates a new evar of context @@ -65,6 +74,9 @@ val head_evar : constr -> existential_key (** may raise NoHeadEvar *) (* Expand head evar if any *) val whd_head_evar : evar_map -> constr -> constr +(* [has_undefined_evars or_sorts evd c] checks if [c] has undefined evars + and optionally if it contains undefined sorts. *) +val has_undefined_evars : bool -> evar_map -> constr -> bool val is_ground_term : evar_map -> constr -> bool val is_ground_env : evar_map -> env -> bool (** [check_evars env initial_sigma extended_sigma c] fails if some @@ -160,6 +172,15 @@ val jv_nf_betaiotaevar : evar_map -> unsafe_judgment array -> unsafe_judgment array (** Presenting terms without solved evars *) +val nf_evars_universes : evar_map -> constr -> constr + +val nf_evars_and_universes : evar_map -> evar_map * (constr -> constr) +val e_nf_evars_and_universes : evar_map ref -> (constr -> constr) * Universes.universe_opt_subst + +(** Normalize the evar map w.r.t. universes, after simplification of constraints. + Return the substitution function for constrs as well. *) +val nf_evar_map_universes : evar_map -> evar_map * (constr -> constr) + (** Replacing all evars, possibly raising [Uninstantiated_evar] *) exception Uninstantiated_evar of existential_key val flush_and_check_evars : evar_map -> constr -> constr @@ -189,3 +210,9 @@ val push_rel_context_to_named_context : Environ.env -> types -> named_context_val * types * constr list * constr list * (identifier*constr) list val generalize_evar_over_rels : evar_map -> existential -> types * constr list + +(** Evar combinators *) + +val evd_comb0 : (evar_map -> evar_map * 'a) -> evar_map ref -> 'a +val evd_comb1 : (evar_map -> 'b -> evar_map * 'a) -> evar_map ref -> 'b -> 'a +val evd_comb2 : (evar_map -> 'b -> 'c -> evar_map * 'a) -> evar_map ref -> 'b -> 'c -> 'a diff --git a/pretyping/evd.ml b/pretyping/evd.ml index 8fc6b8ab2..0776988d7 100644 --- a/pretyping/evd.ml +++ b/pretyping/evd.ml @@ -207,6 +207,18 @@ let eq_evar_info ei1 ei2 = eq_evar_body ei1.evar_body ei2.evar_body (** ppedrot: [eq_constr] may be a bit too permissive here *) + +let map_evar_body f = function + | Evar_empty -> Evar_empty + | Evar_defined d -> Evar_defined (f d) + +let map_evar_info f evi = + {evi with + evar_body = map_evar_body f evi.evar_body; + evar_hyps = map_named_val f evi.evar_hyps; + evar_concl = f evi.evar_concl; + evar_candidates = Option.map (List.map f) evi.evar_candidates } + (* spiwack: Revised hierarchy : - Evar.Map ( Maps of existential_keys ) - EvarInfoMap ( .t = evar_info Evar.Map.t * evar_info Evar.Map ) @@ -250,6 +262,202 @@ let instantiate_evar_array info c args = | [] -> c | _ -> replace_vars inst c +(* 2nd part used to check consistency on the fly. *) +type evar_universe_context = + { uctx_local : Univ.universe_context_set; (** The local context of variables *) + uctx_postponed : Univ.universe_constraints; + uctx_univ_variables : Universes.universe_opt_subst; + (** The local universes that are unification variables *) + uctx_univ_algebraic : Univ.universe_set; + (** The subset of unification variables that + can be instantiated with algebraic universes as they appear in types + and universe instances only. *) + uctx_universes : Univ.universes; (** The current graph extended with the local constraints *) + } + +let empty_evar_universe_context = + { uctx_local = Univ.ContextSet.empty; + uctx_postponed = Univ.UniverseConstraints.empty; + uctx_univ_variables = Univ.LMap.empty; + uctx_univ_algebraic = Univ.LSet.empty; + uctx_universes = Univ.initial_universes } + +let evar_universe_context_from e c = + {empty_evar_universe_context with + uctx_local = c; uctx_universes = universes e} + +let is_empty_evar_universe_context ctx = + Univ.ContextSet.is_empty ctx.uctx_local && + Univ.LMap.is_empty ctx.uctx_univ_variables + +let union_evar_universe_context ctx ctx' = + if ctx == ctx' then ctx + else if is_empty_evar_universe_context ctx then ctx' + else if is_empty_evar_universe_context ctx' then ctx + else + let local = + if ctx.uctx_local == ctx'.uctx_local then ctx.uctx_local + else Univ.ContextSet.union ctx.uctx_local ctx'.uctx_local + in + { uctx_local = local; + uctx_postponed = Univ.UniverseConstraints.union ctx.uctx_postponed ctx'.uctx_postponed; + uctx_univ_variables = + Univ.LMap.subst_union ctx.uctx_univ_variables ctx'.uctx_univ_variables; + uctx_univ_algebraic = + Univ.LSet.union ctx.uctx_univ_algebraic ctx'.uctx_univ_algebraic; + uctx_universes = + if local == ctx.uctx_local then ctx.uctx_universes + else + let cstrsr = Univ.ContextSet.constraints ctx'.uctx_local in + Univ.merge_constraints cstrsr ctx.uctx_universes} + +(* let union_evar_universe_context_key = Profile.declare_profile "union_evar_universe_context";; *) +(* let union_evar_universe_context = *) +(* Profile.profile2 union_evar_universe_context_key union_evar_universe_context;; *) + +let diff_evar_universe_context ctx' ctx = + if ctx == ctx' then empty_evar_universe_context + else + let local = Univ.ContextSet.diff ctx'.uctx_local ctx.uctx_local in + { uctx_local = local; + uctx_postponed = Univ.UniverseConstraints.diff ctx'.uctx_postponed ctx.uctx_postponed; + uctx_univ_variables = + Univ.LMap.diff ctx'.uctx_univ_variables ctx.uctx_univ_variables; + uctx_univ_algebraic = + Univ.LSet.diff ctx'.uctx_univ_algebraic ctx.uctx_univ_algebraic; + uctx_universes = Univ.empty_universes } + +(* let diff_evar_universe_context_key = Profile.declare_profile "diff_evar_universe_context";; *) +(* let diff_evar_universe_context = *) +(* Profile.profile2 diff_evar_universe_context_key diff_evar_universe_context;; *) + +type 'a in_evar_universe_context = 'a * evar_universe_context + +let evar_universe_context_set ctx = ctx.uctx_local +let evar_context_universe_context ctx = Univ.ContextSet.to_context ctx.uctx_local +let evar_universe_context_of ctx = { empty_evar_universe_context with uctx_local = ctx } +let evar_universe_context_subst ctx = ctx.uctx_univ_variables + +let instantiate_variable l b v = + (* let b = Univ.subst_large_constraint (Univ.Universe.make l) Univ.type0m_univ b in *) + (* if Univ.univ_depends (Univ.Universe.make l) b then *) + (* error ("Occur-check in universe variable instantiation") *) + (* else *) v := Univ.LMap.add l (Some b) !v + +exception UniversesDiffer + +let process_universe_constraints univs postponed vars alg local cstrs = + let vars = ref vars in + let normalize = Universes.normalize_universe_opt_subst vars in + let rec unify_universes fo l d r local postponed = + let l = normalize l and r = normalize r in + if Univ.Universe.eq l r then local, postponed + else + let varinfo x = + match Univ.Universe.level x with + | None -> Inl x + | Some l -> Inr (l, Univ.LMap.mem l !vars, Univ.LSet.mem l alg) + in + if d == Univ.ULe then + if Univ.check_leq univs l r then + (** Keep Prop <= var around if var might be instantiated by prop later. *) + if Univ.is_type0m_univ l && not (Univ.is_small_univ r) then + match Univ.Universe.level l, Univ.Universe.level r with + | Some l, Some r -> Univ.Constraint.add (l,Univ.Le,r) local, postponed + | _, _ -> local, postponed + else local, postponed + else + match Univ.Universe.level r with + | None -> (local, Univ.UniverseConstraints.add (l,d,r) postponed) + | Some _ -> (Univ.enforce_leq l r local, postponed) + else if d == Univ.ULub then + match varinfo l, varinfo r with + | (Inr (l, true, _), Inr (r, _, _)) + | (Inr (r, _, _), Inr (l, true, _)) -> + instantiate_variable l (Univ.Universe.make r) vars; + Univ.enforce_eq_level l r local, postponed + | Inr (_, _, _), Inr (_, _, _) -> + unify_universes true l Univ.UEq r local postponed + | _, _ -> (* Dead code *) + if Univ.check_eq univs l r then local, postponed + else local, Univ.UniverseConstraints.add (l,d,r) postponed + else (* d = Univ.UEq *) + match varinfo l, varinfo r with + | Inr (l', lloc, _), Inr (r', rloc, _) -> + let () = + if lloc then + instantiate_variable l' (Univ.Universe.make r') vars + else if rloc then + instantiate_variable r' (Univ.Universe.make l') vars + else + (* Two rigid/global levels, one of them being Prop/Set, disallow *) + (* if Univ.is_small_univ l' || Univ.is_small_univ r' then *) + (* raise UniversesDiffer *) + (* else *) + if fo then + if not (Univ.check_eq univs l r) then + raise UniversesDiffer + in + Univ.enforce_eq_level l' r' local, postponed + | _, _ (* Algebraic or globals: + try first-order unification of formal expressions. + THIS IS WRONG: it should be postponed and the equality + turned into a common lub constraint. *) -> + if Univ.check_eq univs l r then local, postponed + else raise UniversesDiffer + (* anomaly (Pp.str"Trying to equate algebraic universes") *) + (* local, Univ.UniverseConstraints.add (l,d,r) postponed *) + in + let rec fixpoint local postponed cstrs = + let local, postponed' = + Univ.UniverseConstraints.fold (fun (l,d,r) (local, p) -> unify_universes false l d r local p) + cstrs (local, postponed) + in + if Univ.UniverseConstraints.is_empty postponed' then local, postponed' + else if Univ.UniverseConstraints.equal cstrs postponed' then local, postponed' + else (* Progress: *) + fixpoint local Univ.UniverseConstraints.empty postponed' + in + let local, pbs = fixpoint Univ.Constraint.empty postponed cstrs in + !vars, local, pbs + +let add_constraints_context ctx cstrs = + let univs, local = ctx.uctx_local in + let cstrs' = Univ.Constraint.fold (fun (l,d,r) acc -> + let l = Univ.Universe.make l and r = Univ.Universe.make r in + let cstr' = + if d == Univ.Lt then (Univ.Universe.super l, Univ.ULe, r) + else (l, (if d == Univ.Le then Univ.ULe else Univ.UEq), r) + in Univ.UniverseConstraints.add cstr' acc) + cstrs Univ.UniverseConstraints.empty + in + let vars, local', pbs = + process_universe_constraints ctx.uctx_universes ctx.uctx_postponed + ctx.uctx_univ_variables ctx.uctx_univ_algebraic + local cstrs' + in + { ctx with uctx_local = (univs, Univ.Constraint.union local local'); + uctx_postponed = pbs; + uctx_univ_variables = vars; + uctx_universes = Univ.merge_constraints cstrs ctx.uctx_universes } + +(* let addconstrkey = Profile.declare_profile "add_constraints_context";; *) +(* let add_constraints_context = Profile.profile2 addconstrkey add_constraints_context;; *) + +let add_universe_constraints_context ctx cstrs = + let univs, local = ctx.uctx_local in + let vars, local', pbs = + process_universe_constraints ctx.uctx_universes ctx.uctx_postponed + ctx.uctx_univ_variables ctx.uctx_univ_algebraic local cstrs + in + { ctx with uctx_local = (univs, Univ.Constraint.union local local'); + uctx_postponed = pbs; + uctx_univ_variables = vars; + uctx_universes = Univ.merge_constraints local' ctx.uctx_universes } + +(* let addunivconstrkey = Profile.declare_profile "add_universe_constraints_context";; *) +(* let add_universe_constraints_context = *) +(* Profile.profile2 addunivconstrkey add_universe_constraints_context;; *) (*******************************************************************) (* Metamaps *) @@ -341,8 +549,7 @@ module EvMap = Evar.Map type evar_map = { defn_evars : evar_info EvMap.t; undf_evars : evar_info EvMap.t; - universes : Univ.UniverseLSet.t; - univ_cstrs : Univ.universes; + universes : evar_universe_context; conv_pbs : evar_constraint list; last_mods : Evar.Set.t; metas : clbinding Metamap.t; @@ -448,8 +655,11 @@ let existential_type d (n, args) = anomaly (str "Evar " ++ str (string_of_existential n) ++ str " was not declared") in instantiate_evar_array info info.evar_concl args -let add_constraints d cstrs = - { d with univ_cstrs = Univ.merge_constraints cstrs d.univ_cstrs } +let add_constraints d c = + { d with universes = add_constraints_context d.universes c } + +let add_universe_constraints d c = + { d with universes = add_universe_constraints_context d.universes c } (*** /Lifting... ***) @@ -473,8 +683,8 @@ let subst_evar_info s evi = evar_body = subst_evb evi.evar_body } let subst_evar_defs_light sub evd = - assert (Univ.is_initial_universes evd.univ_cstrs); - assert (match evd.conv_pbs with [] -> true | _ -> false); + assert (Univ.is_initial_universes evd.universes.uctx_universes); + assert (List.is_empty evd.conv_pbs); let map_info i = subst_evar_info sub i in { evd with undf_evars = EvMap.smartmap map_info evd.undf_evars; @@ -483,6 +693,13 @@ let subst_evar_defs_light sub evd = let subst_evar_map = subst_evar_defs_light +let cmap f evd = + { evd with + metas = Metamap.map (map_clb f) evd.metas; + defn_evars = EvMap.map (map_evar_info f) evd.defn_evars; + undf_evars = EvMap.map (map_evar_info f) evd.defn_evars + } + (* spiwack: deprecated *) let create_evar_defs sigma = { sigma with conv_pbs=[]; last_mods=Evar.Set.empty; metas=Metamap.empty } @@ -494,20 +711,32 @@ let create_goal_evar_defs sigma = { sigma with let empty = { defn_evars = EvMap.empty; undf_evars = EvMap.empty; - universes = Univ.UniverseLSet.empty; - univ_cstrs = Univ.initial_universes; + universes = empty_evar_universe_context; conv_pbs = []; last_mods = Evar.Set.empty; metas = Metamap.empty; effects = Declareops.no_seff; } +let from_env ?(ctx=Univ.ContextSet.empty) e = + { empty with universes = evar_universe_context_from e ctx } + + let has_undefined evd = not (EvMap.is_empty evd.undf_evars) -let evars_reset_evd ?(with_conv_pbs=false) evd d = +let evars_reset_evd ?(with_conv_pbs=false) ?(with_univs=true) evd d = let conv_pbs = if with_conv_pbs then evd.conv_pbs else d.conv_pbs in let last_mods = if with_conv_pbs then evd.last_mods else d.last_mods in - { evd with metas = d.metas; last_mods; conv_pbs; } + let universes = + if not with_univs then evd.universes + else union_evar_universe_context evd.universes d.universes + in + { evd with + metas = d.metas; + last_mods; conv_pbs; universes } + +let merge_universe_context evd uctx' = + { evd with universes = union_evar_universe_context evd.universes uctx' } let add_conv_pb pb d = {d with conv_pbs = pb::d.conv_pbs} @@ -608,80 +837,444 @@ let drop_side_effects evd = let eval_side_effects evd = evd.effects +let meta_diff ext orig = + Metamap.fold (fun m v acc -> + if Metamap.mem m orig then acc + else Metamap.add m v acc) + ext Metamap.empty + +(** ext is supposed to be an extension of odef: + it might have more defined evars, and more + or less undefined ones *) +let diff2 edef eundef odef oundef = + let def = + if odef == edef then EvMap.empty + else + EvMap.fold (fun e v acc -> + if EvMap.mem e odef then acc + else EvMap.add e v acc) + edef EvMap.empty + in + let undef = + if oundef == eundef then EvMap.empty + else + EvMap.fold (fun e v acc -> + if EvMap.mem e oundef then acc + else EvMap.add e v acc) + eundef EvMap.empty + in + (def, undef) + +let diff ext orig = + let defn, undf = diff2 ext.defn_evars ext.undf_evars orig.defn_evars orig.undf_evars in + { ext with + defn_evars = defn; undf_evars = undf; + universes = diff_evar_universe_context ext.universes orig.universes; + metas = meta_diff ext.metas orig.metas + } + +(** Invariant: sigma' is a partial extension of sigma: + It may define variables that are undefined in sigma, + or add new defined or undefined variables. It should not + undefine a defined variable in sigma. +*) + +let merge2 def undef def' undef' = + let def, undef = + EvMap.fold (fun n v (def,undef) -> + EvMap.add n v def, EvMap.remove n undef) + def' (def,undef) + in + let undef = EvMap.fold EvMap.add undef' undef in + (def, undef) + +let merge_metas metas1 metas2 = + List.fold_left (fun m (n,v) -> Metamap.add n v m) + metas2 (metamap_to_list metas1) + +let merge orig ext = + let defn, undf = merge2 orig.defn_evars orig.undf_evars ext.defn_evars ext.undf_evars in + let universes = union_evar_universe_context orig.universes ext.universes in + { orig with defn_evars = defn; undf_evars = undf; + universes; + metas = merge_metas orig.metas ext.metas } + (**********************************************************) (* Sort variables *) -let new_univ_variable evd = - let u = Termops.new_univ_level () in - let universes = Univ.UniverseLSet.add u evd.universes in - ({ evd with universes }, Univ.Universe.make u) +type rigid = + | UnivRigid + | UnivFlexible of bool (** Is substitution by an algebraic ok? *) + +let univ_rigid = UnivRigid +let univ_flexible = UnivFlexible false +let univ_flexible_alg = UnivFlexible true + +let evar_universe_context d = d.universes -let new_sort_variable d = - let (d', u) = new_univ_variable d in - (d', Type u) +let get_universe_context_set d = d.universes.uctx_local + +let universes evd = evd.universes.uctx_universes + +let universe_context evd = + Univ.ContextSet.to_context evd.universes.uctx_local + +let universe_subst evd = + evd.universes.uctx_univ_variables + +let merge_uctx rigid uctx ctx' = + let uctx = + match rigid with + | UnivRigid -> uctx + | UnivFlexible b -> + let uvars' = Univ.LMap.subst_union uctx.uctx_univ_variables + (Univ.LMap.of_set (Univ.ContextSet.levels ctx') None) in + if b then + { uctx with uctx_univ_variables = uvars'; + uctx_univ_algebraic = Univ.LSet.union uctx.uctx_univ_algebraic + (Univ.ContextSet.levels ctx') } + else { uctx with uctx_univ_variables = uvars' } + in + { uctx with uctx_local = Univ.ContextSet.union uctx.uctx_local ctx'; + uctx_universes = Univ.merge_constraints (Univ.ContextSet.constraints ctx') + uctx.uctx_universes } + +let merge_context_set rigid evd ctx' = + {evd with universes = merge_uctx rigid evd.universes ctx'} + +let with_context_set rigid d (a, ctx) = + (merge_context_set rigid d ctx, a) + +let uctx_new_univ_variable rigid + ({ uctx_local = ctx; uctx_univ_variables = uvars; uctx_univ_algebraic = avars} as uctx) = + let u = Universes.new_univ_level (Global.current_dirpath ()) in + let ctx' = Univ.ContextSet.union ctx (Univ.ContextSet.singleton u) in + let uctx' = + match rigid with + | UnivRigid -> uctx + | UnivFlexible b -> + let uvars' = Univ.LMap.add u None uvars in + if b then {uctx with uctx_univ_variables = uvars'; + uctx_univ_algebraic = Univ.LSet.add u avars} + else {uctx with uctx_univ_variables = Univ.LMap.add u None uvars} in + {uctx' with uctx_local = ctx'}, u + +let new_univ_variable rigid evd = + let uctx', u = uctx_new_univ_variable rigid evd.universes in + ({evd with universes = uctx'}, Univ.Universe.make u) + +let new_sort_variable rigid d = + let (d', u) = new_univ_variable rigid d in + (d', Type u) + +let make_flexible_variable evd b u = + let {uctx_univ_variables = uvars; uctx_univ_algebraic = avars} as ctx = evd.universes in + let uvars' = Univ.LMap.add u None uvars in + let avars' = + if b then + let uu = Univ.Universe.make u in + let substu_not_alg u' v = + Option.cata (fun vu -> Univ.Universe.eq uu vu && not (Univ.LSet.mem u' avars)) false v + in + if not (Univ.LMap.exists substu_not_alg uvars) + then Univ.LSet.add u avars else avars + else avars + in + {evd with universes = {ctx with uctx_univ_variables = uvars'; + uctx_univ_algebraic = avars'}} + + +let instantiate_univ_variable evd v u = + let uvars' = Univ.LMap.add v (Some u) evd.universes.uctx_univ_variables in + {evd with universes = {evd.universes with uctx_univ_variables = uvars'}} + +(****************************************) +(* Operations on constants *) +(****************************************) + +let fresh_sort_in_family env evd s = + with_context_set univ_flexible evd (Universes.fresh_sort_in_family env s) + +let fresh_constant_instance env evd c = + with_context_set univ_flexible evd (Universes.fresh_constant_instance env c) + +let fresh_inductive_instance env evd i = + with_context_set univ_flexible evd (Universes.fresh_inductive_instance env i) + +let fresh_constructor_instance env evd c = + with_context_set univ_flexible evd (Universes.fresh_constructor_instance env c) + +let fresh_global ?(rigid=univ_flexible) env evd gr = + (* match gr with *) + (* | ConstructRef c -> let evd, c = fresh_constructor_instance env evd c in *) + (* evd, mkConstructU c *) + (* | IndRef c -> let evd, c = fresh_inductive_instance env evd c in *) + (* evd, mkIndU c *) + (* | ConstRef c -> let evd, c = fresh_constant_instance env evd c in *) + (* evd, mkConstU c *) + (* | VarRef i -> evd, mkVar i *) + with_context_set rigid evd (Universes.fresh_global_instance env gr) -let is_sort_variable evd s = match s with Type u -> true | _ -> false let whd_sort_variable evd t = t -let univ_of_sort = function - | Type u -> u - | Prop Pos -> Univ.type0_univ - | Prop Null -> Univ.type0m_univ +let is_sort_variable evd s = + match s with + | Type u -> + (match Univ.universe_level u with + | Some l -> + let uctx = evd.universes in + if Univ.LSet.mem l (Univ.ContextSet.levels uctx.uctx_local) then + Some (l, not (Univ.LMap.mem l uctx.uctx_univ_variables)) + else None + | None -> None) + | _ -> None + let is_eq_sort s1 s2 = if Sorts.equal s1 s2 then None else let u1 = univ_of_sort s1 and u2 = univ_of_sort s2 in - if Univ.Universe.equal u1 u2 then None + if Univ.Universe.eq u1 u2 then None else Some (u1, u2) -let is_univ_var_or_set u = - Univ.is_univ_variable u || Univ.is_type0_univ u +let is_univ_var_or_set u = + not (Option.is_empty (Univ.universe_level u)) -let set_leq_sort evd s1 s2 = - match is_eq_sort s1 s2 with - | None -> evd - | Some (u1, u2) -> - match s1, s2 with - | Prop Null, Prop Pos -> evd - | Prop _, Prop _ -> - raise (Univ.UniverseInconsistency (Univ.Le, u1, u2,[])) - | Type u, Prop Pos -> - let cstr = Univ.enforce_leq u Univ.type0_univ Univ.empty_constraint in - add_constraints evd cstr - | Type _, Prop _ -> - raise (Univ.UniverseInconsistency (Univ.Le, u1, u2,[])) - | _, Type u -> - if is_univ_var_or_set u then - let cstr = Univ.enforce_leq u1 u2 Univ.empty_constraint in - add_constraints evd cstr - else raise (Univ.UniverseInconsistency (Univ.Le, u1, u2,[])) - -let is_univ_level_var us u = - match Univ.universe_level u with - | Some u -> Univ.UniverseLSet.mem u us - | None -> false +type universe_global = + | LocalUniv of Univ.universe_level + | GlobalUniv of Univ.universe_level + +type universe_kind = + | Algebraic of Univ.universe + | Variable of universe_global * bool -let set_eq_sort ({ universes = us; univ_cstrs = sm; } as d) s1 s2 = +let is_univ_level_var (us, cst) algs u = + match Univ.universe_level u with + | Some l -> + let glob = if Univ.LSet.mem l us then LocalUniv l else GlobalUniv l in + Variable (glob, Univ.LSet.mem l algs) + | None -> Algebraic u + +let normalize_universe evd = + let vars = ref evd.universes.uctx_univ_variables in + let normalize = Universes.normalize_universe_opt_subst vars in + normalize + +let memo_normalize_universe evd = + let vars = ref evd.universes.uctx_univ_variables in + let normalize = Universes.normalize_universe_opt_subst vars in + (fun () -> {evd with universes = {evd.universes with uctx_univ_variables = !vars}}), + normalize + +let normalize_universe_instance evd l = + let vars = ref evd.universes.uctx_univ_variables in + let normalize = Univ.level_subst_of (Universes.normalize_univ_variable_opt_subst vars) in + Univ.Instance.subst_fn normalize l + +let normalize_sort evars s = + match s with + | Prop _ -> s + | Type u -> + let u' = normalize_universe evars u in + if u' == u then s else Type u' + +(* FIXME inefficient *) +let set_eq_sort d s1 s2 = + let s1 = normalize_sort d s1 and s2 = normalize_sort d s2 in match is_eq_sort s1 s2 with | None -> d + | Some (u1, u2) -> add_universe_constraints d + (Univ.UniverseConstraints.singleton (u1,Univ.UEq,u2)) + +let has_lub evd u1 u2 = + (* let normalize = Universes.normalize_universe_opt_subst (ref univs.uctx_univ_variables) in *) + (* (\* let dref, norm = memo_normalize_universe d in *\) *) + (* let u1 = normalize u1 and u2 = normalize u2 in *) + if Univ.Universe.eq u1 u2 then evd + else add_universe_constraints evd + (Univ.UniverseConstraints.singleton (u1,Univ.ULub,u2)) + +let set_eq_level d u1 u2 = + add_constraints d (Univ.enforce_eq_level u1 u2 Univ.Constraint.empty) + +let set_leq_level d u1 u2 = + add_constraints d (Univ.enforce_leq_level u1 u2 Univ.Constraint.empty) + +let set_eq_instances d u1 u2 = + add_universe_constraints d + (Univ.enforce_eq_instances_univs false u1 u2 Univ.UniverseConstraints.empty) + +let set_leq_sort evd s1 s2 = + let s1 = normalize_sort evd s1 + and s2 = normalize_sort evd s2 in + match is_eq_sort s1 s2 with + | None -> evd | Some (u1, u2) -> match s1, s2 with - | Prop c, Type u when is_univ_level_var us u -> - add_constraints d (Univ.enforce_eq u1 u2 Univ.empty_constraint) - | Type u, Prop c when is_univ_level_var us u -> - add_constraints d (Univ.enforce_eq u1 u2 Univ.empty_constraint) - | Type u, Type v when (is_univ_level_var us u) || (is_univ_level_var us v) -> - add_constraints d (Univ.enforce_eq u1 u2 Univ.empty_constraint) - | Prop c, Type u when is_univ_var_or_set u && - Univ.lax_check_eq sm u1 u2 -> d - | Type u, Prop c when is_univ_var_or_set u && - Univ.lax_check_eq sm u1 u2 -> d - | Type u, Type v when is_univ_var_or_set u && is_univ_var_or_set v -> - add_constraints d (Univ.enforce_eq u1 u2 Univ.empty_constraint) - | _, _ -> raise (Univ.UniverseInconsistency (Univ.Eq, u1, u2, [])) - + | Prop c, Prop c' -> + if c == Null && c' == Pos then evd + else (raise (Univ.UniverseInconsistency (Univ.Le, u1, u2, []))) + | _, _ -> + add_universe_constraints evd (Univ.UniverseConstraints.singleton (u1,Univ.ULe,u2)) + +let check_eq evd s s' = + Univ.check_eq evd.universes.uctx_universes s s' + +let check_leq evd s s' = + Univ.check_leq evd.universes.uctx_universes s s' + +let subst_univs_context_with_def def usubst (ctx, cst) = + (Univ.LSet.diff ctx def, Univ.subst_univs_constraints usubst cst) + +let subst_univs_context usubst ctx = + subst_univs_context_with_def (Univ.LMap.universes usubst) (Univ.make_subst usubst) ctx + +let subst_univs_universes s g = + Univ.LMap.fold (fun u v g -> + (* Problem here: we might have instantiated an algebraic universe... *) + Univ.enforce_constraint (u, Univ.Eq, Option.get (Univ.Universe.level v)) g) s g + +let subst_univs_opt_universes s g = + Univ.LMap.fold (fun u v g -> + (* Problem here: we might have instantiated an algebraic universe... *) + match v with + | Some l -> + Univ.enforce_constraint (u, Univ.Eq, Option.get (Univ.Universe.level l)) g + | None -> g) s g + +let normalize_evar_universe_context_variables uctx = + let normalized_variables, undef, def, subst = + Universes.normalize_univ_variables uctx.uctx_univ_variables + in + let ctx_local = subst_univs_context_with_def def (Univ.make_subst subst) uctx.uctx_local in + (* let univs = subst_univs_universes subst uctx.uctx_universes in *) + let ctx_local', univs = Universes.refresh_constraints (Global.universes ()) ctx_local in + subst, { uctx with uctx_local = ctx_local'; + uctx_univ_variables = normalized_variables; + uctx_universes = univs } + +(* let normvarsconstrkey = Profile.declare_profile "normalize_evar_universe_context_variables";; *) +(* let normalize_evar_universe_context_variables = *) +(* Profile.profile1 normvarsconstrkey normalize_evar_universe_context_variables;; *) + +let mark_undefs_as_rigid uctx = + let vars' = + Univ.LMap.fold (fun u v acc -> + if v == None && not (Univ.LSet.mem u uctx.uctx_univ_algebraic) + then acc else Univ.LMap.add u v acc) + uctx.uctx_univ_variables Univ.LMap.empty + in { uctx with uctx_univ_variables = vars' } + +let mark_undefs_as_nonalg uctx = + let vars' = + Univ.LMap.fold (fun u v acc -> + if v == None then Univ.LSet.remove u acc + else acc) + uctx.uctx_univ_variables uctx.uctx_univ_algebraic + in { uctx with uctx_univ_algebraic = vars' } + +let abstract_undefined_variables evd = + {evd with universes = mark_undefs_as_nonalg evd.universes} + +let refresh_undefined_univ_variables uctx = + let subst, ctx' = Universes.fresh_universe_context_set_instance uctx.uctx_local in + let alg = Univ.LSet.fold (fun u acc -> Univ.LSet.add (Univ.subst_univs_level_level subst u) acc) + uctx.uctx_univ_algebraic Univ.LSet.empty + in + let vars = + Univ.LMap.fold + (fun u v acc -> + Univ.LMap.add (Univ.subst_univs_level_level subst u) + (Option.map (Univ.subst_univs_level_universe subst) v) acc) + uctx.uctx_univ_variables Univ.LMap.empty + in + let uctx' = {uctx_local = ctx'; + uctx_postponed = Univ.UniverseConstraints.empty;(*FIXME*) + uctx_univ_variables = vars; uctx_univ_algebraic = alg; + uctx_universes = Univ.initial_universes} in + uctx', subst + +let refresh_undefined_universes evd = + let uctx', subst = refresh_undefined_univ_variables evd.universes in + let evd' = cmap (subst_univs_level_constr subst) {evd with universes = uctx'} in + evd', subst + +let constraints_universes c = + Univ.Constraint.fold (fun (l',d,r') acc -> Univ.LSet.add l' (Univ.LSet.add r' acc)) + c Univ.LSet.empty + +let is_undefined_universe_variable l vars = + try (match Univ.LMap.find l vars with + | Some u -> false + | None -> true) + with Not_found -> false + +let normalize_evar_universe_context uctx = + let rec fixpoint uctx = + let ((vars',algs'), us') = + Universes.normalize_context_set uctx.uctx_local uctx.uctx_univ_variables + uctx.uctx_univ_algebraic + in + if Univ.LSet.equal (fst us') (fst uctx.uctx_local) then + uctx + else + let us', universes = Universes.refresh_constraints (Global.universes ()) us' in + (* let universes = subst_univs_opt_universes vars' uctx.uctx_universes in *) + let postponed = + Univ.subst_univs_universe_constraints (Universes.make_opt_subst vars') + uctx.uctx_postponed + in + let uctx' = + { uctx_local = us'; + uctx_univ_variables = vars'; + uctx_univ_algebraic = algs'; + uctx_postponed = postponed; + uctx_universes = universes} + in fixpoint uctx' + in fixpoint uctx + +let nf_univ_variables evd = + let subst, uctx' = normalize_evar_universe_context_variables evd.universes in + let evd' = {evd with universes = uctx'} in + evd', subst + +let normalize_univ_level fullsubst u = + try Univ.LMap.find u fullsubst + with Not_found -> Univ.Universe.make u + +let nf_constraints evd = + let subst, uctx' = normalize_evar_universe_context_variables evd.universes in + let uctx' = normalize_evar_universe_context uctx' in + {evd with universes = uctx'} + +(* let nfconstrkey = Profile.declare_profile "nf_constraints";; *) +(* let nf_constraints = Profile.profile1 nfconstrkey nf_constraints;; *) + +let universes evd = evd.universes.uctx_universes + +(* Conversion w.r.t. an evar map and its local universes. *) + +let conversion_gen env evd pb t u = + match pb with + | Reduction.CONV -> + Reduction.trans_conv_universes + full_transparent_state ~evars:(existential_opt_value evd) env + evd.universes.uctx_universes t u + | Reduction.CUMUL -> Reduction.trans_conv_leq_universes + full_transparent_state ~evars:(existential_opt_value evd) env + evd.universes.uctx_universes t u + +(* let conversion_gen_key = Profile.declare_profile "conversion_gen" *) +(* let conversion_gen = Profile.profile5 conversion_gen_key conversion_gen *) + +let conversion env d pb t u = + conversion_gen env d pb t u; d + +let test_conversion env d pb t u = + try conversion_gen env d pb t u; true + with _ -> false + (**********************************************************) (* Accessing metas *) @@ -691,7 +1284,6 @@ let set_metas evd metas = { defn_evars = evd.defn_evars; undf_evars = evd.undf_evars; universes = evd.universes; - univ_cstrs = evd.univ_cstrs; conv_pbs = evd.conv_pbs; last_mods = evd.last_mods; metas; @@ -787,9 +1379,12 @@ let meta_with_name evd id = (str "Binder name \"" ++ pr_id id ++ strbrk "\" occurs more than once in clause.") +let clear_metas evd = {evd with metas = Metamap.empty} + let meta_merge evd1 evd2 = let metas = Metamap.fold Metamap.add evd1.metas evd2.metas in - set_metas evd2 metas + let universes = union_evar_universe_context evd2.universes evd1.universes in + {evd2 with universes; metas; } type metabinding = metavariable * constr * instance_status @@ -907,7 +1502,7 @@ let pr_evar_source = function | Evar_kinds.ImplicitArg (c,(n,ido),b) -> let id = Option.get ido in str "parameter " ++ pr_id id ++ spc () ++ str "of" ++ - spc () ++ print_constr (constr_of_global c) + spc () ++ print_constr (printable_constr_of_global c) | Evar_kinds.InternalHole -> str "internal placeholder" | Evar_kinds.TomatchTypeParameter (ind,n) -> pr_nth n ++ str " argument of type " ++ print_constr (mkInd ind) @@ -989,6 +1584,16 @@ let evar_dependency_closure n sigma = let has_no_evar sigma = EvMap.is_empty sigma.defn_evars && EvMap.is_empty sigma.undf_evars +let pr_evar_universe_context ctx = + if is_empty_evar_universe_context ctx then mt () + else + (str"UNIVERSES:"++brk(0,1)++ h 0 (Univ.pr_universe_context_set ctx.uctx_local) ++ fnl () ++ + str"POSTPONED CONSTRAINTS:"++brk(0,1)++ + h 0 (Univ.UniverseConstraints.pr ctx.uctx_postponed) ++ fnl () ++ + str"ALGEBRAIC UNIVERSES:"++brk(0,1)++h 0 (Univ.LSet.pr ctx.uctx_univ_algebraic) ++ fnl() ++ + str"UNDEFINED UNIVERSES:"++brk(0,1)++ + h 0 (Universes.pr_universe_opt_subst ctx.uctx_univ_variables)) + let print_env_short env = let pr_body n = function | None -> pr_name n @@ -1012,17 +1617,9 @@ let pr_evar_constraints pbs = prlist_with_sep fnl pr_evconstr pbs let pr_evar_map_gen pr_evars sigma = - let { universes = uvs; univ_cstrs = univs; } = sigma in + let { universes = uvs } = sigma in let evs = if has_no_evar sigma then mt () else pr_evars sigma - and svs = - if Univ.UniverseLSet.is_empty uvs then mt () - else str "UNIVERSE VARIABLES:" ++ brk (0, 1) ++ - h 0 (prlist_with_sep fnl Univ.pr_uni_level - (Univ.UniverseLSet.elements uvs)) ++ fnl () - and cs = - if Univ.is_initial_universes univs then mt () - else str "UNIVERSES:" ++ brk (0, 1) ++ - h 0 (Univ.pr_universes univs) ++ fnl () + and svs = pr_evar_universe_context uvs and cstrs = if List.is_empty sigma.conv_pbs then mt () else @@ -1033,7 +1630,7 @@ let pr_evar_map_gen pr_evars sigma = else str "METAS:" ++ brk (0, 1) ++ pr_meta_map sigma.metas in - evs ++ svs ++ cs ++ cstrs ++ metas + evs ++ svs ++ cstrs ++ metas let pr_evar_list l = let pr (ev, evi) = diff --git a/pretyping/evd.mli b/pretyping/evd.mli index 55bce05de..18d68bebf 100644 --- a/pretyping/evd.mli +++ b/pretyping/evd.mli @@ -112,6 +112,9 @@ val evar_filter : evar_info -> Filter.t val evar_env : evar_info -> env val evar_filtered_env : evar_info -> env +val map_evar_body : (constr -> constr) -> evar_body -> evar_body +val map_evar_info : (constr -> constr) -> evar_info -> evar_info + (** {6 Unification state} **) type evar_map @@ -125,6 +128,10 @@ val progress_evar_map : evar_map -> evar_map -> bool val empty : evar_map (** The empty evar map. *) +val from_env : ?ctx:Univ.universe_context_set -> env -> evar_map +(** The empty evar map with given universe context, taking its initial + universes from env. *) + val is_empty : evar_map -> bool (** Whether an evarmap is empty. *) @@ -174,6 +181,17 @@ val define : evar -> constr -> evar_map -> evar_map {- All the evars present in the constr should be present in the evar map.} } *) +val cmap : (constr -> constr) -> evar_map -> evar_map +(** Map the function on all terms in the evar map. *) + +val diff : evar_map -> evar_map -> evar_map +(** [diff ext orig] assuming [ext] is an extension of [orig], + return an evar map containing just the extension *) + +val merge : evar_map -> evar_map -> evar_map +(** [merge orig ext] assuming [ext] is an extension of [orig], + return an evar map containing the union of the two maps *) + val is_evar : evar_map -> evar -> bool (** Alias for {!mem}. *) @@ -208,7 +226,7 @@ val instantiate_evar_array : evar_info -> constr -> constr array -> constr val subst_evar_defs_light : substitution -> evar_map -> evar_map (** Assume empty universe constraints in [evar_map] and [conv_pbs] *) -val evars_reset_evd : ?with_conv_pbs:bool -> evar_map -> evar_map -> evar_map +val evars_reset_evd : ?with_conv_pbs:bool -> ?with_univs:bool -> evar_map -> evar_map -> evar_map (** spiwack: this function seems to somewhat break the abstraction. *) (** {6 Misc} *) @@ -245,6 +263,13 @@ val whd_sort_variable : evar_map -> constr -> constr val set_leq_sort : evar_map -> sorts -> sorts -> evar_map val set_eq_sort : evar_map -> sorts -> sorts -> evar_map +exception UniversesDiffer + +val add_universe_constraints : evar_map -> Univ.universe_constraints -> evar_map +(** Add the given universe unification constraints to the evar map. + @raises UniversesDiffer in case a first-order unification fails. + @raises UniverseInconsistency +*) (** {5 Enriching with evar maps} *) type 'a sigma = { @@ -353,6 +378,8 @@ val meta_declare : val meta_assign : metavariable -> constr * instance_status -> evar_map -> evar_map val meta_reassign : metavariable -> constr * instance_status -> evar_map -> evar_map +val clear_metas : evar_map -> evar_map + (** [meta_merge evd1 evd2] returns [evd2] extended with the metas of [evd1] *) val meta_merge : evar_map -> evar_map -> evar_map @@ -366,6 +393,106 @@ val subst_defined_metas : metabinding list -> constr -> constr option (** {5 FIXME: Nothing to do here} *) +(********************************************************* + Sort/universe variables *) + +(** Rigid or flexible universe variables *) + +type rigid = + | UnivRigid + | UnivFlexible of bool (** Is substitution by an algebraic ok? *) + +val univ_rigid : rigid +val univ_flexible : rigid +val univ_flexible_alg : rigid + +(** The universe context associated to an evar map *) +type evar_universe_context + +type 'a in_evar_universe_context = 'a * evar_universe_context + +val evar_universe_context_set : evar_universe_context -> Univ.universe_context_set +val evar_context_universe_context : evar_universe_context -> Univ.universe_context +val evar_universe_context_of : Univ.universe_context_set -> evar_universe_context +val empty_evar_universe_context : evar_universe_context +val union_evar_universe_context : evar_universe_context -> evar_universe_context -> + evar_universe_context +val evar_universe_context_subst : evar_universe_context -> Universes.universe_opt_subst + +val universes : evar_map -> Univ.universes + +val add_constraints_context : evar_universe_context -> + Univ.constraints -> evar_universe_context + +val normalize_evar_universe_context_variables : evar_universe_context -> + Univ.universe_subst in_evar_universe_context + +val normalize_evar_universe_context : evar_universe_context -> + evar_universe_context + +val new_univ_variable : rigid -> evar_map -> evar_map * Univ.universe +val new_sort_variable : rigid -> evar_map -> evar_map * sorts +val make_flexible_variable : evar_map -> bool -> Univ.universe_level -> evar_map +val is_sort_variable : evar_map -> sorts -> (Univ.universe_level * bool) option +(** [is_sort_variable evm s] returns [Some (u, is_rigid)] or [None] if [s] is + not a sort variable declared in [evm] *) +val whd_sort_variable : evar_map -> constr -> constr +(* val normalize_universe_level : evar_map -> Univ.universe_level -> Univ.universe_level *) +val normalize_universe : evar_map -> Univ.universe -> Univ.universe +val normalize_universe_instance : evar_map -> Univ.universe_instance -> Univ.universe_instance + +val set_leq_sort : evar_map -> sorts -> sorts -> evar_map +val set_eq_sort : evar_map -> sorts -> sorts -> evar_map +val has_lub : evar_map -> Univ.universe -> Univ.universe -> evar_map +val set_eq_level : evar_map -> Univ.universe_level -> Univ.universe_level -> evar_map +val set_leq_level : evar_map -> Univ.universe_level -> Univ.universe_level -> evar_map +val set_eq_instances : evar_map -> Univ.universe_instance -> Univ.universe_instance -> evar_map + +val check_eq : evar_map -> Univ.universe -> Univ.universe -> bool +val check_leq : evar_map -> Univ.universe -> Univ.universe -> bool + +val evar_universe_context : evar_map -> evar_universe_context +val get_universe_context_set : evar_map -> Univ.universe_context_set +val universe_context : evar_map -> Univ.universe_context +val universe_subst : evar_map -> Universes.universe_opt_subst +val universes : evar_map -> Univ.universes + + +val merge_universe_context : evar_map -> evar_universe_context -> evar_map + +val merge_context_set : rigid -> evar_map -> Univ.universe_context_set -> evar_map + +val with_context_set : rigid -> evar_map -> 'a Univ.in_universe_context_set -> evar_map * 'a + +val nf_univ_variables : evar_map -> evar_map * Univ.universe_subst +val abstract_undefined_variables : evar_map -> evar_map + +val refresh_undefined_universes : evar_map -> evar_map * Univ.universe_level_subst + +val nf_constraints : evar_map -> evar_map + +(** Polymorphic universes *) + +val fresh_sort_in_family : env -> evar_map -> sorts_family -> evar_map * sorts +val fresh_constant_instance : env -> evar_map -> constant -> evar_map * pconstant +val fresh_inductive_instance : env -> evar_map -> inductive -> evar_map * pinductive +val fresh_constructor_instance : env -> evar_map -> constructor -> evar_map * pconstructor + +val fresh_global : ?rigid:rigid -> env -> evar_map -> Globnames.global_reference -> evar_map * constr + +(******************************************************************** + Conversion w.r.t. an evar map: might generate universe unifications + that are kept in the evarmap. + Raises [NotConvertible]. *) + +val conversion : env -> evar_map -> conv_pb -> constr -> constr -> evar_map + +(** This one forgets about the assignemts of universes. *) +val test_conversion : env -> evar_map -> conv_pb -> constr -> constr -> bool + +(******************************************************************** + constr with holes *) + type open_constr = evar_map * constr (** Partially constructed constrs. *) @@ -380,6 +507,7 @@ val pr_evar_map : int option -> evar_map -> Pp.std_ppcmds val pr_evar_map_filter : (Evar.t -> evar_info -> bool) -> evar_map -> Pp.std_ppcmds val pr_metaset : Metaset.t -> Pp.std_ppcmds +val pr_evar_universe_context : evar_universe_context -> Pp.std_ppcmds (** {5 Deprecated functions} *) diff --git a/pretyping/glob_ops.ml b/pretyping/glob_ops.ml index f1e38d0f8..73bb343ee 100644 --- a/pretyping/glob_ops.ml +++ b/pretyping/glob_ops.ml @@ -61,7 +61,7 @@ let cast_type_eq eq t1 t2 = match t1, t2 with | _ -> false let rec glob_constr_eq c1 c2 = match c1, c2 with -| GRef (_, gr1), GRef (_, gr2) -> eq_gr gr1 gr2 +| GRef (_, gr1, _), GRef (_, gr2, _) -> eq_gr gr1 gr2 | GVar (_, id1), GVar (_, id2) -> Id.equal id1 id2 | GEvar (_, ev1, arg1), GEvar (_, ev2, arg2) -> Evar.equal ev1 ev2 && @@ -156,6 +156,9 @@ let map_glob_constr_left_to_right f = function let comp2 = Util.List.map_left (fun (tm,x) -> (f tm,x)) tml in let comp3 = Util.List.map_left (fun (loc,idl,p,c) -> (loc,idl,p,f c)) pl in GCases (loc,sty,comp1,comp2,comp3) + | GProj (loc,p,c) -> + let comp1 = f c in + GProj (loc,p,comp1) | GLetTuple (loc,nal,(na,po),b,c) -> let comp1 = Option.map f po in let comp2 = f b in @@ -183,6 +186,7 @@ let fold_glob_constr f acc = let rec fold acc = function | GVar _ -> acc | GApp (_,c,args) -> List.fold_left fold (fold acc c) args + | GProj (_,p,c) -> fold acc c | GLambda (_,_,_,b,c) | GProd (_,_,_,b,c) | GLetIn (_,_,b,c) -> fold (fold acc b) c | GCases (_,_,rtntypopt,tml,pl) -> @@ -221,6 +225,7 @@ let occur_glob_constr id = let rec occur = function | GVar (loc,id') -> Id.equal id id' | GApp (loc,f,args) -> (occur f) || (List.exists occur args) + | GProj (loc,p,c) -> occur c | GLambda (loc,na,bk,ty,c) -> (occur ty) || (not (same_id na id) && (occur c)) | GProd (loc,na,bk,ty,c) -> @@ -270,6 +275,7 @@ let free_glob_vars = let rec vars bounded vs = function | GVar (loc,id') -> if Id.Set.mem id' bounded then vs else Id.Set.add id' vs | GApp (loc,f,args) -> List.fold_left (vars bounded) vs (f::args) + | GProj (loc,p,c) -> vars bounded vs c | GLambda (loc,na,_,ty,c) | GProd (loc,na,_,ty,c) | GLetIn (loc,na,ty,c) -> let vs' = vars bounded vs ty in let bounded' = add_name_to_ids bounded na in @@ -326,11 +332,12 @@ let free_glob_vars = let loc_of_glob_constr = function - | GRef (loc,_) -> loc + | GRef (loc,_,_) -> loc | GVar (loc,_) -> loc | GEvar (loc,_,_) -> loc | GPatVar (loc,_) -> loc | GApp (loc,_,_) -> loc + | GProj (loc,p,c) -> loc | GLambda (loc,_,_,_,_) -> loc | GProd (loc,_,_,_,_) -> loc | GLetIn (loc,_,_,_) -> loc @@ -354,18 +361,18 @@ let rec cases_pattern_of_glob_constr na = function | Anonymous -> PatVar (loc,Name id) end | GHole (loc,_,_) -> PatVar (loc,na) - | GRef (loc,ConstructRef cstr) -> + | GRef (loc,ConstructRef cstr,_) -> PatCstr (loc,cstr,[],na) - | GApp (loc,GRef (_,ConstructRef cstr),l) -> + | GApp (loc,GRef (_,ConstructRef cstr,_),l) -> PatCstr (loc,cstr,List.map (cases_pattern_of_glob_constr Anonymous) l,na) | _ -> raise Not_found (* Turn a closed cases pattern into a glob_constr *) let rec glob_constr_of_closed_cases_pattern_aux = function | PatCstr (loc,cstr,[],Anonymous) -> - GRef (loc,ConstructRef cstr) + GRef (loc,ConstructRef cstr,None) | PatCstr (loc,cstr,l,Anonymous) -> - let ref = GRef (loc,ConstructRef cstr) in + let ref = GRef (loc,ConstructRef cstr,None) in GApp (loc,ref, List.map glob_constr_of_closed_cases_pattern_aux l) | _ -> raise Not_found diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml index bf9fd8a10..35a9cbdb2 100644 --- a/pretyping/indrec.ml +++ b/pretyping/indrec.ml @@ -33,7 +33,7 @@ type dep_flag = bool (* Errors related to recursors building *) type recursion_scheme_error = - | NotAllowedCaseAnalysis of (*isrec:*) bool * sorts * inductive + | NotAllowedCaseAnalysis of (*isrec:*) bool * sorts * pinductive | NotMutualInScheme of inductive * inductive exception RecursionSchemeError of recursion_scheme_error @@ -49,16 +49,16 @@ let mkLambda_string s t c = mkLambda (Name (Id.of_string s), t, c) (* Building case analysis schemes *) (* Christine Paulin, 1996 *) -let mis_make_case_com dep env sigma ind (mib,mip as specif) kind = - let lnamespar = List.map - (fun (n, c, t) -> (n, c, Termops.refresh_universes t)) +let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind = + let usubst = Inductive.make_inductive_subst mib u in + let lnamespar = Vars.subst_univs_context usubst mib.mind_params_ctxt in if not (Sorts.List.mem kind (elim_sorts specif)) then raise (RecursionSchemeError - (NotAllowedCaseAnalysis (false, Termops.new_sort_in_family kind, ind))); + (NotAllowedCaseAnalysis (false, fst (Universes.fresh_sort_in_family env kind), pind))); let ndepar = mip.mind_nrealargs_ctxt + 1 in @@ -66,7 +66,7 @@ let mis_make_case_com dep env sigma ind (mib,mip as specif) kind = (* mais pas très joli ... (mais manque get_sort_of à ce niveau) *) let env' = push_rel_context lnamespar env in - let indf = make_ind_family(ind, Termops.extended_rel_list 0 lnamespar) in + let indf = make_ind_family(pind, Termops.extended_rel_list 0 lnamespar) in let constrs = get_constructors env indf in let rec add_branch env k = @@ -78,7 +78,7 @@ let mis_make_case_com dep env sigma ind (mib,mip as specif) kind = let depind = build_dependent_inductive env indf' in let deparsign = (Anonymous,None,depind)::arsign in - let ci = make_case_info env ind RegularStyle in + let ci = make_case_info env (fst pind) RegularStyle in let pbody = appvect (mkRel (ndepar + nbprod), @@ -101,10 +101,13 @@ let mis_make_case_com dep env sigma ind (mib,mip as specif) kind = mkLambda_string "f" t (add_branch (push_rel (Anonymous, None, t) env) (k+1)) in - let typP = make_arity env' dep indf (Termops.new_sort_in_family kind) in - it_mkLambda_or_LetIn_name env + let sigma, s = Evd.fresh_sort_in_family env sigma kind in + let typP = make_arity env' dep indf s in + let c = + it_mkLambda_or_LetIn_name env (mkLambda_string "P" typP - (add_branch (push_rel (Anonymous,None,typP) env') 0)) lnamespar + (add_branch (push_rel (Anonymous,None,typP) env') 0)) lnamespar + in sigma, c (* check if the type depends recursively on one of the inductive scheme *) @@ -188,7 +191,7 @@ let type_rec_branch is_rec dep env sigma (vargs,depPvect,decP) tyi cs recargs = if dep then let realargs = List.rev_map (fun k -> mkRel (i-k)) li in let params = List.map (lift i) vargs in - let co = applist (mkConstruct cs.cs_cstr,params@realargs) in + let co = applist (mkConstructU cs.cs_cstr,params@realargs) in Reduction.beta_appvect c [|co|] else c in @@ -264,13 +267,14 @@ let context_chop k ctx = | (_, []) -> failwith "context_chop" in chop_aux [] (k,ctx) - (* Main function *) -let mis_make_indrec env sigma listdepkind mib = +let mis_make_indrec env sigma listdepkind mib u = let nparams = mib.mind_nparams in - let nparrec = mib. mind_nparams_rec in + let nparrec = mib.mind_nparams_rec in + let evdref = ref sigma in + let usubst = Inductive.make_inductive_subst mib u in let lnonparrec,lnamesparrec = - context_chop (nparams-nparrec) mib.mind_params_ctxt in + context_chop (nparams-nparrec) (Vars.subst_univs_context usubst mib.mind_params_ctxt) in let nrec = List.length listdepkind in let depPvec = Array.make mib.mind_ntypes (None : (bool * constr) option) in @@ -278,7 +282,7 @@ let mis_make_indrec env sigma listdepkind mib = let rec assign k = function | [] -> () - | (indi,mibi,mipi,dep,_)::rest -> + | ((indi,u),mibi,mipi,dep,_)::rest -> (Array.set depPvec (snd indi) (Some(dep,mkRel k)); assign (k-1) rest) in @@ -292,7 +296,7 @@ let mis_make_indrec env sigma listdepkind mib = let make_one_rec p = let makefix nbconstruct = let rec mrec i ln ltyp ldef = function - | (indi,mibi,mipi,dep,_)::rest -> + | ((indi,u),mibi,mipi,dep,_)::rest -> let tyi = snd indi in let nctyi = Array.length mipi.mind_consnames in (* nb constructeurs du type*) @@ -300,7 +304,7 @@ let mis_make_indrec env sigma listdepkind mib = (* arity in the context of the fixpoint, i.e. P1..P_nrec f1..f_nbconstruct *) let args = Termops.extended_rel_list (nrec+nbconstruct) lnamesparrec in - let indf = make_ind_family(indi,args) in + let indf = make_ind_family((indi,u),args) in let arsign,_ = get_arity env indf in let depind = build_dependent_inductive env indf in @@ -315,7 +319,7 @@ let mis_make_indrec env sigma listdepkind mib = P1..P_nrec f1..f_nbconstruct F_1..F_nrec a_1..a_nar x:I *) let args' = Termops.extended_rel_list (dect+nrec) lnamesparrec in let args'' = Termops.extended_rel_list ndepar lnonparrec in - let indf' = make_ind_family(indi,args'@args'') in + let indf' = make_ind_family((indi,u),args'@args'') in let branches = let constrs = get_constructors env indf' in @@ -325,7 +329,7 @@ let mis_make_indrec env sigma listdepkind mib = fi in Array.map3 - (make_rec_branch_arg env sigma + (make_rec_branch_arg env !evdref (nparrec,depPvec,larsign)) vecfi constrs (dest_subterms recargsvec.(tyi)) in @@ -389,7 +393,7 @@ let mis_make_indrec env sigma listdepkind mib = mrec 0 [] [] [] in let rec make_branch env i = function - | (indi,mibi,mipi,dep,_)::rest -> + | ((indi,u),mibi,mipi,dep,_)::rest -> let tyi = snd indi in let nconstr = Array.length mipi.mind_consnames in let rec onerec env j = @@ -399,10 +403,10 @@ let mis_make_indrec env sigma listdepkind mib = let recarg = (dest_subterms recargsvec.(tyi)).(j) in let recarg = recargpar@recarg in let vargs = Termops.extended_rel_list (nrec+i+j) lnamesparrec in - let cs = get_constructor (indi,mibi,mipi,vargs) (j+1) in + let cs = get_constructor ((indi,u),mibi,mipi,vargs) (j+1) in let p_0 = type_rec_branch - true dep env sigma (vargs,depPvec,i+j) tyi cs recarg + true dep env !evdref (vargs,depPvec,i+j) tyi cs recarg in mkLambda_string "f" p_0 (onerec (push_rel (Anonymous,None,p_0) env) (j+1)) @@ -411,9 +415,10 @@ let mis_make_indrec env sigma listdepkind mib = makefix i listdepkind in let rec put_arity env i = function - | (indi,_,_,dep,kinds)::rest -> - let indf = make_ind_family (indi, Termops.extended_rel_list i lnamesparrec) in - let typP = make_arity env dep indf (Termops.new_sort_in_family kinds) in + | ((indi,u),_,_,dep,kinds)::rest -> + let indf = make_ind_family ((indi,u), Termops.extended_rel_list i lnamesparrec) in + let s = Evarutil.evd_comb1 (Evd.fresh_sort_in_family env) evdref kinds in + let typP = make_arity env dep indf s in mkLambda_string "P" typP (put_arity (push_rel (Anonymous,None,typP) env) (i+1) rest) | [] -> @@ -421,36 +426,38 @@ let mis_make_indrec env sigma listdepkind mib = in (* Body on make_one_rec *) - let (indi,mibi,mipi,dep,kind) = List.nth listdepkind p in + let ((indi,u),mibi,mipi,dep,kind) = List.nth listdepkind p in if (mis_is_recursive_subset - (List.map (fun (indi,_,_,_,_) -> snd indi) listdepkind) + (List.map (fun ((indi,u),_,_,_,_) -> snd indi) listdepkind) mipi.mind_recargs) then let env' = push_rel_context lnamesparrec env in it_mkLambda_or_LetIn_name env (put_arity env' 0 listdepkind) lnamesparrec else - mis_make_case_com dep env sigma indi (mibi,mipi) kind + let evd', c = mis_make_case_com dep env !evdref (indi,u) (mibi,mipi) kind in + evdref := evd'; c in (* Body of mis_make_indrec *) - List.init nrec make_one_rec + !evdref, List.init nrec make_one_rec (**********************************************************************) (* This builds elimination predicate for Case tactic *) -let build_case_analysis_scheme env sigma ity dep kind = - let (mib,mip) = lookup_mind_specif env ity in - mis_make_case_com dep env sigma ity (mib,mip) kind +let build_case_analysis_scheme env sigma pity dep kind = + let (mib,mip) = lookup_mind_specif env (fst pity) in + mis_make_case_com dep env sigma pity (mib,mip) kind -let build_case_analysis_scheme_default env sigma ity kind = - let (mib,mip) = lookup_mind_specif env ity in - let dep = match inductive_sort_family mip with - | InProp -> false - | _ -> true - in - mis_make_case_com dep env sigma ity (mib,mip) kind +let is_in_prop mip = + match inductive_sort_family mip with + | InProp -> true + | _ -> false +let build_case_analysis_scheme_default env sigma pity kind = + let (mib,mip) = lookup_mind_specif env (fst pity) in + let dep = not (is_in_prop mip) in + mis_make_case_com dep env sigma pity (mib,mip) kind (**********************************************************************) (* [modify_sort_scheme s rec] replaces the sort of the scheme @@ -459,37 +466,25 @@ let build_case_analysis_scheme_default env sigma ity kind = let change_sort_arity sort = let rec drec a = match kind_of_term a with | Cast (c,_,_) -> drec c - | Prod (n,t,c) -> mkProd (n, t, drec c) - | LetIn (n,b,t,c) -> mkLetIn (n,b, t, drec c) - | Sort _ -> mkSort sort + | Prod (n,t,c) -> let s, c' = drec c in s, mkProd (n, t, c') + | LetIn (n,b,t,c) -> let s, c' = drec c in s, mkLetIn (n,b,t,c') + | Sort s -> s, mkSort sort | _ -> assert false in drec -(* [npar] is the number of expected arguments (then excluding letin's) *) -let modify_sort_scheme sort = - let rec drec npar elim = - match kind_of_term elim with - | Lambda (n,t,c) -> - if Int.equal npar 0 then - mkLambda (n, change_sort_arity sort t, c) - else - mkLambda (n, t, drec (npar-1) c) - | LetIn (n,b,t,c) -> mkLetIn (n,b,t,drec npar c) - | _ -> anomaly ~label:"modify_sort_scheme" (Pp.str "wrong elimination type") - in - drec - (* Change the sort in the type of an inductive definition, builds the corresponding eta-expanded term *) -let weaken_sort_scheme sort npars term = +let weaken_sort_scheme env evd set sort npars term ty = + let evdref = ref evd in let rec drec np elim = match kind_of_term elim with | Prod (n,t,c) -> if Int.equal np 0 then - let t' = change_sort_arity sort t in - mkProd (n, t', c), - mkLambda (n, t', mkApp(term,Termops.rel_vect 0 (npars+1))) + let osort, t' = change_sort_arity sort t in + evdref := (if set then Evd.set_eq_sort else Evd.set_leq_sort) !evdref sort osort; + mkProd (n, t', c), + mkLambda (n, t', mkApp(term,Termops.rel_vect 0 (npars+1))) else let c',term' = drec (np-1) c in mkProd (n, t, c'), mkLambda (n, t, term') @@ -497,7 +492,8 @@ let weaken_sort_scheme sort npars term = mkLetIn (n,b,t,c'), mkLetIn (n,b,t,term') | _ -> anomaly ~label:"weaken_sort_scheme" (Pp.str "wrong elimination type") in - drec npars + let ty, term = drec npars ty in + !evdref, ty, term (**********************************************************************) (* Interface to build complex Scheme *) @@ -506,11 +502,12 @@ let weaken_sort_scheme sort npars term = let check_arities listdepkind = let _ = List.fold_left - (fun ln ((_,ni as mind),mibi,mipi,dep,kind) -> + (fun ln (((_,ni as mind),u),mibi,mipi,dep,kind) -> let kelim = elim_sorts (mibi,mipi) in if not (Sorts.List.mem kind kelim) then raise (RecursionSchemeError - (NotAllowedCaseAnalysis (true, Termops.new_sort_in_family kind,mind))) + (NotAllowedCaseAnalysis (true, fst (Universes.fresh_sort_in_family (Global.env ()) + kind),(mind,u)))) else if Int.List.mem ni ln then raise (RecursionSchemeError (NotMutualInScheme (mind,mind))) else ni::ln) @@ -518,28 +515,29 @@ let check_arities listdepkind = in true let build_mutual_induction_scheme env sigma = function - | (mind,dep,s)::lrecspec -> + | ((mind,u),dep,s)::lrecspec -> let (mib,mip) = Global.lookup_inductive mind in let (sp,tyi) = mind in let listdepkind = - (mind,mib,mip,dep,s):: + ((mind,u),mib,mip,dep,s):: (List.map - (function (mind',dep',s') -> + (function ((mind',u'),dep',s') -> let (sp',_) = mind' in if eq_mind sp sp' then let (mibi',mipi') = lookup_mind_specif env mind' in - (mind',mibi',mipi',dep',s') + ((mind',u'),mibi',mipi',dep',s') else raise (RecursionSchemeError (NotMutualInScheme (mind,mind')))) lrecspec) in let _ = check_arities listdepkind in - mis_make_indrec env sigma listdepkind mib + mis_make_indrec env sigma listdepkind mib u | _ -> anomaly (Pp.str "build_induction_scheme expects a non empty list of inductive types") -let build_induction_scheme env sigma ind dep kind = - let (mib,mip) = lookup_mind_specif env ind in - List.hd (mis_make_indrec env sigma [(ind,mib,mip,dep,kind)] mib) +let build_induction_scheme env sigma pind dep kind = + let (mib,mip) = lookup_mind_specif env (fst pind) in + let sigma, l = mis_make_indrec env sigma [(pind,mib,mip,dep,kind)] mib (snd pind) in + sigma, List.hd l (*s Eliminations. *) @@ -564,11 +562,11 @@ let lookup_eliminator ind_sp s = try let cst =Global.constant_of_delta_kn (make_kn mp dp (Label.of_id id)) in let _ = Global.lookup_constant cst in - mkConst cst + ConstRef cst with Not_found -> (* Then try to get a user-defined eliminator in some other places *) (* using short name (e.g. for "eq_rec") *) - try constr_of_global (Nametab.locate (qualid_of_ident id)) + try Nametab.locate (qualid_of_ident id) with Not_found -> errorlabstrm "default_elim" (strbrk "Cannot find the elimination combinator " ++ diff --git a/pretyping/indrec.mli b/pretyping/indrec.mli index 6bcfac20e..54827281a 100644 --- a/pretyping/indrec.mli +++ b/pretyping/indrec.mli @@ -14,7 +14,7 @@ open Evd (** Errors related to recursors building *) type recursion_scheme_error = - | NotAllowedCaseAnalysis of (*isrec:*) bool * sorts * inductive + | NotAllowedCaseAnalysis of (*isrec:*) bool * sorts * pinductive | NotMutualInScheme of inductive * inductive exception RecursionSchemeError of recursion_scheme_error @@ -25,41 +25,38 @@ type dep_flag = bool (** Build a case analysis elimination scheme in some sort family *) -val build_case_analysis_scheme : env -> evar_map -> inductive -> - dep_flag -> sorts_family -> constr +val build_case_analysis_scheme : env -> evar_map -> pinductive -> + dep_flag -> sorts_family -> evar_map * constr (** Build a dependent case elimination predicate unless type is in Prop *) -val build_case_analysis_scheme_default : env -> evar_map -> inductive -> - sorts_family -> constr +val build_case_analysis_scheme_default : env -> evar_map -> pinductive -> + sorts_family -> evar_map * constr (** Builds a recursive induction scheme (Peano-induction style) in the same sort family as the inductive family; it is dependent if not in Prop *) -val build_induction_scheme : env -> evar_map -> inductive -> - dep_flag -> sorts_family -> constr +val build_induction_scheme : env -> evar_map -> pinductive -> + dep_flag -> sorts_family -> evar_map * constr (** Builds mutual (recursive) induction schemes *) val build_mutual_induction_scheme : - env -> evar_map -> (inductive * dep_flag * sorts_family) list -> constr list + env -> evar_map -> (pinductive * dep_flag * sorts_family) list -> evar_map * constr list (** Scheme combinators *) -(** [modify_sort_scheme s n c] modifies the quantification sort of - scheme c whose predicate is abstracted at position [n] of [c] *) +(** [weaken_sort_scheme env sigma eq s n c t] derives by subtyping from [c:t] + whose conclusion is quantified on [Type i] at position [n] of [t] a + scheme quantified on sort [s]. [set] asks for [s] be declared equal to [i], + otherwise just less or equal to [i]. *) -val modify_sort_scheme : sorts -> int -> constr -> constr - -(** [weaken_sort_scheme s n c t] derives by subtyping from [c:t] - whose conclusion is quantified on [Type] at position [n] of [t] a - scheme quantified on sort [s] *) - -val weaken_sort_scheme : sorts -> int -> constr -> types -> constr * types +val weaken_sort_scheme : env -> evar_map -> bool -> sorts -> int -> constr -> types -> + evar_map * types * constr (** Recursor names utilities *) -val lookup_eliminator : inductive -> sorts_family -> constr +val lookup_eliminator : inductive -> sorts_family -> Globnames.global_reference val elimination_suffix : sorts_family -> string val make_elimination_ident : Id.t -> sorts_family -> Id.t diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index 775795ce0..7e4d37b2e 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -19,32 +19,38 @@ open Declarations open Declareops open Environ open Reductionops +open Inductive (* The following three functions are similar to the ones defined in Inductive, but they expect an env *) -let type_of_inductive env ind = +let type_of_inductive env (ind,u) = let specif = Inductive.lookup_mind_specif env ind in - Inductive.type_of_inductive env specif + Inductive.type_of_inductive env (specif,u) (* Return type as quoted by the user *) -let type_of_constructor env cstr = +let type_of_constructor env (cstr,u) = let specif = Inductive.lookup_mind_specif env (inductive_of_constructor cstr) in - Inductive.type_of_constructor cstr specif + Inductive.type_of_constructor (cstr,u) specif + +let type_of_constructor_in_ctx env cstr = + let specif = + Inductive.lookup_mind_specif env (inductive_of_constructor cstr) in + Inductive.type_of_constructor_in_ctx cstr specif (* Return constructor types in user form *) -let type_of_constructors env ind = +let type_of_constructors env (ind,u as indu) = let specif = Inductive.lookup_mind_specif env ind in - Inductive.type_of_constructors ind specif + Inductive.type_of_constructors indu specif (* Return constructor types in normal form *) -let arities_of_constructors env ind = +let arities_of_constructors env (ind,u as indu) = let specif = Inductive.lookup_mind_specif env ind in - Inductive.arities_of_constructors ind specif + Inductive.arities_of_constructors indu specif (* [inductive_family] = [inductive_instance] applied to global parameters *) -type inductive_family = inductive * constr list +type inductive_family = pinductive * constr list let make_ind_family (mis, params) = (mis,params) let dest_ind_family (mis,params) = (mis,params) @@ -71,7 +77,7 @@ let lift_inductive_type n = liftn_inductive_type n 1 let substnl_ind_type l n = map_inductive_type (substnl l n) let mkAppliedInd (IndType ((ind,params), realargs)) = - applist (mkInd ind,params@realargs) + applist (mkIndU ind,params@realargs) (* Does not consider imbricated or mutually recursive types *) let mis_is_recursive_subset listind rarg = @@ -88,13 +94,14 @@ let mis_is_recursive (ind,mib,mip) = mis_is_recursive_subset (List.interval 0 (mib.mind_ntypes - 1)) mip.mind_recargs -let mis_nf_constructor_type (ind,mib,mip) j = +let mis_nf_constructor_type ((ind,u),mib,mip) j = let specif = mip.mind_nf_lc and ntypes = mib.mind_ntypes and nconstr = Array.length mip.mind_consnames in - let make_Ik k = mkInd ((fst ind),ntypes-k-1) in + let make_Ik k = mkIndU (((fst ind),ntypes-k-1),u) in if j > nconstr then error "Not enough constructors in the type."; - substl (List.init ntypes make_Ik) specif.(j-1) + let univsubst = make_inductive_subst mib u in + substl (List.init ntypes make_Ik) (subst_univs_constr univsubst specif.(j-1)) (* Arity of constructors excluding parameters and local defs *) @@ -139,9 +146,10 @@ let constructor_nrealhyps (ind,j) = let (mib,mip) = Global.lookup_inductive ind in mip.mind_consnrealdecls.(j-1) -let get_full_arity_sign env ind = +let get_full_arity_sign env (ind,u) = let (mib,mip) = Inductive.lookup_mind_specif env ind in - mip.mind_arity_ctxt + let subst = Inductive.make_inductive_subst mib u in + Vars.subst_univs_context subst mip.mind_arity_ctxt let nconstructors ind = let (mib,mip) = Inductive.lookup_mind_specif (Global.env()) ind in @@ -164,6 +172,10 @@ let inductive_has_local_defs ind = let inductive_nparams ind = (fst (Global.lookup_inductive ind)).mind_nparams +let inductive_params_ctxt (ind,u) = + let (mib,mip) = Global.lookup_inductive ind in + Inductive.inductive_params_ctxt (mib,u) + let inductive_nargs ind = let (mib,mip) = Global.lookup_inductive ind in (rel_context_length (mib.mind_params_ctxt), mip.mind_nrealargs_ctxt) @@ -189,7 +201,7 @@ let make_case_info env ind style = (*s Useful functions *) type constructor_summary = { - cs_cstr : constructor; + cs_cstr : pconstructor; cs_params : constr list; cs_nargs : int; cs_args : rel_context; @@ -219,21 +231,21 @@ let instantiate_params t args sign = | _ -> anomaly ~label:"instantiate_params" (Pp.str "type, ctxt and args mismatch") in inst [] t (List.rev sign,args) -let get_constructor (ind,mib,mip,params) j = +let get_constructor ((ind,u as indu),mib,mip,params) j = assert (j <= Array.length mip.mind_consnames); - let typi = mis_nf_constructor_type (ind,mib,mip) j in + let typi = mis_nf_constructor_type (indu,mib,mip) j in let typi = instantiate_params typi params mib.mind_params_ctxt in let (args,ccl) = decompose_prod_assum typi in let (_,allargs) = decompose_app ccl in let vargs = List.skipn (List.length params) allargs in - { cs_cstr = ith_constructor_of_inductive ind j; + { cs_cstr = (ith_constructor_of_inductive ind j,u); cs_params = params; cs_nargs = rel_context_length args; cs_args = args; cs_concl_realargs = Array.of_list vargs } let get_constructors env (ind,params) = - let (mib,mip) = Inductive.lookup_mind_specif env ind in + let (mib,mip) = Inductive.lookup_mind_specif env (fst ind) in Array.init (Array.length mip.mind_consnames) (fun j -> get_constructor (ind,mib,mip,params) (j+1)) @@ -255,8 +267,9 @@ let instantiate_context sign args = | _ -> anomaly (Pp.str "Signature/instance mismatch in inductive family") in aux [] (List.rev sign,args) -let get_arity env (ind,params) = +let get_arity env ((ind,u),params) = let (mib,mip) = Inductive.lookup_mind_specif env ind in + let univsubst = make_inductive_subst mib u in let parsign = (* Dynamically detect if called with an instance of recursively uniform parameter only or also of non recursively uniform @@ -267,15 +280,17 @@ let get_arity env (ind,params) = snd (List.chop nnonrecparams mib.mind_params_ctxt) else parsign in + let parsign = Vars.subst_univs_context univsubst parsign in let arproperlength = List.length mip.mind_arity_ctxt - List.length parsign in let arsign,_ = List.chop arproperlength mip.mind_arity_ctxt in let subst = instantiate_context parsign params in + let arsign = Vars.subst_univs_context univsubst arsign in (substl_rel_context subst arsign, Inductive.inductive_sort_family mip) (* Functions to build standard types related to inductive *) let build_dependent_constructor cs = applist - (mkConstruct cs.cs_cstr, + (mkConstructU cs.cs_cstr, (List.map (lift cs.cs_nargs) cs.cs_params) @(extended_rel_list 0 cs.cs_args)) @@ -283,7 +298,7 @@ let build_dependent_inductive env ((ind, params) as indf) = let arsign,_ = get_arity env indf in let nrealargs = List.length arsign in applist - (mkInd ind, + (mkIndU ind, (List.map (lift nrealargs) params)@(extended_rel_list 0 arsign)) (* builds the arity of an elimination predicate in sort [s] *) @@ -328,18 +343,18 @@ let find_mrectype env sigma c = let find_rectype env sigma c = let (t, l) = decompose_app (whd_betadeltaiota env sigma c) in match kind_of_term t with - | Ind ind -> + | Ind (ind,u as indu) -> let (mib,mip) = Inductive.lookup_mind_specif env ind in if mib.mind_nparams > List.length l then raise Not_found; let (par,rargs) = List.chop mib.mind_nparams l in - IndType((ind, par),rargs) + IndType((indu, par),rargs) | _ -> raise Not_found let find_inductive env sigma c = let (t, l) = decompose_app (whd_betadeltaiota env sigma c) in match kind_of_term t with | Ind ind - when (fst (Inductive.lookup_mind_specif env ind)).mind_finite -> + when (fst (Inductive.lookup_mind_specif env (fst ind))).mind_finite -> (ind, l) | _ -> raise Not_found @@ -347,7 +362,7 @@ let find_coinductive env sigma c = let (t, l) = decompose_app (whd_betadeltaiota env sigma c) in match kind_of_term t with | Ind ind - when not (fst (Inductive.lookup_mind_specif env ind)).mind_finite -> + when not (fst (Inductive.lookup_mind_specif env (fst ind))).mind_finite -> (ind, l) | _ -> raise Not_found @@ -414,7 +429,7 @@ let set_pattern_names env ind brv = let type_case_branches_with_names env indspec p c = let (ind,args) = indspec in - let (mib,mip as specif) = Inductive.lookup_mind_specif env ind in + let (mib,mip as specif) = Inductive.lookup_mind_specif env (fst ind) in let nparams = mib.mind_nparams in let (params,realargs) = List.chop nparams args in let lbrty = Inductive.build_branches_type ind specif params p in @@ -422,7 +437,7 @@ let type_case_branches_with_names env indspec p c = let conclty = Reduction.beta_appvect p (Array.of_list (realargs@[c])) in (* Adjust names *) if is_elim_predicate_explicitly_dependent env p (ind,params) then - (set_pattern_names env ind lbrty, conclty) + (set_pattern_names env (fst ind) lbrty, conclty) else (lbrty, conclty) (* Type of Case predicates *) @@ -436,40 +451,9 @@ let arity_of_case_predicate env (ind,params) dep k = (* Inferring the sort of parameters of a polymorphic inductive type knowing the sort of the conclusion *) -(* Compute the inductive argument types: replace the sorts - that appear in the type of the inductive by the sort of the - conclusion, and the other ones by fresh universes. *) -let rec instantiate_universes env scl is = function - | (_,Some _,_ as d)::sign, exp -> - d :: instantiate_universes env scl is (sign, exp) - | d::sign, None::exp -> - d :: instantiate_universes env scl is (sign, exp) - | (na,None,ty)::sign, Some u::exp -> - let ctx,_ = Reduction.dest_arity env ty in - let s = - (* Does the sort of parameter [u] appear in (or equal) - the sort of inductive [is] ? *) - if univ_depends u is then - scl (* constrained sort: replace by scl *) - else - (* unconstriained sort: replace by fresh universe *) - new_Type_sort() in - (na,None,mkArity(ctx,s)):: instantiate_universes env scl is (sign, exp) - | sign, [] -> sign (* Uniform parameters are exhausted *) - | [], _ -> assert false - -(* Does not deal with universes, but only with Set/Type distinction *) -let type_of_inductive_knowing_conclusion env mip conclty = - match mip.mind_arity with - | Monomorphic s -> - s.mind_user_arity - | Polymorphic ar -> - let _,scl = Reduction.dest_arity env conclty in - let ctx = List.rev mip.mind_arity_ctxt in - let ctx = - instantiate_universes - env scl ar.poly_level (ctx,ar.poly_param_levels) in - mkArity (List.rev ctx,scl) +let type_of_inductive_knowing_conclusion env ((mib,mip),u) conclty = + let subst = Inductive.make_inductive_subst mib u in + subst_univs_constr subst mip.mind_arity.mind_user_arity (***********************************************) (* Guard condition *) @@ -490,7 +474,3 @@ let control_only_guard env c = iter_constr_with_full_binders push_rel iter env c in iter env c - -let subst_inductive subst (kn,i as ind) = - let kn' = Mod_subst.subst_ind subst kn in - if kn == kn' then ind else (kn',i) diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli index 204f506a6..39451ec05 100644 --- a/pretyping/inductiveops.mli +++ b/pretyping/inductiveops.mli @@ -16,19 +16,20 @@ open Evd (** The following three functions are similar to the ones defined in Inductive, but they expect an env *) -val type_of_inductive : env -> inductive -> types +val type_of_inductive : env -> pinductive -> types (** Return type as quoted by the user *) -val type_of_constructor : env -> constructor -> types -val type_of_constructors : env -> inductive -> types array +val type_of_constructor : env -> pconstructor -> types +val type_of_constructor_in_ctx : env -> constructor -> types Univ.in_universe_context +val type_of_constructors : env -> pinductive -> types array (** Return constructor types in normal form *) -val arities_of_constructors : env -> inductive -> types array +val arities_of_constructors : env -> pinductive -> types array (** An inductive type with its parameters *) type inductive_family -val make_ind_family : inductive * constr list -> inductive_family -val dest_ind_family : inductive_family -> inductive * constr list +val make_ind_family : inductive puniverses * constr list -> inductive_family +val dest_ind_family : inductive_family -> inductive puniverses * constr list val map_ind_family : (constr -> constr) -> inductive_family -> inductive_family val liftn_inductive_family : int -> int -> inductive_family -> inductive_family val lift_inductive_family : int -> inductive_family -> inductive_family @@ -49,7 +50,7 @@ val mis_is_recursive_subset : int list -> wf_paths -> bool val mis_is_recursive : inductive * mutual_inductive_body * one_inductive_body -> bool val mis_nf_constructor_type : - inductive * mutual_inductive_body * one_inductive_body -> int -> constr + pinductive * mutual_inductive_body * one_inductive_body -> int -> constr (** {6 Extract information from an inductive name} @@ -69,6 +70,7 @@ val inductive_nargs_env : env -> inductive -> int * int (** @return nb of params without letin *) val inductive_nparams : inductive -> int +val inductive_params_ctxt : pinductive -> rel_context (** @return param + args without letin *) val mis_constructor_nargs : constructor -> int @@ -88,14 +90,14 @@ val constructor_nrealhyps : constructor -> int val mis_constructor_has_local_defs : constructor -> bool val inductive_has_local_defs : inductive -> bool -val get_full_arity_sign : env -> inductive -> rel_context +val get_full_arity_sign : env -> pinductive -> rel_context val allowed_sorts : env -> inductive -> sorts_family list (** Extract information from an inductive family *) type constructor_summary = { - cs_cstr : constructor; (* internal name of the constructor *) + cs_cstr : pconstructor; (* internal name of the constructor plus universes *) cs_params : constr list; (* parameters of the constructor in current ctx *) cs_nargs : int; (* length of arguments signature (letin included) *) cs_args : rel_context; (* signature of the arguments (letin included) *) @@ -103,7 +105,7 @@ type constructor_summary = { } val lift_constructor : int -> constructor_summary -> constructor_summary val get_constructor : - inductive * mutual_inductive_body * one_inductive_body * constr list -> + pinductive * mutual_inductive_body * one_inductive_body * constr list -> int -> constructor_summary val get_arity : env -> inductive_family -> rel_context * sorts_family val get_constructors : env -> inductive_family -> constructor_summary array @@ -114,11 +116,11 @@ val make_arity : env -> bool -> inductive_family -> sorts -> types val build_branch_type : env -> bool -> constr -> constructor_summary -> types (** Raise [Not_found] if not given an valid inductive type *) -val extract_mrectype : constr -> inductive * constr list -val find_mrectype : env -> evar_map -> types -> inductive * constr list +val extract_mrectype : constr -> pinductive * constr list +val find_mrectype : env -> evar_map -> types -> pinductive * constr list val find_rectype : env -> evar_map -> types -> inductive_type -val find_inductive : env -> evar_map -> types -> inductive * constr list -val find_coinductive : env -> evar_map -> types -> inductive * constr list +val find_inductive : env -> evar_map -> types -> pinductive * constr list +val find_coinductive : env -> evar_map -> types -> pinductive * constr list (********************) @@ -127,7 +129,7 @@ val arity_of_case_predicate : env -> inductive_family -> bool -> sorts -> types val type_case_branches_with_names : - env -> inductive * constr list -> constr -> constr -> + env -> pinductive * constr list -> constr -> constr -> types array * types (** Annotation for cases *) @@ -140,9 +142,7 @@ i*) (********************) val type_of_inductive_knowing_conclusion : - env -> one_inductive_body -> types -> types + env -> Inductive.mind_specif puniverses -> types -> types (********************) val control_only_guard : env -> types -> unit - -val subst_inductive : Mod_subst.substitution -> inductive -> inductive diff --git a/pretyping/namegen.ml b/pretyping/namegen.ml index d4435489a..c6c21f025 100644 --- a/pretyping/namegen.ml +++ b/pretyping/namegen.ml @@ -76,9 +76,10 @@ let hdchar env c = | LetIn (_,_,_,c) -> hdrec (k+1) c | Cast (c,_,_) -> hdrec k c | App (f,l) -> hdrec k f - | Const kn -> lowercase_first_char (Label.to_id (con_label kn)) - | Ind x -> lowercase_first_char (basename_of_global (IndRef x)) - | Construct x -> lowercase_first_char (basename_of_global (ConstructRef x)) + | Proj (kn,_) + | Const (kn,_) -> lowercase_first_char (Label.to_id (con_label kn)) + | Ind (x,_) -> lowercase_first_char (basename_of_global (IndRef x)) + | Construct (x,_) -> lowercase_first_char (basename_of_global (ConstructRef x)) | Var id -> lowercase_first_char id | Sort s -> sort_hdchar s | Rel n -> diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml index b635229cf..829fa106c 100644 --- a/pretyping/nativenorm.ml +++ b/pretyping/nativenorm.ml @@ -59,7 +59,7 @@ let find_rectype_a env c = (* Instantiate inductives and parameters in constructor type *) let type_constructor mind mib typ params = - let s = ind_subst mind mib in + let s = ind_subst mind mib Univ.Instance.empty (* FIXME *)in let ctyp = substl s typ in let nparams = Array.length params in if Int.equal nparams 0 then ctyp @@ -67,7 +67,7 @@ let type_constructor mind mib typ params = let _,ctyp = decompose_prod_n nparams ctyp in substl (List.rev (Array.to_list params)) ctyp -let construct_of_constr_notnative const env tag (mind, _ as ind) allargs = +let construct_of_constr_notnative const env tag (mind, _ as ind) u allargs = let mib,mip = lookup_mind_specif env ind in let nparams = mib.mind_nparams in let params = Array.sub allargs 0 nparams in @@ -80,14 +80,14 @@ let construct_of_constr_notnative const env tag (mind, _ as ind) allargs = with Not_found -> let i = invert_tag const tag mip.mind_reloc_tbl in let ctyp = type_constructor mind mib (mip.mind_nf_lc.(i-1)) params in - (mkApp(mkConstruct(ind,i), params), ctyp) + (mkApp(mkConstructU((ind,i),u), params), ctyp) let construct_of_constr const env tag typ = let t, l = app_type env typ in match kind_of_term t with - | Ind ind -> - construct_of_constr_notnative const env tag ind l + | Ind (ind,u) -> + construct_of_constr_notnative const env tag ind u l | _ -> assert false let construct_of_constr_const env tag typ = @@ -109,9 +109,9 @@ let build_branches_type env (mind,_ as _ind) mib mip params dep p = let codom = let papp = mkApp(lift (List.length decl) p,crealargs) in if dep then - let cstr = ith_constructor_of_inductive ind (i+1) in + let cstr = ith_constructor_of_inductive (fst ind) (i+1) in let relargs = Array.init carity (fun i -> mkRel (carity-i)) in - let dep_cstr = mkApp(mkApp(mkConstruct cstr,params),relargs) in + let dep_cstr = mkApp(mkApp(mkConstructU (cstr,snd ind),params),relargs) in mkApp(papp,[|dep_cstr|]) else papp in @@ -266,6 +266,9 @@ and nf_atom env atom = mkProd(n,dom,codom) | Ameta (mv,_) -> mkMeta mv | Aevar (ev,_) -> mkEvar ev + | Aproj(p,c) -> + let c = nf_accu env c in + mkProj(p,c) | _ -> fst (nf_atom_type env atom) and nf_atom_type env atom = @@ -274,17 +277,17 @@ and nf_atom_type env atom = let n = (nb_rel env - i) in mkRel n, type_of_rel env n | Aconstant cst -> - mkConst cst, Typeops.type_of_constant env cst + mkConst cst, fst (Typeops.type_of_constant env (cst,Univ.Instance.empty)) (* FIXME *) | Aind ind -> - mkInd ind, Inductiveops.type_of_inductive env ind + mkInd ind, Inductiveops.type_of_inductive env (ind,Univ.Instance.empty) | Asort s -> mkSort s, type_of_sort s | Avar id -> mkVar id, type_of_var env id | Acase(ans,accu,p,bs) -> let a,ta = nf_accu_type env accu in - let (mind,_ as ind),allargs = find_rectype_a env ta in - let (mib,mip) = Inductive.lookup_mind_specif env ind in + let ((mind,_),u as ind),allargs = find_rectype_a env ta in + let (mib,mip) = Inductive.lookup_mind_specif env (fst ind) in let nparams = mib.mind_nparams in let params,realargs = Array.chop nparams allargs in let pT = @@ -293,7 +296,7 @@ and nf_atom_type env atom = let pT = whd_betadeltaiota env pT in let dep, p = nf_predicate env ind mip params p pT in (* Calcul du type des branches *) - let btypes = build_branches_type env ind mib mip params dep p in + let btypes = build_branches_type env (fst ind) mib mip params dep p in (* calcul des branches *) let bsw = branch_of_switch (nb_rel env) ans bs in let mkbranch i v = @@ -336,6 +339,12 @@ and nf_atom_type env atom = | Ameta(mv,ty) -> let ty = nf_type env ty in mkMeta mv, ty + | Aproj(p,c) -> + let c,tc = nf_accu_type env c in + let cj = make_judge c tc in + let uj = Typeops.judge_of_projection env p cj in + uj.uj_val, uj.uj_type + and nf_predicate env ind mip params v pT = match kind_of_value v, kind_of_term pT with @@ -358,7 +367,7 @@ and nf_predicate env ind mip params v pT = let n = mip.mind_nrealargs in let rargs = Array.init n (fun i -> mkRel (n-i)) in let params = if Int.equal n 0 then params else Array.map (lift n) params in - let dom = mkApp(mkInd ind,Array.append params rargs) in + let dom = mkApp(mkIndU ind,Array.append params rargs) in let body = nf_type (push_rel (name,None,dom) env) vb in true, mkLambda(name,dom,body) | _, _ -> false, nf_type env v diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml index cc13d342a..8557953cc 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -81,6 +81,7 @@ and rec_declaration_eq (n1, c1, r1) (n2, c2, r2) = let rec occur_meta_pattern = function | PApp (f,args) -> (occur_meta_pattern f) || (Array.exists occur_meta_pattern args) + | PProj (_,arg) -> occur_meta_pattern arg | PLambda (na,t,c) -> (occur_meta_pattern t) || (occur_meta_pattern c) | PProd (na,t,c) -> (occur_meta_pattern t) || (occur_meta_pattern c) | PLetIn (na,t,c) -> (occur_meta_pattern t) || (occur_meta_pattern c) @@ -105,6 +106,7 @@ let rec head_pattern_bound t = | PCase (_,p,c,br) -> head_pattern_bound c | PRef r -> r | PVar id -> VarRef id + | PProj (p,c) -> ConstRef p | PEvar _ | PRel _ | PMeta _ | PSoApp _ | PSort _ | PFix _ -> raise BoundPattern (* Perhaps they were arguments, but we don't beta-reduce *) @@ -112,9 +114,9 @@ let rec head_pattern_bound t = | PCoFix _ -> anomaly ~label:"head_pattern_bound" (Pp.str "not a type") let head_of_constr_reference c = match kind_of_term c with - | Const sp -> ConstRef sp - | Construct sp -> ConstructRef sp - | Ind sp -> IndRef sp + | Const (sp,_) -> ConstRef sp + | Construct (sp,_) -> ConstructRef sp + | Ind (sp,_) -> IndRef sp | Var id -> VarRef id | _ -> anomaly (Pp.str "Not a rigid reference") @@ -145,9 +147,11 @@ let pattern_of_constr sigma t = with | Some n -> PSoApp (n,Array.to_list (Array.map pattern_of_constr a)) | None -> PApp (pattern_of_constr f,Array.map (pattern_of_constr) a)) - | Const sp -> PRef (ConstRef (constant_of_kn(canonical_con sp))) - | Ind sp -> PRef (canonical_gr (IndRef sp)) - | Construct sp -> PRef (canonical_gr (ConstructRef sp)) + | Const (sp,u) -> PRef (ConstRef (constant_of_kn(canonical_con sp))) + | Ind (sp,u) -> PRef (canonical_gr (IndRef sp)) + | Construct (sp,u) -> PRef (canonical_gr (ConstructRef sp)) + | Proj (p, c) -> + PProj (constant_of_kn(canonical_con p), pattern_of_constr c) | Evar (evk,ctxt as ev) -> (match snd (Evd.evar_source evk sigma) with | Evar_kinds.MatchingVar (b,id) -> @@ -185,6 +189,7 @@ let map_pattern_with_binders g f l = function | PIf (c,b1,b2) -> PIf (f l c,f l b1,f l b2) | PCase (ci,po,p,pl) -> PCase (ci,f l po,f l p, List.map (fun (i,n,c) -> (i,n,f l c)) pl) + | PProj (p,pc) -> PProj (p, f l pc) (* Non recursive *) | (PVar _ | PEvar _ | PRel _ | PRef _ | PSort _ | PMeta _ (* Bound to terms *) @@ -240,6 +245,12 @@ let rec subst_pattern subst pat = | PVar _ | PEvar _ | PRel _ -> pat + | PProj (p,c) -> + let p',t = subst_global subst (ConstRef p) in + let p' = destConstRef p' in + let c' = subst_pattern subst c in + if p' == p && c' == c then pat else + PProj(p',c') | PApp (f,args) -> let f' = subst_pattern subst f in let args' = Array.smartmap (subst_pattern subst) args in @@ -274,7 +285,7 @@ let rec subst_pattern subst pat = PIf (c',c1',c2') | PCase (cip,typ,c,branches) -> let ind = cip.cip_ind in - let ind' = Option.smartmap (Inductiveops.subst_inductive subst) ind in + let ind' = Option.smartmap (subst_ind subst) ind in let cip' = if ind' == ind then cip else { cip with cip_ind = ind' } in let typ' = subst_pattern subst typ in let c' = subst_pattern subst c in @@ -308,11 +319,13 @@ let rec pat_of_raw metas vars = function with Not_found -> PVar id) | GPatVar (_,(false,n)) -> metas := n::!metas; PMeta (Some n) - | GRef (_,gr) -> + | GRef (_,gr,_) -> PRef (canonical_gr gr) (* Hack pour ne pas réécrire une interprétation complète des patterns*) | GApp (_, GPatVar (_,(true,n)), cl) -> metas := n::!metas; PSoApp (n, List.map (pat_of_raw metas vars) cl) + | GProj (_, p, c) -> + PProj (p, pat_of_raw metas vars c) | GApp (_,c,cl) -> PApp (pat_of_raw metas vars c, Array.of_list (List.map (pat_of_raw metas vars) cl)) diff --git a/pretyping/pretype_errors.ml b/pretyping/pretype_errors.ml index 8ffd53055..003665db5 100644 --- a/pretyping/pretype_errors.ml +++ b/pretyping/pretype_errors.ml @@ -21,7 +21,7 @@ type unification_error = | ConversionFailed of env * constr * constr | MetaOccurInBody of existential_key | InstanceNotSameType of existential_key * env * types * types - | UnifUnivInconsistency + | UnifUnivInconsistency of Univ.univ_inconsistency type pretype_error = (* Old Case *) diff --git a/pretyping/pretype_errors.mli b/pretyping/pretype_errors.mli index 8e98f6307..d9ee969e3 100644 --- a/pretyping/pretype_errors.mli +++ b/pretyping/pretype_errors.mli @@ -22,7 +22,7 @@ type unification_error = | ConversionFailed of env * constr * constr | MetaOccurInBody of existential_key | InstanceNotSameType of existential_key * env * types * types - | UnifUnivInconsistency + | UnifUnivInconsistency of Univ.univ_inconsistency type pretype_error = (** Old Case *) @@ -70,7 +70,7 @@ val error_case_not_inductive_loc : val error_ill_formed_branch_loc : Loc.t -> env -> Evd.evar_map -> - constr -> constructor -> constr -> constr -> 'b + constr -> pconstructor -> constr -> constr -> 'b val error_number_branches_loc : Loc.t -> env -> Evd.evar_map -> diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index c66221e5f..7777de514 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -93,10 +93,10 @@ let ((constr_in : constr -> Dyn.t), (** Miscellaneous interpretation functions *) -let interp_sort = function - | GProp -> Prop Null - | GSet -> Prop Pos - | GType _ -> new_Type_sort () +let interp_sort evd = function + | GProp -> evd, Prop Null + | GSet -> evd, Prop Pos + | GType _ -> new_sort_variable univ_rigid evd let interp_elimination_sort = function | GProp -> InProp @@ -157,7 +157,7 @@ let check_extra_evars_are_solved env initial_sigma sigma = let check_evars_are_solved env initial_sigma sigma = check_typeclasses_instances_are_solved env sigma; - check_problems_are_solved sigma; + check_problems_are_solved env sigma; check_extra_evars_are_solved env initial_sigma sigma (* Try typeclasses, hooks, unification heuristics ... *) @@ -179,21 +179,6 @@ let process_inference_flags flags env initial_sigma (sigma,c) = (* Allow references to syntaxically inexistent variables (i.e., if applied on an inductive) *) let allow_anonymous_refs = ref false -let evd_comb0 f evdref = - let (evd',x) = f !evdref in - evdref := evd'; - x - -let evd_comb1 f evdref x = - let (evd',y) = f !evdref x in - evdref := evd'; - y - -let evd_comb2 f evdref x y = - let (evd',z) = f !evdref x y in - evdref := evd'; - z - (* Utilisé pour inférer le prédicat des Cases *) (* Semble exagérement fort *) (* Faudra préférer une unification entre les types de toutes les clauses *) @@ -236,7 +221,8 @@ let protected_get_type_of env sigma c = (str "Cannot reinterpret " ++ quote (print_constr c) ++ str " in the current environment.") -let pretype_id loc env sigma (lvar,unbndltacvars) id = +let pretype_id loc env evdref (lvar,unbndltacvars) id = + let sigma = !evdref in (* Look for the binder of [id] *) try let (n,_,typ) = lookup_rel_id id (rel_context env) in @@ -257,6 +243,12 @@ let pretype_id loc env sigma (lvar,unbndltacvars) id = (* Check if [id] is a section or goal variable *) try let (_,_,typ) = lookup_named id env in + (* let _ = *) + (* try *) + (* let ctx = Decls.variable_context id in *) + (* evdref := Evd.merge_context_set univ_rigid !evdref ctx; *) + (* with Not_found -> () *) + (* in *) { uj_val = mkVar id; uj_type = typ } with Not_found -> (* [id] not found, standard error message *) @@ -268,18 +260,26 @@ let evar_kind_of_term sigma c = (*************************************************************************) (* Main pretyping function *) -let pretype_ref loc evdref env = function +(* Check with universe list? *) +let pretype_global rigid env evd gr us = Evd.fresh_global ~rigid env evd gr + +let pretype_ref loc evdref env ref us = + match ref with | VarRef id -> (* Section variable *) - (try let (_,_,ty) = lookup_named id env in make_judge (mkVar id) ty + (try let (_,_,ty) = lookup_named id env in + (* let ctx = Decls.variable_context id in *) + (* evdref := Evd.merge_context_set univ_rigid !evdref ctx; *) + make_judge (mkVar id) ty with Not_found -> (* This may happen if env is a goal env and section variables have been cleared - section variables should be different from goal variables *) Pretype_errors.error_var_not_found_loc loc id) | ref -> - let c = constr_of_global ref in - make_judge c (Retyping.get_type_of env Evd.empty c) + let evd, c = pretype_global univ_flexible env !evdref ref us in + evdref := evd; + make_judge c (Retyping.get_type_of env evd c) let pretype_sort evdref = function | GProp -> judge_of_prop @@ -287,27 +287,37 @@ let pretype_sort evdref = function | GType _ -> evd_comb0 judge_of_new_Type evdref let new_type_evar evdref env loc = - evd_comb0 (fun evd -> Evarutil.new_type_evar evd env ~src:(loc,Evar_kinds.InternalHole)) evdref + let e, s = + evd_comb0 (fun evd -> Evarutil.new_type_evar univ_flexible_alg evd env ~src:(loc,Evar_kinds.InternalHole)) evdref + in e + +let get_projection env cst = + let cb = lookup_constant cst env in + match cb.Declarations.const_proj with + | Some {Declarations.proj_ind = mind; proj_npars = n; proj_arg = m; proj_type = ty} -> + (cst,mind,n,m,ty) + | None -> raise Not_found let (f_genarg_interp, genarg_interp_hook) = Hook.make () (* [pretype tycon env evdref lvar lmeta cstr] attempts to type [cstr] *) (* in environment [env], with existential variables [evdref] and *) (* the type constraint tycon *) + let rec pretype resolve_tc (tycon : type_constraint) env evdref lvar t = let inh_conv_coerce_to_tycon = inh_conv_coerce_to_tycon resolve_tc in let pretype_type = pretype_type resolve_tc in let pretype = pretype resolve_tc in match t with - | GRef (loc,ref) -> + | GRef (loc,ref,u) -> inh_conv_coerce_to_tycon loc env evdref - (pretype_ref loc evdref env ref) + (pretype_ref loc evdref env ref u) tycon | GVar (loc, id) -> - inh_conv_coerce_to_tycon loc env evdref - (pretype_id loc env !evdref lvar id) - tycon + inh_conv_coerce_to_tycon loc env evdref + (pretype_id loc env evdref lvar id) + tycon | GEvar (loc, evk, instopt) -> (* Ne faudrait-il pas s'assurer que hyps est bien un @@ -321,12 +331,12 @@ let rec pretype resolve_tc (tycon : type_constraint) env evdref lvar t = inh_conv_coerce_to_tycon loc env evdref j tycon | GPatVar (loc,(someta,n)) -> - let ty = - match tycon with - | Some ty -> ty - | None -> new_type_evar evdref env loc in - let k = Evar_kinds.MatchingVar (someta,n) in - { uj_val = e_new_evar evdref env ~src:(loc,k) ty; uj_type = ty } + let ty = + match tycon with + | Some ty -> ty + | None -> new_type_evar evdref env loc in + let k = Evar_kinds.MatchingVar (someta,n) in + { uj_val = e_new_evar evdref env ~src:(loc,k) ty; uj_type = ty } | GHole (loc, k, None) -> let ty = @@ -348,178 +358,216 @@ let rec pretype resolve_tc (tycon : type_constraint) env evdref lvar t = { uj_val = c; uj_type = ty } | GRec (loc,fixkind,names,bl,lar,vdef) -> - let rec type_bl env ctxt = function - [] -> ctxt - | (na,bk,None,ty)::bl -> - let ty' = pretype_type empty_valcon env evdref lvar ty in - let dcl = (na,None,ty'.utj_val) in - type_bl (push_rel dcl env) (add_rel_decl dcl ctxt) bl - | (na,bk,Some bd,ty)::bl -> - let ty' = pretype_type empty_valcon env evdref lvar ty in - let bd' = pretype (mk_tycon ty'.utj_val) env evdref lvar ty in - let dcl = (na,Some bd'.uj_val,ty'.utj_val) in - type_bl (push_rel dcl env) (add_rel_decl dcl ctxt) bl in - let ctxtv = Array.map (type_bl env empty_rel_context) bl in - let larj = - Array.map2 - (fun e ar -> - pretype_type empty_valcon (push_rel_context e env) evdref lvar ar) - ctxtv lar in - let lara = Array.map (fun a -> a.utj_val) larj in - let ftys = Array.map2 (fun e a -> it_mkProd_or_LetIn a e) ctxtv lara in - let nbfix = Array.length lar in - let names = Array.map (fun id -> Name id) names in - let _ = - match tycon with - | Some t -> - let fixi = match fixkind with - | GFix (vn,i) -> i - | GCoFix i -> i - in e_conv env evdref ftys.(fixi) t - | None -> true - in - (* Note: bodies are not used by push_rec_types, so [||] is safe *) - let newenv = push_rec_types (names,ftys,[||]) env in - let vdefj = - Array.map2_i - (fun i ctxt def -> + let rec type_bl env ctxt = function + [] -> ctxt + | (na,bk,None,ty)::bl -> + let ty' = pretype_type empty_valcon env evdref lvar ty in + let dcl = (na,None,ty'.utj_val) in + type_bl (push_rel dcl env) (add_rel_decl dcl ctxt) bl + | (na,bk,Some bd,ty)::bl -> + let ty' = pretype_type empty_valcon env evdref lvar ty in + let bd' = pretype (mk_tycon ty'.utj_val) env evdref lvar ty in + let dcl = (na,Some bd'.uj_val,ty'.utj_val) in + type_bl (push_rel dcl env) (add_rel_decl dcl ctxt) bl in + let ctxtv = Array.map (type_bl env empty_rel_context) bl in + let larj = + Array.map2 + (fun e ar -> + pretype_type empty_valcon (push_rel_context e env) evdref lvar ar) + ctxtv lar in + let lara = Array.map (fun a -> a.utj_val) larj in + let ftys = Array.map2 (fun e a -> it_mkProd_or_LetIn a e) ctxtv lara in + let nbfix = Array.length lar in + let names = Array.map (fun id -> Name id) names in + let _ = + match tycon with + | Some t -> + let fixi = match fixkind with + | GFix (vn,i) -> i + | GCoFix i -> i + in e_conv env evdref ftys.(fixi) t + | None -> true + in + (* Note: bodies are not used by push_rec_types, so [||] is safe *) + let newenv = push_rec_types (names,ftys,[||]) env in + let vdefj = + Array.map2_i + (fun i ctxt def -> (* we lift nbfix times the type in tycon, because of * the nbfix variables pushed to newenv *) - let (ctxt,ty) = - decompose_prod_n_assum (rel_context_length ctxt) - (lift nbfix ftys.(i)) in - let nenv = push_rel_context ctxt newenv in - let j = pretype (mk_tycon ty) nenv evdref lvar def in - { uj_val = it_mkLambda_or_LetIn j.uj_val ctxt; - uj_type = it_mkProd_or_LetIn j.uj_type ctxt }) - ctxtv vdef in - evar_type_fixpoint loc env evdref names ftys vdefj; - let ftys = Array.map (nf_evar !evdref) ftys in - let fdefs = Array.map (fun x -> nf_evar !evdref (j_val x)) vdefj in - let fixj = match fixkind with - | GFix (vn,i) -> + let (ctxt,ty) = + decompose_prod_n_assum (rel_context_length ctxt) + (lift nbfix ftys.(i)) in + let nenv = push_rel_context ctxt newenv in + let j = pretype (mk_tycon ty) nenv evdref lvar def in + { uj_val = it_mkLambda_or_LetIn j.uj_val ctxt; + uj_type = it_mkProd_or_LetIn j.uj_type ctxt }) + ctxtv vdef in + evar_type_fixpoint loc env evdref names ftys vdefj; + let ftys = Array.map (nf_evar !evdref) ftys in + let fdefs = Array.map (fun x -> nf_evar !evdref (j_val x)) vdefj in + let fixj = match fixkind with + | GFix (vn,i) -> (* First, let's find the guard indexes. *) (* If recursive argument was not given by user, we try all args. An earlier approach was to look only for inductive arguments, but doing it properly involves delta-reduction, and it finally doesn't seem worth the effort (except for huge mutual fixpoints ?) *) - let possible_indexes = - Array.to_list (Array.mapi - (fun i (n,_) -> match n with - | Some n -> [n] - | None -> List.map_i (fun i _ -> i) 0 ctxtv.(i)) - vn) - in - let fixdecls = (names,ftys,fdefs) in - let indexes = search_guard loc env possible_indexes fixdecls in - make_judge (mkFix ((indexes,i),fixdecls)) ftys.(i) - | GCoFix i -> - let cofix = (i,(names,ftys,fdefs)) in - (try check_cofix env cofix - with reraise -> - let e = Errors.push reraise in Loc.raise loc e); - make_judge (mkCoFix cofix) ftys.(i) - in + let possible_indexes = + Array.to_list (Array.mapi + (fun i (n,_) -> match n with + | Some n -> [n] + | None -> List.map_i (fun i _ -> i) 0 ctxtv.(i)) + vn) + in + let fixdecls = (names,ftys,fdefs) in + let indexes = search_guard loc env possible_indexes fixdecls in + make_judge (mkFix ((indexes,i),fixdecls)) ftys.(i) + | GCoFix i -> + let cofix = (i,(names,ftys,fdefs)) in + (try check_cofix env cofix + with reraise -> + let e = Errors.push reraise in Loc.raise loc e); + make_judge (mkCoFix cofix) ftys.(i) + in inh_conv_coerce_to_tycon loc env evdref fixj tycon | GSort (loc,s) -> - let j = pretype_sort evdref s in - inh_conv_coerce_to_tycon loc env evdref j tycon + let j = pretype_sort evdref s in + inh_conv_coerce_to_tycon loc env evdref j tycon + + | GProj (loc, p, arg) -> + let (cst, mind, n, m, ty) = + try get_projection env p + with Not_found -> + user_err_loc (loc,"",str "Not a projection") + in + let mk_ty k = + let ind = + Evarutil.evd_comb1 (Evd.fresh_inductive_instance env) evdref (mind,0) + in + let args = + let ctx = smash_rel_context (Inductiveops.inductive_params_ctxt ind) in + List.fold_right (fun (n, b, ty) (* par *)args -> + let ty = substl args ty in + let ev = e_new_evar evdref env ~src:(loc,k) ty in + ev :: args) ctx [] + (* let j = pretype (mk_tycon ty) env evdref lvar par in *) + (* j.uj_val :: args) ctx pars [] *) + in (ind, List.rev args) + in + let argtycon = + match arg with + (** FIXME ? *) + | GHole (loc, k, _) -> (* Typeclass projection application: + create the necessary type constraint *) + let ind, args = mk_ty k in + mk_tycon (applist (mkIndU ind, args)) + | _ -> empty_tycon + in + let recty = pretype argtycon env evdref lvar arg in + let recty, ((ind,u), pars) = + try + let IndType (indf, _ (*[]*)) = + find_rectype env !evdref recty.uj_type + in recty, dest_ind_family indf + with Not_found -> + (match argtycon with + | Some ty -> assert false + (* let IndType (indf, _) = find_rectype env !evdref ty in *) + (* recty, dest_ind_family indf *) + | None -> + let ind, args = mk_ty Evar_kinds.InternalHole in + let j' = + inh_conv_coerce_to_tycon loc env evdref recty + (mk_tycon (applist (mkIndU ind, args))) in + j', (ind, args)) + in + let usubst = make_inductive_subst (fst (lookup_mind_specif env ind)) u in + let ty = Vars.subst_univs_constr usubst ty in + let ty = substl (recty.uj_val :: List.rev pars) ty in + let j = {uj_val = mkProj (cst,recty.uj_val); uj_type = ty} in + inh_conv_coerce_to_tycon loc env evdref j tycon | GApp (loc,f,args) -> - let fj = pretype empty_tycon env evdref lvar f in - let floc = loc_of_glob_constr f in - let length = List.length args in - let candargs = + let fj = pretype empty_tycon env evdref lvar f in + let floc = loc_of_glob_constr f in + let length = List.length args in + let candargs = (* Bidirectional typechecking hint: parameters of a constructor are completely determined by a typing constraint *) - if Flags.is_program_mode () && length > 0 && isConstruct fj.uj_val then - match tycon with - | None -> [] - | Some ty -> - let (ind, i) = destConstruct fj.uj_val in - let npars = inductive_nparams ind in - if Int.equal npars 0 then [] - else - try - (* Does not treat partially applied constructors. *) - let ty = evd_comb1 (Coercion.inh_coerce_to_prod loc env) evdref ty in - let IndType (indf, args) = find_rectype env !evdref ty in - let (ind',pars) = dest_ind_family indf in - if eq_ind ind ind' then pars - else (* Let the usual code throw an error *) [] - with Not_found -> [] - else [] - in - let rec apply_rec env n resj candargs = function - | [] -> resj - | c::rest -> - let argloc = loc_of_glob_constr c in - let resj = evd_comb1 (Coercion.inh_app_fun resolve_tc env) evdref resj in - let resty = whd_betadeltaiota env !evdref resj.uj_type in - match kind_of_term resty with - | Prod (na,c1,c2) -> - let hj = pretype (mk_tycon c1) env evdref lvar c in - let candargs, ujval = - match candargs with - | [] -> [], j_val hj - | arg :: args -> - if e_conv env evdref (j_val hj) arg then - args, nf_evar !evdref (j_val hj) - else [], j_val hj - in - let value, typ = applist (j_val resj, [ujval]), subst1 ujval c2 in - apply_rec env (n+1) - { uj_val = value; - uj_type = typ } - candargs rest - - | _ -> - let hj = pretype empty_tycon env evdref lvar c in - error_cant_apply_not_functional_loc - (Loc.merge floc argloc) env !evdref - resj [hj] - in - let resj = apply_rec env 1 fj candargs args in - let resj = - match evar_kind_of_term !evdref resj.uj_val with - | App (f,args) -> - let f = whd_evar !evdref f in - begin match kind_of_term f with - | Ind _ | Const _ - when isInd f || has_polymorphic_type (destConst f) - -> - let sigma = !evdref in - let c = mkApp (f,Array.map (whd_evar sigma) args) in - let t = Retyping.get_type_of env sigma c in - make_judge c (* use this for keeping evars: resj.uj_val *) t - | _ -> resj end - | _ -> resj in - inh_conv_coerce_to_tycon loc env evdref resj tycon + if Flags.is_program_mode () && length > 0 && isConstruct fj.uj_val then + match tycon with + | None -> [] + | Some ty -> + let ((ind, i), u) = destConstruct fj.uj_val in + let npars = inductive_nparams ind in + if Int.equal npars 0 then [] + else + try + let ty = evd_comb1 (Coercion.inh_coerce_to_prod loc env) evdref ty in + let IndType (indf, args) = find_rectype env !evdref ty in + let ((ind',u'),pars) = dest_ind_family indf in + if eq_ind ind ind' then pars + else (* Let the usual code throw an error *) [] + with Not_found -> [] + else [] + in + let rec apply_rec env n resj candargs = function + | [] -> resj + | c::rest -> + let argloc = loc_of_glob_constr c in + let resj = evd_comb1 (Coercion.inh_app_fun resolve_tc env) evdref resj in + let resty = whd_betadeltaiota env !evdref resj.uj_type in + match kind_of_term resty with + | Prod (na,c1,c2) -> + let hj = pretype (mk_tycon c1) env evdref lvar c in + let candargs, ujval = + match candargs with + | [] -> [], j_val hj + | arg :: args -> + if e_conv env evdref (j_val hj) arg then + args, nf_evar !evdref (j_val hj) + else [], j_val hj + in + let value, typ = applist (j_val resj, [ujval]), subst1 ujval c2 in + apply_rec env (n+1) + { uj_val = value; + uj_type = typ } + candargs rest + + | _ -> + let hj = pretype empty_tycon env evdref lvar c in + error_cant_apply_not_functional_loc + (Loc.merge floc argloc) env !evdref + resj [hj] + in + let resj = apply_rec env 1 fj candargs args in + inh_conv_coerce_to_tycon loc env evdref resj tycon | GLambda(loc,name,bk,c1,c2) -> - let tycon' = evd_comb1 - (fun evd tycon -> - match tycon with - | None -> evd, tycon - | Some ty -> - let evd, ty' = Coercion.inh_coerce_to_prod loc env evd ty in - evd, Some ty') - evdref tycon - in - let (name',dom,rng) = evd_comb1 (split_tycon loc env) evdref tycon' in - let dom_valcon = valcon_of_tycon dom in - let j = pretype_type dom_valcon env evdref lvar c1 in - let var = (name,None,j.utj_val) in - let j' = pretype rng (push_rel var env) evdref lvar c2 in - let resj = judge_of_abstraction env (orelse_name name name') j j' in - inh_conv_coerce_to_tycon loc env evdref resj tycon + let tycon' = evd_comb1 + (fun evd tycon -> + match tycon with + | None -> evd, tycon + | Some ty -> + let evd, ty' = Coercion.inh_coerce_to_prod loc env evd ty in + evd, Some ty') + evdref tycon + in + let (name',dom,rng) = evd_comb1 (split_tycon loc env) evdref tycon' in + let dom_valcon = valcon_of_tycon dom in + let j = pretype_type dom_valcon env evdref lvar c1 in + let var = (name,None,j.utj_val) in + let j' = pretype rng (push_rel var env) evdref lvar c2 in + let resj = judge_of_abstraction env (orelse_name name name') j j' in + inh_conv_coerce_to_tycon loc env evdref resj tycon | GProd(loc,name,bk,c1,c2) -> - let j = pretype_type empty_valcon env evdref lvar c1 in - let j' = match name with + let j = pretype_type empty_valcon env evdref lvar c1 in + let j' = match name with | Anonymous -> let j = pretype_type empty_valcon env evdref lvar c2 in { j with utj_val = lift 1 j.utj_val } @@ -527,212 +575,208 @@ let rec pretype resolve_tc (tycon : type_constraint) env evdref lvar t = let var = (name,j.utj_val) in let env' = push_rel_assum var env in pretype_type empty_valcon env' evdref lvar c2 - in - let resj = - try judge_of_product env name j j' - with TypeError _ as e -> let e = Errors.push e in Loc.raise loc e in - inh_conv_coerce_to_tycon loc env evdref resj tycon + in + let resj = + try judge_of_product env name j j' + with TypeError _ as e -> let e = Errors.push e in Loc.raise loc e in + inh_conv_coerce_to_tycon loc env evdref resj tycon | GLetIn(loc,name,c1,c2) -> - let j = - match c1 with - | GCast (loc, c, CastConv t) -> - let tj = pretype_type empty_valcon env evdref lvar t in - pretype (mk_tycon tj.utj_val) env evdref lvar c - | _ -> pretype empty_tycon env evdref lvar c1 - in - let t = refresh_universes j.uj_type in - let var = (name,Some j.uj_val,t) in - let tycon = lift_tycon 1 tycon in - let j' = pretype tycon (push_rel var env) evdref lvar c2 in - { uj_val = mkLetIn (name, j.uj_val, t, j'.uj_val) ; - uj_type = subst1 j.uj_val j'.uj_type } + let j = + match c1 with + | GCast (loc, c, CastConv t) -> + let tj = pretype_type empty_valcon env evdref lvar t in + pretype (mk_tycon tj.utj_val) env evdref lvar c + | _ -> pretype empty_tycon env evdref lvar c1 + in + let t = j.uj_type in + let var = (name,Some j.uj_val,t) in + let tycon = lift_tycon 1 tycon in + let j' = pretype tycon (push_rel var env) evdref lvar c2 in + { uj_val = mkLetIn (name, j.uj_val, t, j'.uj_val) ; + uj_type = subst1 j.uj_val j'.uj_type } | GLetTuple (loc,nal,(na,po),c,d) -> - let cj = pretype empty_tycon env evdref lvar c in - let (IndType (indf,realargs)) = - try find_rectype env !evdref cj.uj_type - with Not_found -> - let cloc = loc_of_glob_constr c in - error_case_not_inductive_loc cloc env !evdref cj - in - let cstrs = get_constructors env indf in - if not (Int.equal (Array.length cstrs) 1) then - user_err_loc (loc,"",str "Destructing let is only for inductive types" ++ - str " with one constructor."); - let cs = cstrs.(0) in - if not (Int.equal (List.length nal) cs.cs_nargs) then - user_err_loc (loc,"", str "Destructing let on this type expects " ++ - int cs.cs_nargs ++ str " variables."); - let fsign = List.map2 (fun na (_,c,t) -> (na,c,t)) - (List.rev nal) cs.cs_args in - let env_f = push_rel_context fsign env in - (* Make dependencies from arity signature impossible *) - let arsgn = - let arsgn,_ = get_arity env indf in - if not !allow_anonymous_refs then - List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn - else arsgn - in - let psign = (na,None,build_dependent_inductive env indf)::arsgn in - let nar = List.length arsgn in - (match po with - | Some p -> - let env_p = push_rel_context psign env in - let pj = pretype_type empty_valcon env_p evdref lvar p in - let ccl = nf_evar !evdref pj.utj_val in - let psign = make_arity_signature env true indf in (* with names *) - let p = it_mkLambda_or_LetIn ccl psign in - let inst = - (Array.to_list cs.cs_concl_realargs) - @[build_dependent_constructor cs] in - let lp = lift cs.cs_nargs p in - let fty = hnf_lam_applist env !evdref lp inst in - let fj = pretype (mk_tycon fty) env_f evdref lvar d in - let f = it_mkLambda_or_LetIn fj.uj_val fsign in - let v = - let ind,_ = dest_ind_family indf in - let ci = make_case_info env ind LetStyle in - Typing.check_allowed_sort env !evdref ind cj.uj_val p; - mkCase (ci, p, cj.uj_val,[|f|]) in - { uj_val = v; uj_type = substl (realargs@[cj.uj_val]) ccl } - - | None -> - let tycon = lift_tycon cs.cs_nargs tycon in - let fj = pretype tycon env_f evdref lvar d in - let f = it_mkLambda_or_LetIn fj.uj_val fsign in - let ccl = nf_evar !evdref fj.uj_type in - let ccl = - if noccur_between 1 cs.cs_nargs ccl then - lift (- cs.cs_nargs) ccl - else - error_cant_find_case_type_loc loc env !evdref - cj.uj_val in - let ccl = refresh_universes ccl in - let p = it_mkLambda_or_LetIn (lift (nar+1) ccl) psign in - let v = - let ind,_ = dest_ind_family indf in - let ci = make_case_info env ind LetStyle in - Typing.check_allowed_sort env !evdref ind cj.uj_val p; - mkCase (ci, p, cj.uj_val,[|f|]) - in { uj_val = v; uj_type = ccl }) - - | GIf (loc,c,(na,po),b1,b2) -> - let cj = pretype empty_tycon env evdref lvar c in - let (IndType (indf,realargs)) = - try find_rectype env !evdref cj.uj_type - with Not_found -> - let cloc = loc_of_glob_constr c in - error_case_not_inductive_loc cloc env !evdref cj in - let cstrs = get_constructors env indf in - if not (Int.equal (Array.length cstrs) 2) then - user_err_loc (loc,"", - str "If is only for inductive types with two constructors."); - + let cj = pretype empty_tycon env evdref lvar c in + let (IndType (indf,realargs)) = + try find_rectype env !evdref cj.uj_type + with Not_found -> + let cloc = loc_of_glob_constr c in + error_case_not_inductive_loc cloc env !evdref cj + in + let cstrs = get_constructors env indf in + if not (Int.equal (Array.length cstrs) 1) then + user_err_loc (loc,"",str "Destructing let is only for inductive types" ++ + str " with one constructor."); + let cs = cstrs.(0) in + if not (Int.equal (List.length nal) cs.cs_nargs) then + user_err_loc (loc,"", str "Destructing let on this type expects " ++ + int cs.cs_nargs ++ str " variables."); + let fsign = List.map2 (fun na (_,c,t) -> (na,c,t)) + (List.rev nal) cs.cs_args in + let env_f = push_rel_context fsign env in + (* Make dependencies from arity signature impossible *) let arsgn = let arsgn,_ = get_arity env indf in if not !allow_anonymous_refs then - (* Make dependencies from arity signature impossible *) List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn else arsgn in - let nar = List.length arsgn in let psign = (na,None,build_dependent_inductive env indf)::arsgn in - let pred,p = match po with + let nar = List.length arsgn in + (match po with | Some p -> - let env_p = push_rel_context psign env in - let pj = pretype_type empty_valcon env_p evdref lvar p in - let ccl = nf_evar !evdref pj.utj_val in - let pred = it_mkLambda_or_LetIn ccl psign in - let typ = lift (- nar) (beta_applist (pred,[cj.uj_val])) in - pred, typ + let env_p = push_rel_context psign env in + let pj = pretype_type empty_valcon env_p evdref lvar p in + let ccl = nf_evar !evdref pj.utj_val in + let psign = make_arity_signature env true indf in (* with names *) + let p = it_mkLambda_or_LetIn ccl psign in + let inst = + (Array.to_list cs.cs_concl_realargs) + @[build_dependent_constructor cs] in + let lp = lift cs.cs_nargs p in + let fty = hnf_lam_applist env !evdref lp inst in + let fj = pretype (mk_tycon fty) env_f evdref lvar d in + let f = it_mkLambda_or_LetIn fj.uj_val fsign in + let v = + let ind,_ = dest_ind_family indf in + let ci = make_case_info env (fst ind) LetStyle in + Typing.check_allowed_sort env !evdref ind cj.uj_val p; + mkCase (ci, p, cj.uj_val,[|f|]) in + { uj_val = v; uj_type = substl (realargs@[cj.uj_val]) ccl } + | None -> - let p = match tycon with - | Some ty -> ty - | None -> new_type_evar evdref env loc - in - it_mkLambda_or_LetIn (lift (nar+1) p) psign, p in - let pred = nf_evar !evdref pred in - let p = nf_evar !evdref p in - let f cs b = - let n = rel_context_length cs.cs_args in - let pi = lift n pred in (* liftn n 2 pred ? *) - let pi = beta_applist (pi, [build_dependent_constructor cs]) in - let csgn = - if not !allow_anonymous_refs then - List.map (fun (_,b,t) -> (Anonymous,b,t)) cs.cs_args - else - List.map - (fun (n, b, t) -> - match n with - Name _ -> (n, b, t) - | Anonymous -> (Name (Id.of_string "H"), b, t)) - cs.cs_args + let tycon = lift_tycon cs.cs_nargs tycon in + let fj = pretype tycon env_f evdref lvar d in + let f = it_mkLambda_or_LetIn fj.uj_val fsign in + let ccl = nf_evar !evdref fj.uj_type in + let ccl = + if noccur_between 1 cs.cs_nargs ccl then + lift (- cs.cs_nargs) ccl + else + error_cant_find_case_type_loc loc env !evdref + cj.uj_val in + (* let ccl = refresh_universes ccl in *) + let p = it_mkLambda_or_LetIn (lift (nar+1) ccl) psign in + let v = + let ind,_ = dest_ind_family indf in + let ci = make_case_info env (fst ind) LetStyle in + Typing.check_allowed_sort env !evdref ind cj.uj_val p; + mkCase (ci, p, cj.uj_val,[|f|]) + in { uj_val = v; uj_type = ccl }) + + | GIf (loc,c,(na,po),b1,b2) -> + let cj = pretype empty_tycon env evdref lvar c in + let (IndType (indf,realargs)) = + try find_rectype env !evdref cj.uj_type + with Not_found -> + let cloc = loc_of_glob_constr c in + error_case_not_inductive_loc cloc env !evdref cj in + let cstrs = get_constructors env indf in + if not (Int.equal (Array.length cstrs) 2) then + user_err_loc (loc,"", + str "If is only for inductive types with two constructors."); + + let arsgn = + let arsgn,_ = get_arity env indf in + if not !allow_anonymous_refs then + (* Make dependencies from arity signature impossible *) + List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn + else arsgn + in + let nar = List.length arsgn in + let psign = (na,None,build_dependent_inductive env indf)::arsgn in + let pred,p = match po with + | Some p -> + let env_p = push_rel_context psign env in + let pj = pretype_type empty_valcon env_p evdref lvar p in + let ccl = nf_evar !evdref pj.utj_val in + let pred = it_mkLambda_or_LetIn ccl psign in + let typ = lift (- nar) (beta_applist (pred,[cj.uj_val])) in + pred, typ + | None -> + let p = match tycon with + | Some ty -> ty + | None -> new_type_evar evdref env loc in - let env_c = push_rel_context csgn env in - let bj = pretype (mk_tycon pi) env_c evdref lvar b in - it_mkLambda_or_LetIn bj.uj_val cs.cs_args in - let b1 = f cstrs.(0) b1 in - let b2 = f cstrs.(1) b2 in - let v = - let ind,_ = dest_ind_family indf in - let ci = make_case_info env ind IfStyle in - let pred = nf_evar !evdref pred in - Typing.check_allowed_sort env !evdref ind cj.uj_val pred; - mkCase (ci, pred, cj.uj_val, [|b1;b2|]) + it_mkLambda_or_LetIn (lift (nar+1) p) psign, p in + let pred = nf_evar !evdref pred in + let p = nf_evar !evdref p in + let f cs b = + let n = rel_context_length cs.cs_args in + let pi = lift n pred in (* liftn n 2 pred ? *) + let pi = beta_applist (pi, [build_dependent_constructor cs]) in + let csgn = + if not !allow_anonymous_refs then + List.map (fun (_,b,t) -> (Anonymous,b,t)) cs.cs_args + else + List.map + (fun (n, b, t) -> + match n with + Name _ -> (n, b, t) + | Anonymous -> (Name (Id.of_string "H"), b, t)) + cs.cs_args in - { uj_val = v; uj_type = p } + let env_c = push_rel_context csgn env in + let bj = pretype (mk_tycon pi) env_c evdref lvar b in + it_mkLambda_or_LetIn bj.uj_val cs.cs_args in + let b1 = f cstrs.(0) b1 in + let b2 = f cstrs.(1) b2 in + let v = + let ind,_ = dest_ind_family indf in + let ci = make_case_info env (fst ind) IfStyle in + let pred = nf_evar !evdref pred in + Typing.check_allowed_sort env !evdref ind cj.uj_val pred; + mkCase (ci, pred, cj.uj_val, [|b1;b2|]) + in + { uj_val = v; uj_type = p } | GCases (loc,sty,po,tml,eqns) -> - Cases.compile_cases loc sty - ((fun vtyc env evdref -> pretype vtyc env evdref lvar),evdref) - tycon env (* loc *) (po,tml,eqns) + Cases.compile_cases loc sty + ((fun vtyc env evdref -> pretype vtyc env evdref lvar),evdref) + tycon env (* loc *) (po,tml,eqns) | GCast (loc,c,k) -> - let cj = - match k with - | CastCoerce -> - let cj = pretype empty_tycon env evdref lvar c in - evd_comb1 (Coercion.inh_coerce_to_base loc env) evdref cj - | CastConv t | CastVM t | CastNative t -> - let k = (match k with CastVM _ -> VMcast | CastNative _ -> NATIVEcast | _ -> DEFAULTcast) in - let tj = pretype_type empty_valcon env evdref lvar t in - let tval = nf_evar !evdref tj.utj_val in - let cj = match k with - | VMcast -> - let cj = pretype empty_tycon env evdref lvar c in - let cty = nf_evar !evdref cj.uj_type and tval = nf_evar !evdref tj.utj_val in - if not (occur_existential cty || occur_existential tval) then - begin - try - ignore (Reduction.vm_conv Reduction.CUMUL env cty tval); cj - with Reduction.NotConvertible -> - error_actual_type_loc loc env !evdref cj tval - (ConversionFailed (env,cty,tval)) - end - else user_err_loc (loc,"",str "Cannot check cast with vm: " ++ - str "unresolved arguments remain.") - | NATIVEcast -> - let cj = pretype empty_tycon env evdref lvar c in - let cty = nf_evar !evdref cj.uj_type and - tval = nf_evar !evdref tj.utj_val in - let evars = Nativenorm.evars_of_evar_map !evdref in - begin - try - ignore - (Nativeconv.native_conv Reduction.CUMUL evars env cty tval); - cj - with Reduction.NotConvertible -> - error_actual_type_loc loc env !evdref cj tval + let cj = + match k with + | CastCoerce -> + let cj = pretype empty_tycon env evdref lvar c in + evd_comb1 (Coercion.inh_coerce_to_base loc env) evdref cj + | CastConv t | CastVM t | CastNative t -> + let k = (match k with CastVM _ -> VMcast | CastNative _ -> NATIVEcast | _ -> DEFAULTcast) in + let tj = pretype_type empty_valcon env evdref lvar t in + let tval = nf_evar !evdref tj.utj_val in + let cj = match k with + | VMcast -> + let cj = pretype empty_tycon env evdref lvar c in + let cty = nf_evar !evdref cj.uj_type and tval = nf_evar !evdref tj.utj_val in + if not (occur_existential cty || occur_existential tval) then + begin + try + ignore (Reduction.vm_conv Reduction.CUMUL env cty tval); cj + with Reduction.NotConvertible -> + error_actual_type_loc loc env !evdref cj tval + (ConversionFailed (env,cty,tval)) + end + else user_err_loc (loc,"",str "Cannot check cast with vm: " ++ + str "unresolved arguments remain.") + | NATIVEcast -> + let cj = pretype empty_tycon env evdref lvar c in + let cty = nf_evar !evdref cj.uj_type and tval = nf_evar !evdref tj.utj_val in + let evars = Nativenorm.evars_of_evar_map !evdref in + begin + try + ignore (Nativeconv.native_conv Reduction.CUMUL evars env cty tval); cj + with Reduction.NotConvertible -> + error_actual_type_loc loc env !evdref cj tval (ConversionFailed (env,cty,tval)) - end - - | _ -> - pretype (mk_tycon tval) env evdref lvar c - in - let v = mkCast (cj.uj_val, k, tval) in - { uj_val = v; uj_type = tval } - in inh_conv_coerce_to_tycon loc env evdref cj tycon + end + | _ -> + pretype (mk_tycon tval) env evdref lvar c + in + let v = mkCast (cj.uj_val, k, tval) in + { uj_val = v; uj_type = tval } + in inh_conv_coerce_to_tycon loc env evdref cj tycon (* [pretype_type valcon env evdref lvar c] coerces [c] into a type *) and pretype_type resolve_tc valcon env evdref lvar = function @@ -751,7 +795,7 @@ and pretype_type resolve_tc valcon env evdref lvar = function { utj_val = v; utj_type = s } | None -> - let s = evd_comb0 new_sort_variable evdref in + let s = evd_comb0 (new_sort_variable univ_flexible_alg) evdref in { utj_val = e_new_evar evdref env ~src:(loc, knd) (mkSort s); utj_type = s}) | c -> @@ -778,11 +822,6 @@ let ise_pretype_gen flags sigma env lvar kind c = in process_inference_flags flags env sigma (!evdref,c') -(* TODO: comment faire remonter l'information si le typage a resolu des - variables du sigma original. il faudrait que la fonction de typage - retourne aussi le nouveau sigma... -*) - let default_inference_flags fail = { use_typeclasses = true; use_unif_heuristics = true; @@ -810,8 +849,10 @@ let on_judgment f j = let understand_judgment sigma env c = let evdref = ref sigma in let j = pretype true empty_tycon env evdref empty_lvar c in - on_judgment (fun c -> - snd (process_inference_flags all_and_fail_flags env sigma (!evdref,c))) j + let j = on_judgment (fun c -> + let evd, c = process_inference_flags all_and_fail_flags env sigma (!evdref,c) in + evdref := evd; c) j + in j, Evd.evar_universe_context !evdref let understand_judgment_tcc evdref env c = let j = pretype true empty_tycon env evdref empty_lvar c in @@ -819,13 +860,18 @@ let understand_judgment_tcc evdref env c = let (evd,c) = process_inference_flags all_no_fail_flags env Evd.empty (!evdref,c) in evdref := evd; c) j +let ise_pretype_gen_ctx flags sigma env lvar kind c = + let evd, c = ise_pretype_gen flags sigma env lvar kind c in + let evd, f = Evarutil.nf_evars_and_universes evd in + f c, Evd.get_universe_context_set evd + (** Entry points of the high-level type synthesis algorithm *) let understand ?(flags=all_and_fail_flags) ?(expected_type=WithoutTypeConstraint) sigma env c = - snd (ise_pretype_gen flags sigma env empty_lvar expected_type c) + ise_pretype_gen_ctx flags sigma env empty_lvar expected_type c let understand_tcc ?(flags=all_no_fail_flags) sigma env ?(expected_type=WithoutTypeConstraint) c = ise_pretype_gen flags sigma env empty_lvar expected_type c diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli index ec8aae140..79b051845 100644 --- a/pretyping/pretyping.mli +++ b/pretyping/pretyping.mli @@ -81,14 +81,16 @@ val understand_ltac : inference_flags -> (** Standard call to get a constr from a glob_constr, resolving implicit args *) val understand : ?flags:inference_flags -> ?expected_type:typing_constraint -> - evar_map -> env -> glob_constr -> constr + evar_map -> env -> glob_constr -> constr Univ.in_universe_context_set (** Idem but returns the judgment of the understood term *) -val understand_judgment : evar_map -> env -> glob_constr -> unsafe_judgment +val understand_judgment : evar_map -> env -> + glob_constr -> unsafe_judgment Evd.in_evar_universe_context (** Idem but do not fail on unresolved evars *) -val understand_judgment_tcc : evar_map ref -> env -> glob_constr -> unsafe_judgment +val understand_judgment_tcc : evar_map ref -> env -> + glob_constr -> unsafe_judgment (** Trying to solve remaining evars and remaining conversion problems with type classes, heuristics, and possibly an external solver *) @@ -122,7 +124,7 @@ val ise_pretype_gen : val constr_in : constr -> Dyn.t val constr_out : Dyn.t -> constr -val interp_sort : glob_sort -> sorts +val interp_sort : evar_map -> glob_sort -> evar_map * sorts val interp_elimination_sort : glob_sort -> sorts_family val genarg_interp_hook : diff --git a/pretyping/program.ml b/pretyping/program.ml index 6d913060b..67bb3bd2a 100644 --- a/pretyping/program.ml +++ b/pretyping/program.ml @@ -21,7 +21,7 @@ let find_reference locstr dir s = anomaly ~label:locstr (Pp.str "cannot find" ++ spc () ++ Libnames.pr_path sp) let coq_reference locstr dir s = find_reference locstr ("Coq"::dir) s -let coq_constant locstr dir s = Globnames.constr_of_global (coq_reference locstr dir s) +let coq_constant locstr dir s = Universes.constr_of_global (coq_reference locstr dir s) let init_constant dir s () = coq_constant "Program" dir s let init_reference dir s () = coq_reference "Program" dir s diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index 9f8ba956a..967583a2b 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -63,12 +63,12 @@ let cache_structure o = load_structure 1 o let subst_structure (subst,((kn,i),id,kl,projs as obj)) = - let kn' = subst_ind subst kn in + let kn' = subst_mind subst kn in let projs' = (* invariant: struc.s_PROJ is an evaluable reference. Thus we can take *) (* the first component of subst_con. *) List.smartmap - (Option.smartmap (fun kn -> fst (subst_con subst kn))) + (Option.smartmap (fun kn -> fst (subst_con_kn subst kn))) projs in let id' = fst (subst_constructor subst id) in @@ -132,6 +132,7 @@ that maps the pair (Li,ci) to the following data type obj_typ = { o_DEF : constr; + o_CTX : Univ.ContextSet.t; o_INJ : int; (* position of trivial argument (negative= none) *) o_TABS : constr list; (* ordered *) o_TPARAMS : constr list; (* ordered *) @@ -189,9 +190,13 @@ let cs_pattern_of_constr t = (* Intended to always succeed *) let compute_canonical_projections (con,ind) = - let v = mkConst con in - let c = Environ.constant_value (Global.env()) con in - let lt,t = Reductionops.splay_lam (Global.env()) Evd.empty c in + let env = Global.env () in + let ctx = Environ.constant_context env con in + let u = Univ.UContext.instance ctx in + let v = (mkConstU (con,u)) in + let ctx = Univ.ContextSet.of_context ctx in + let c = Environ.constant_value_in env (con,u) in + let lt,t = Reductionops.splay_lam env Evd.empty c in let lt = List.rev_map snd lt in let args = snd (decompose_app t) in let { s_EXPECTEDPARAM = p; s_PROJ = lpj; s_PROJKIND = kl } = @@ -221,7 +226,7 @@ let compute_canonical_projections (con,ind) = [] lps in List.map (fun (refi,c,inj,argj) -> (refi,c), - {o_DEF=v; o_INJ=inj; o_TABS=lt; + {o_DEF=v; o_CTX=ctx; o_INJ=inj; o_TABS=lt; o_TPARAMS=params; o_NPARAMS=List.length params; o_TCOMPS=argj}) comp @@ -256,8 +261,8 @@ let cache_canonical_structure o = let subst_canonical_structure (subst,(cst,ind as obj)) = (* invariant: cst is an evaluable reference. Thus we can take *) (* the first component of subst_con. *) - let cst' = fst (subst_con subst cst) in - let ind' = Inductiveops.subst_inductive subst ind in + let cst' = subst_constant subst cst in + let ind' = subst_ind subst ind in if cst' == cst && ind' == ind then obj else (cst',ind') let discharge_canonical_structure (_,(cst,ind)) = @@ -282,7 +287,9 @@ let error_not_structure ref = let check_and_decompose_canonical_structure ref = let sp = match ref with ConstRef sp -> sp | _ -> error_not_structure ref in let env = Global.env () in - let vc = match Environ.constant_opt_value env sp with + let ctx = Environ.constant_context env sp in + let u = Univ.UContext.instance ctx in + let vc = match Environ.constant_opt_value_in env (sp, u) with | Some vc -> vc | None -> error_not_structure ref in let body = snd (splay_lam (Global.env()) Evd.empty vc) in @@ -290,7 +297,7 @@ let check_and_decompose_canonical_structure ref = | App (f,args) -> f,args | _ -> error_not_structure ref in let indsp = match kind_of_term f with - | Construct (indsp,1) -> indsp + | Construct ((indsp,1),u) -> indsp | _ -> error_not_structure ref in let s = try lookup_structure indsp with Not_found -> error_not_structure ref in let ntrue_projs = List.length (List.filter (fun (_, x) -> x) s.s_PROJKIND) in @@ -304,6 +311,9 @@ let declare_canonical_structure ref = let lookup_canonical_conversion (proj,pat) = List.assoc_f eq_cs_pattern pat (Refmap.find proj !object_table) + (* let cst, u' = destConst cs.o_DEF in *) + (* { cs with o_DEF = mkConstU (cst, u) } *) + let is_open_canonical_projection env sigma (c,args) = try let n = find_projection_nparams (global_of_constr c) in diff --git a/pretyping/recordops.mli b/pretyping/recordops.mli index 42663c014..b1763a359 100644 --- a/pretyping/recordops.mli +++ b/pretyping/recordops.mli @@ -56,6 +56,7 @@ type cs_pattern = type obj_typ = { o_DEF : constr; + o_CTX : Univ.ContextSet.t; o_INJ : int; (** position of trivial argument *) o_TABS : constr list; (** ordered *) o_TPARAMS : constr list; (** ordered *) diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 0b6c3197d..676fc4f3a 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -61,7 +61,7 @@ module ReductionBehaviour = struct let discharge = function | _,(ReqGlobal (ConstRef c, req), (_, b)) -> let c' = pop_con c in - let vars = Lib.section_segment_of_constant c in + let vars, _ctx = Lib.section_segment_of_constant c in let extra = List.length vars in let nargs' = if b.b_nargs < 0 then b.b_nargs else b.b_nargs + extra in let recargs' = List.map ((+) extra) b.b_recargs in @@ -142,6 +142,7 @@ sig type 'a member = | App of 'a app_node | Case of case_info * 'a * 'a array * ('a * 'a list) option + | Proj of int * int * projection | Fix of fixpoint * 'a t * ('a * 'a list) option | Shift of int | Update of 'a @@ -186,6 +187,7 @@ struct type 'a member = | App of 'a app_node | Case of Term.case_info * 'a * 'a array * ('a * 'a list) option + | Proj of int * int * projection | Fix of fixpoint * 'a t * ('a * 'a list) option | Shift of int | Update of 'a @@ -200,6 +202,9 @@ struct str "ZCase(" ++ prvect_with_sep (pr_bar) pr_c br ++ str ")" + | Proj (n,m,p) -> + str "ZProj(" ++ int n ++ pr_comma () ++ int m ++ + pr_comma () ++ pr_con p ++ str ")" | Fix (f,args,cst) -> str "ZFix(" ++ Termops.pr_fix Termops.print_constr f ++ pr_comma () ++ pr pr_c args ++ str ")" @@ -261,6 +266,8 @@ struct | (_, App (i,_,j)::s2) -> compare_rec (bal - j - 1 + i) stk1 s2 | (Case(c1,_,_,_)::s1, Case(c2,_,_,_)::s2) -> Int.equal bal 0 (* && c1.ci_ind = c2.ci_ind *) && compare_rec 0 s1 s2 + | (Proj (n1,m1,p)::s1, Proj(n2,m2,p2)::s2) -> + Int.equal bal 0 && compare_rec 0 s1 s2 | (Fix(_,a1,_)::s1, Fix(_,a2,_)::s2) -> Int.equal bal 0 && compare_rec 0 a1 a2 && compare_rec 0 s1 s2 | (_,_) -> false in @@ -284,6 +291,9 @@ struct aux (fold_array (f o (Vars.lift lft1 t1) (Vars.lift lft2 t2)) a1 a2) lft1 q1 lft2 q2 + | Proj (n1,m1,p1) :: q1, Proj (n2,m2,p2) :: q2 -> + (* MS: FIXME: unsure *) + aux o lft1 q1 lft2 q2 | Fix ((_,(_,a1,b1)),s1,_) :: q1, Fix ((_,(_,a2,b2)),s2,_) :: q2 -> let (o',_,_) = aux (fold_array (fold_array o b1 b2) a1 a2) lft1 s1 lft2 s2 in @@ -323,7 +333,7 @@ struct in aux n [] s let not_purely_applicative args = - List.exists (function (Fix _ | Case _) -> true | _ -> false) args + List.exists (function (Fix _ | Case _ | Proj _) -> true | _ -> false) args let list_of_app_stack s = let rec aux = function | App (i,a,j) :: s -> @@ -379,6 +389,7 @@ struct | f, (Fix (fix,st,_)::s) -> zip ~refold (mkFix fix, st @ (append_app [|f|] s)) | f, (Shift n::s) -> zip ~refold (lift n f, s) + | f, (Proj (n,m,p)::s) -> zip ~refold (mkProj (p,f),s) | _ -> assert false end @@ -388,6 +399,7 @@ type state = constr * constr Stack.t type contextual_reduction_function = env -> evar_map -> constr -> constr type reduction_function = contextual_reduction_function type local_reduction_function = evar_map -> constr -> constr +type e_reduction_function = env -> evar_map -> constr -> evar_map * constr type contextual_stack_reduction_function = env -> evar_map -> constr -> constr * constr list @@ -527,9 +539,17 @@ let magicaly_constant_of_fixbody env bd = function try let cst = Nametab.locate_constant (Libnames.make_qualid DirPath.empty id) in - match constant_opt_value env cst with + let (cst, u), ctx = Universes.fresh_constant_instance env cst in + match constant_opt_value env (cst,u) with | None -> bd - | Some t -> if eq_constr t bd then mkConst cst else bd + | Some (t,cstrs) -> + let b, csts = eq_constr_universes t bd in + let subst = UniverseConstraints.fold (fun (l,d,r) acc -> + Univ.LMap.add (Option.get (Universe.level l)) (Option.get (Universe.level r)) acc) + csts Univ.LMap.empty + in + let inst = Instance.subst_fn (fun u -> Univ.LMap.find u subst) u in + if b then mkConstU (cst,inst) else bd with | Not_found -> bd @@ -550,7 +570,7 @@ let contract_cofix ?env (bodynum,(names,types,bodies as typedbodies)) cst = let reduce_mind_case mia = match kind_of_term mia.mconstr with - | Construct (ind_sp,i) -> + | Construct ((ind_sp,i),u) -> (* let ncargs = (fst mia.mci).(i-1) in*) let real_cargs = List.skipn mia.mci.ci_npar mia.mcargs in applist (mia.mlf.(i-1),real_cargs) @@ -585,6 +605,10 @@ let fix_recarg ((recindices,bodynum),_) stack = with Not_found -> None +type 'a reduced_state = + | NotReducible + | Reduced of constr + (** Generic reduction function with environment Here is where unfolded constant are stored in order to be @@ -625,15 +649,15 @@ let rec whd_state_gen ?csts tactic_mode flags env sigma = (match safe_meta_value sigma ev with | Some body -> whrec cst_l (body, stack) | None -> fold ()) - | Const const when Closure.RedFlags.red_set flags (Closure.RedFlags.fCONST const) -> - (match constant_opt_value env const with + | Const (c,u as const) when Closure.RedFlags.red_set flags (Closure.RedFlags.fCONST c) -> + (match constant_opt_value_in env const with | None -> fold () - | Some body -> + | Some body -> if not tactic_mode - then whrec (Cst_stack.add_cst (mkConst const) cst_l) (body, stack) + then whrec (Cst_stack.add_cst (mkConstU const) cst_l) (body, stack) else (* Looks for ReductionBehaviour *) - match ReductionBehaviour.get (Globnames.ConstRef const) with - | None -> whrec (Cst_stack.add_cst (mkConst const) cst_l) (body, stack) + match ReductionBehaviour.get (Globnames.ConstRef c) with + | None -> whrec (Cst_stack.add_cst (mkConstU const) cst_l) (body, stack) | Some (recargs, nargs, flags) -> if (List.mem `ReductionNeverUnfold flags || (nargs > 0 && Stack.args_size stack < nargs)) @@ -642,7 +666,7 @@ let rec whd_state_gen ?csts tactic_mode flags env sigma = if List.mem `ReductionDontExposeCase flags then let app_sk,sk = Stack.strip_app stack in let (tm',sk'),cst_l' = - whrec (Cst_stack.add_cst (mkConst const) cst_l) (body, app_sk) in + whrec (Cst_stack.add_cst (mkConstU const) cst_l) (body, app_sk) in let f_equal (x,lft1) (y,lft2) = Constr.equal (Vars.lift lft1 x) (Vars.lift lft2 y) in if (match Stack.equal f_equal @@ -660,6 +684,11 @@ let rec whd_state_gen ?csts tactic_mode flags env sigma = whrec cst_l (body, stack) |l -> failwith "TODO recargs in cbn" ) + | Proj (p, c) when Closure.RedFlags.red_set flags (Closure.RedFlags.fCONST p) -> + (match (lookup_constant p env).Declarations.const_proj with + | None -> assert false + | Some pb -> whrec cst_l (c, Stack.Proj (pb.Declarations.proj_npars, pb.Declarations.proj_arg, p) + :: stack)) | LetIn (_,b,_,c) when Closure.RedFlags.red_set flags Closure.RedFlags.fZETA -> apply_subst whrec [b] cst_l c stack | Cast (c,_,_) -> whrec cst_l (c, stack) @@ -698,11 +727,13 @@ let rec whd_state_gen ?csts tactic_mode flags env sigma = |Some (bef,arg,s') -> whrec noth (arg, Stack.Fix(f,bef,Cst_stack.best_cst cst_l)::s')) - | Construct (ind,c) -> + | Construct ((ind,c),u) -> if Closure.RedFlags.red_set flags Closure.RedFlags.fIOTA then match Stack.strip_app stack with |args, (Stack.Case(ci, _, lf,_)::s') -> whrec noth (lf.(c-1), (Stack.tail ci.ci_npar args) @ s') + |args, (Stack.Proj (n,m,p)::s') -> + whrec noth (Stack.nth args (n+m), s') |args, (Stack.Fix (f,s',cst)::s'') -> let x' = Stack.zip(x,args) in whrec noth ((if tactic_mode then contract_fix ~env f else contract_fix f) cst, @@ -720,7 +751,7 @@ let rec whd_state_gen ?csts tactic_mode flags env sigma = |_ -> fold () else fold () - | Rel _ | Var _ | Const _ | LetIn _ -> fold () + | Rel _ | Var _ | Const _ | LetIn _ | Proj _ -> fold () | Sort _ | Ind _ | Prod _ -> fold () in whrec (Option.default noth csts) @@ -752,6 +783,12 @@ let local_whd_state_gen flags sigma = else s | _ -> s) | _ -> s) + + | Proj (p,c) when Closure.RedFlags.red_set flags (Closure.RedFlags.fCONST p) -> + (match (lookup_constant p (Global.env ())).Declarations.const_proj with + | None -> assert false + | Some pb -> whrec (c, Stack.Proj (pb.Declarations.proj_npars, pb.Declarations.proj_arg, p) + :: stack)) | Case (ci,p,d,lf) -> whrec (d, Stack.Case (ci,p,lf,None) :: stack) @@ -771,14 +808,13 @@ let local_whd_state_gen flags sigma = Some c -> whrec (c,stack) | None -> s) - | Construct (ind,c) -> + | Construct ((ind,c),u) -> if Closure.RedFlags.red_set flags Closure.RedFlags.fIOTA then match Stack.strip_app stack with |args, (Stack.Case(ci, _, lf,_)::s') -> whrec (lf.(c-1), (Stack.tail ci.ci_npar args) @ s') - |args, (Stack.Fix (f,s',cst)::s'') -> - let x' = Stack.zip(x,args) in - whrec (contract_fix f cst, s' @ (Stack.append_app [|x'|] s'')) + |args, (Stack.Proj (n,m,p) :: s') -> + whrec (Stack.nth args (n+m), s') |_ -> s else s @@ -899,7 +935,18 @@ let rec whd_evar sigma c = (match safe_evar_value sigma ev with Some c -> whd_evar sigma c | None -> c) - | Sort s -> whd_sort_variable sigma c + | Sort (Type u) -> + let u' = Evd.normalize_universe sigma u in + if u' == u then c else mkSort (Type u') + | Const (c', u) when not (Univ.Instance.is_empty u) -> + let u' = Evd.normalize_universe_instance sigma u in + if u' == u then c else mkConstU (c', u') + | Ind (i, u) when not (Univ.Instance.is_empty u) -> + let u' = Evd.normalize_universe_instance sigma u in + if u' == u then c else mkIndU (i, u') + | Construct (co, u) when not (Univ.Instance.is_empty u) -> + let u' = Evd.normalize_universe_instance sigma u in + if u' == u then c else mkConstructU (co, u') | _ -> c let nf_evar = @@ -916,12 +963,13 @@ let clos_norm_flags flgs env sigma t = (Closure.inject t) with e when is_anomaly e -> error "Tried to normalize ill-typed term" -let nf_beta = clos_norm_flags Closure.beta empty_env -let nf_betaiota = clos_norm_flags Closure.betaiota empty_env -let nf_betaiotazeta = clos_norm_flags Closure.betaiotazeta empty_env +let nf_beta = clos_norm_flags Closure.beta (Global.env ()) +let nf_betaiota = clos_norm_flags Closure.betaiota (Global.env ()) +let nf_betaiotazeta = clos_norm_flags Closure.betaiotazeta (Global.env ()) let nf_betadeltaiota env sigma = clos_norm_flags Closure.betadeltaiota env sigma + (********************************************************************) (* Conversion *) (********************************************************************) @@ -948,32 +996,43 @@ let pb_equal = function | Reduction.CUMUL -> Reduction.CONV | Reduction.CONV -> Reduction.CONV -let sort_cmp = Reduction.sort_cmp +let sort_cmp cv_pb s1 s2 u = + ignore(Reduction.sort_cmp_universes cv_pb s1 s2 (u, None)) -let test_conversion (f: ?l2r:bool-> ?evars:'a->'b) env sigma x y = +let test_trans_conversion (f: ?l2r:bool-> ?evars:'a->'b) reds env sigma x y = try let evars ev = safe_evar_value sigma ev in - let _ = f ~evars env x y in + let _ = f ~evars reds env (Evd.universes sigma) x y in true with Reduction.NotConvertible -> false | e when is_anomaly e -> error "Conversion test raised an anomaly" -let is_conv env sigma = test_conversion Reduction.conv env sigma -let is_conv_leq env sigma = test_conversion Reduction.conv_leq env sigma +let is_trans_conv reds env sigma = test_trans_conversion Reduction.trans_conv_universes reds env sigma +let is_trans_conv_leq reds env sigma = test_trans_conversion Reduction.trans_conv_leq_universes reds env sigma +let is_trans_fconv = function Reduction.CONV -> is_trans_conv | Reduction.CUMUL -> is_trans_conv_leq + +let is_conv = is_trans_conv full_transparent_state +let is_conv_leq = is_trans_conv_leq full_transparent_state let is_fconv = function | Reduction.CONV -> is_conv | Reduction.CUMUL -> is_conv_leq -let test_trans_conversion (f: ?l2r:bool-> ?evars:'a->'b) reds env sigma x y = - try - let evars ev = safe_evar_value sigma ev in - let _ = f ~evars reds env x y in - true - with Reduction.NotConvertible -> false +let check_conv ?(pb=Reduction.CUMUL) ?(ts=full_transparent_state) env sigma x y = + let f = match pb with + | Reduction.CONV -> Reduction.trans_conv_universes + | Reduction.CUMUL -> Reduction.trans_conv_leq_universes in + try f ~evars:(safe_evar_value sigma) ts env (Evd.universes sigma) x y; true + with Reduction.NotConvertible -> false | e when is_anomaly e -> error "Conversion test raised an anomaly" -let is_trans_conv reds env sigma = test_trans_conversion Reduction.trans_conv reds env sigma -let is_trans_conv_leq reds env sigma = test_trans_conversion Reduction.trans_conv_leq reds env sigma -let is_trans_fconv = function | Reduction.CONV -> is_trans_conv | Reduction.CUMUL -> is_trans_conv_leq - +let infer_conv ?(pb=Reduction.CUMUL) ?(ts=full_transparent_state) env sigma x y = + let f = match pb with + | Reduction.CONV -> Reduction.infer_conv + | Reduction.CUMUL -> Reduction.infer_conv_leq in + try + let cstrs = f ~evars:(safe_evar_value sigma) ~ts env (Evd.universes sigma) x y in + Evd.add_constraints sigma cstrs, true + with Reduction.NotConvertible -> sigma, false + | e when is_anomaly e -> error "Conversion test raised an anomaly" + (********************************************************************) (* Special-Purpose Reduction *) (********************************************************************) @@ -1164,6 +1223,14 @@ let whd_betaiota_deltazeta_for_iota_state ts env sigma csts s = let (t_o,stack_o),csts_o = whd_state_gen ~csts:csts' false (Closure.RedFlags.red_add_transparent betadeltaiota ts) env sigma (t,args) in if isConstruct t_o then whrec csts_o (t_o, stack_o@stack') else s,csts' + |args, (Stack.Proj (n,m,p) :: stack'' as stack') -> + let (t_o,stack_o),csts_o = whd_state_gen ~csts:csts' false + (Closure.RedFlags.red_add_transparent betadeltaiota ts) env sigma (t,args) in + if isConstruct t_o then + if Closure.is_transparent_constant ts p then + whrec csts_o (Stack.nth stack_o (n+m), stack'') + else (* Won't unfold *) (whd_betaiota_state sigma (t_o, stack_o@stack'),csts') + else s,csts' |_ -> s,csts' in whrec csts s @@ -1245,6 +1312,17 @@ let meta_reducible_instance evd b = let is_coerce = match s with CoerceToType -> true | _ -> false in if not is_coerce then irec g else u with Not_found -> u) + | Proj (p,c) when isMeta c || isCast c && isMeta (pi1 (destCast c)) -> + let m = try destMeta c with _ -> destMeta (pi1 (destCast c)) in + (match + try + let g, s = Metamap.find m metas in + let is_coerce = match s with CoerceToType -> true | _ -> false in + if isConstruct g || not is_coerce then Some g else None + with Not_found -> None + with + | Some g -> irec (mkProj (p,g)) + | None -> mkProj (p,c)) | _ -> map_constr irec u in if Metaset.is_empty fm then (* nf_betaiota? *) b.rebus @@ -1252,12 +1330,12 @@ let meta_reducible_instance evd b = let head_unfold_under_prod ts env _ c = - let unfold cst = + let unfold (cst,u as cstu) = if Cpred.mem cst (snd ts) then - match constant_opt_value env cst with + match constant_opt_value_in env cstu with | Some c -> c - | None -> mkConst cst - else mkConst cst in + | None -> mkConstU cstu + else mkConstU cstu in let rec aux c = match kind_of_term c with | Prod (n,t,c) -> mkProd (n,aux t, aux c) diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index 5ba0d74ec..29d7a6b2f 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -17,7 +17,7 @@ open Environ exception Elimconst -(** Machinery to custom the behavior of the reduction *) +(** Machinery to customize the behavior of the reduction *) module ReductionBehaviour : sig type flag = [ `ReductionDontExposeCase | `ReductionNeverUnfold ] @@ -37,6 +37,7 @@ module Stack : sig type 'a member = | App of 'a app_node | Case of case_info * 'a * 'a array * ('a * 'a list) option + | Proj of int * int * projection | Fix of fixpoint * 'a t * ('a * 'a list) option | Shift of int | Update of 'a @@ -82,6 +83,8 @@ type contextual_reduction_function = env -> evar_map -> constr -> constr type reduction_function = contextual_reduction_function type local_reduction_function = evar_map -> constr -> constr +type e_reduction_function = env -> evar_map -> constr -> evar_map * constr + type contextual_stack_reduction_function = env -> evar_map -> constr -> constr * constr list type stack_reduction_function = contextual_stack_reduction_function @@ -203,6 +206,7 @@ val splay_prod_n : env -> evar_map -> int -> constr -> rel_context * constr val splay_lam_n : env -> evar_map -> int -> constr -> rel_context * constr val splay_prod_assum : env -> evar_map -> constr -> rel_context * constr +val is_sort : env -> evar_map -> types -> bool type 'a miota_args = { mP : constr; (** the result type *) @@ -223,7 +227,7 @@ val contract_fix : ?env:Environ.env -> fixpoint -> val fix_recarg : fixpoint -> constr Stack.t -> (int * constr) option (** {6 Querying the kernel conversion oracle: opaque/transparent constants } *) -val is_transparent : Environ.env -> 'a tableKey -> bool +val is_transparent : Environ.env -> constant tableKey -> bool (** {6 Conversion Functions (uses closures, lazy strategy) } *) @@ -232,7 +236,7 @@ type conversion_test = constraints -> constraints val pb_is_equal : conv_pb -> bool val pb_equal : conv_pb -> conv_pb -val sort_cmp : conv_pb -> sorts -> sorts -> conversion_test +val sort_cmp : conv_pb -> sorts -> sorts -> universes -> unit val is_conv : env -> evar_map -> constr -> constr -> bool val is_conv_leq : env -> evar_map -> constr -> constr -> bool @@ -242,6 +246,17 @@ val is_trans_conv : transparent_state -> env -> evar_map -> constr -> constr -> val is_trans_conv_leq : transparent_state -> env -> evar_map -> constr -> constr -> bool val is_trans_fconv : conv_pb -> transparent_state -> env -> evar_map -> constr -> constr -> bool +(** [check_conv} Checks universe constraints only. + pb defaults to CUMUL and ts to a full transparent state. + *) +val check_conv : ?pb:conv_pb -> ?ts:transparent_state -> env -> evar_map -> constr -> constr -> bool + +(** [infer_fconv] Adds necessary universe constraints to the evar map. + pb defaults to CUMUL and ts to a full transparent state. + *) +val infer_conv : ?pb:conv_pb -> ?ts:transparent_state -> env -> evar_map -> constr -> constr -> + evar_map * bool + (** {6 Special-Purpose Reduction Functions } *) val whd_meta : evar_map -> constr -> constr diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml index c66ca7ac1..31487125a 100644 --- a/pretyping/retyping.ml +++ b/pretyping/retyping.ml @@ -85,9 +85,10 @@ let type_of_var env id = try let (_,_,ty) = lookup_named id env in ty with Not_found -> retype_error (BadVariable id) -let is_impredicative_set env = match Environ.engagement env with -| Some ImpredicativeSet -> true -| _ -> false +let decomp_sort env sigma t = + match kind_of_term (whd_betadeltaiota env sigma t) with + | Sort s -> s + | _ -> retype_error NotASort let retype ?(polyprop=true) sigma = let rec type_of env cstr= @@ -99,7 +100,7 @@ let retype ?(polyprop=true) sigma = let (_,_,ty) = lookup_rel n env in lift n ty | Var id -> type_of_var env id - | Const cst -> Typeops.type_of_constant env cst + | Const cst -> Typeops.type_of_constant_in env cst | Evar ev -> Evd.existential_type sigma ev | Ind ind -> type_of_inductive env ind | Construct cstr -> type_of_constructor env cstr @@ -129,6 +130,13 @@ let retype ?(polyprop=true) sigma = | App(f,args) -> strip_outer_cast (subst_type env sigma (type_of env f) (Array.to_list args)) + | Proj (p,c) -> + let Inductiveops.IndType(pars,realargs) = + try Inductiveops.find_rectype env sigma (type_of env c) + with Not_found -> anomaly ~label:"type_of" (str "Bad recursive type") + in + let (_,u), pars = dest_ind_family pars in + substl (c :: List.rev pars) (Typeops.type_of_projection env (p,u)) | Cast (c,_, t) -> t | Sort _ | Prod _ -> mkSort (sort_of env cstr) @@ -142,15 +150,13 @@ let retype ?(polyprop=true) sigma = | _, (Prop Null as s) -> s | Prop _, (Prop Pos as s) -> s | Type _, (Prop Pos as s) when is_impredicative_set env -> s - | (Type _, _) | (_, Type _) -> new_Type_sort () -(* | Type u1, Prop Pos -> Type (Univ.sup u1 Univ.type0_univ) | Prop Pos, (Type u2) -> Type (Univ.sup Univ.type0_univ u2) | Prop Null, (Type _ as s) -> s - | Type u1, Type u2 -> Type (Univ.sup u1 u2)*)) - | App(f,args) when isGlobalRef f -> - let t = type_of_global_reference_knowing_parameters env f args in - sort_of_atomic_type env sigma t args + | Type u1, Type u2 -> Type (Univ.sup u1 u2)) + (* | App(f,args) when isGlobalRef f -> *) + (* let t = type_of_global_reference_knowing_parameters env f args in *) + (* sort_of_atomic_type env sigma t args *) | App(f,args) -> sort_of_atomic_type env sigma (type_of env f) args | Lambda _ | Fix _ | Construct _ -> retype_error NotAType | _ -> decomp_sort env sigma (type_of env t) @@ -178,12 +184,12 @@ let retype ?(polyprop=true) sigma = Array.map (fun c -> lazy (nf_evar sigma (type_of env c))) args in match kind_of_term c with | Ind ind -> - let (_,mip) = lookup_mind_specif env ind in + let mip = lookup_mind_specif env (fst ind) in (try Inductive.type_of_inductive_knowing_parameters - ~polyprop env mip argtyps + ~polyprop env (mip,snd ind) argtyps with Reduction.NotArity -> retype_error NotAnArity) | Const cst -> - let t = constant_type env cst in + let t = constant_type_in env cst in (try Typeops.type_of_constant_knowing_parameters env t argtyps with Reduction.NotArity -> retype_error NotAnArity) | Var id -> type_of_var env id @@ -203,24 +209,31 @@ let type_of_global_reference_knowing_parameters env sigma c args = let type_of_global_reference_knowing_conclusion env sigma c conclty = let conclty = nf_evar sigma conclty in match kind_of_term c with - | Ind ind -> - let (_,mip) = Inductive.lookup_mind_specif env ind in - type_of_inductive_knowing_conclusion env mip conclty + | Ind (ind,u) -> + let spec = Inductive.lookup_mind_specif env ind in + type_of_inductive_knowing_conclusion env (spec,u) conclty | Const cst -> - let t = constant_type env cst in + let t = constant_type_in env cst in (* TODO *) Typeops.type_of_constant_knowing_parameters env t [||] | Var id -> type_of_var env id | Construct cstr -> type_of_constructor env cstr | _ -> assert false -(* We are outside the kernel: we take fresh universes *) -(* to avoid tactics and co to refresh universes themselves *) -let get_type_of ?(polyprop=true) ?(refresh=true) ?(lax=false) env sigma c = +(* Profiling *) +(* let get_type_of polyprop lax env sigma c = *) +(* let f,_,_,_ = retype ~polyprop sigma in *) +(* if lax then f env c else anomaly_on_error (f env) c *) + +(* let get_type_of_key = Profile.declare_profile "get_type_of" *) +(* let get_type_of = Profile.profile5 get_type_of_key get_type_of *) + +(* let get_type_of ?(polyprop=true) ?(lax=false) env sigma c = *) +(* get_type_of polyprop lax env sigma c *) + +let get_type_of ?(polyprop=true) ?(lax=false) env sigma c = let f,_,_,_ = retype ~polyprop sigma in - let t = if lax then f env c else anomaly_on_error (f env) c in - if refresh then refresh_universes t else t + if lax then f env c else anomaly_on_error (f env) c (* Makes an unsafe judgment from a constr *) let get_judgment_of env evc c = { uj_val = c; uj_type = get_type_of env evc c } - diff --git a/pretyping/retyping.mli b/pretyping/retyping.mli index c2a08f4b9..fc1dd3564 100644 --- a/pretyping/retyping.mli +++ b/pretyping/retyping.mli @@ -26,8 +26,7 @@ type retype_error exception RetypeError of retype_error val get_type_of : - ?polyprop:bool -> ?refresh:bool -> ?lax:bool -> - env -> evar_map -> constr -> types + ?polyprop:bool -> ?lax:bool -> env -> evar_map -> constr -> types val get_sort_of : ?polyprop:bool -> env -> evar_map -> types -> sorts diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index dd7542fc7..da4595254 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -41,7 +41,8 @@ let error_not_evaluable r = spc () ++ str "to an evaluable reference.") let is_evaluable_const env cst = - is_transparent env (ConstKey cst) && evaluable_constant cst env + is_transparent env (ConstKey cst) && + (evaluable_constant cst env || is_projection cst env) let is_evaluable_var env id = is_transparent env (VarKey id) && evaluable_named id env @@ -50,12 +51,17 @@ let is_evaluable env = function | EvalConstRef cst -> is_evaluable_const env cst | EvalVarRef id -> is_evaluable_var env id -let value_of_evaluable_ref env = function - | EvalConstRef con -> constant_value env con +let value_of_evaluable_ref env evref u = + match evref with + | EvalConstRef con -> + (try constant_value_in env (con,u) + with NotEvaluableConst IsProj -> + raise (Invalid_argument "value_of_evaluable_ref")) | EvalVarRef id -> Option.get (pi2 (lookup_named id env)) -let constr_of_evaluable_ref = function - | EvalConstRef con -> mkConst con +let constr_of_evaluable_ref evref u = + match evref with + | EvalConstRef con -> mkConstU (con,u) | EvalVarRef id -> mkVar id let evaluable_of_global_reference env = function @@ -81,27 +87,43 @@ let evaluable_reference_eq r1 r2 = match r1, r2 with Evar.equal e1 e2 && Array.equal eq_constr ctx1 ctx2 | _ -> false -let mkEvalRef = function - | EvalConst cst -> mkConst cst +let mkEvalRef ref u = + match ref with + | EvalConst cst -> mkConstU (cst,u) | EvalVar id -> mkVar id | EvalRel n -> mkRel n | EvalEvar ev -> mkEvar ev let isEvalRef env c = match kind_of_term c with - | Const sp -> is_evaluable env (EvalConstRef sp) + | Const (sp,_) -> is_evaluable env (EvalConstRef sp) | Var id -> is_evaluable env (EvalVarRef id) | Rel _ | Evar _ -> true | _ -> false -let destEvalRef c = match kind_of_term c with - | Const cst -> EvalConst cst - | Var id -> EvalVar id - | Rel n -> EvalRel n - | Evar ev -> EvalEvar ev +let destEvalRefU c = match kind_of_term c with + | Const (cst,u) -> EvalConst cst, u + | Var id -> (EvalVar id, Univ.Instance.empty) + | Rel n -> (EvalRel n, Univ.Instance.empty) + | Evar ev -> (EvalEvar ev, Univ.Instance.empty) | _ -> anomaly (Pp.str "Not an unfoldable reference") -let reference_opt_value sigma env = function - | EvalConst cst -> constant_opt_value env cst +let unsafe_reference_opt_value sigma env eval = + match eval with + | EvalConst cst -> + (match (lookup_constant cst env).Declarations.const_body with + | Declarations.Def c -> Some (Mod_subst.force_constr c) + | _ -> None) + | EvalVar id -> + let (_,v,_) = lookup_named id env in + v + | EvalRel n -> + let (_,v,_) = lookup_rel n env in + Option.map (lift n) v + | EvalEvar ev -> Evd.existential_opt_value sigma ev + +let reference_opt_value sigma env eval u = + match eval with + | EvalConst cst -> constant_opt_value_in env (cst,u) | EvalVar id -> let (_,v,_) = lookup_named id env in v @@ -111,8 +133,8 @@ let reference_opt_value sigma env = function | EvalEvar ev -> Evd.existential_opt_value sigma ev exception NotEvaluable -let reference_value sigma env c = - match reference_opt_value sigma env c with +let reference_value sigma env c u = + match reference_opt_value sigma env c u with | None -> raise NotEvaluable | Some d -> d @@ -127,6 +149,7 @@ type constant_evaluation = ((int*evaluable_reference) option array * (int * (int * constr) list * int)) | EliminationCases of int + | EliminationProj of int | NotAnElimination (* We use a cache registered as a global table *) @@ -215,7 +238,7 @@ let invert_name labs l na0 env sigma ref = function match refi with | None -> None | Some ref -> - try match reference_opt_value sigma env ref with + try match unsafe_reference_opt_value sigma env ref with | None -> None | Some c -> let labs',ccl = decompose_lam c in @@ -243,9 +266,10 @@ let compute_consteval_direct sigma env ref = (try check_fix_reversibility labs l fix with Elimconst -> NotAnElimination) | Case (_,_,d,_) when isRel d -> EliminationCases n + | Proj (p, d) when isRel d -> EliminationProj n | _ -> NotAnElimination in - match reference_opt_value sigma env ref with + match unsafe_reference_opt_value sigma env ref with | None -> NotAnElimination | Some c -> srec env 0 [] c @@ -270,13 +294,13 @@ let compute_consteval_mutual_fix sigma env ref = | _ -> assert false) | _ when isEvalRef env c' -> (* Forget all \'s and args and do as if we had started with c' *) - let ref = destEvalRef c' in - (match reference_opt_value sigma env ref with + let ref,_ = destEvalRefU c' in + (match unsafe_reference_opt_value sigma env ref with | None -> anomaly (Pp.str "Should have been trapped by compute_direct") | Some c -> srec env (minarg-nargs) [] ref c) | _ -> (* Should not occur *) NotAnElimination in - match reference_opt_value sigma env ref with + match unsafe_reference_opt_value sigma env ref with | None -> (* Should not occur *) NotAnElimination | Some c -> srec env 0 [] ref c @@ -320,7 +344,7 @@ let reference_eval sigma env = function let x = Name (Id.of_string "x") -let make_elim_fun (names,(nbfix,lv,n)) largs = +let make_elim_fun (names,(nbfix,lv,n)) u largs = let lu = List.firstn n largs in let p = List.length lv in let lyi = List.map fst lv in @@ -335,7 +359,7 @@ let make_elim_fun (names,(nbfix,lv,n)) largs = match names.(i) with | None -> None | Some (minargs,ref) -> - let body = applistc (mkEvalRef ref) la in + let body = applistc (mkEvalRef ref u) la in let g = List.fold_left_i (fun q (* j = n+1-q *) c (ij,tij) -> let subst = List.map (lift (-q)) (List.firstn (n-ij) la) in @@ -392,8 +416,9 @@ let solve_arity_problem env sigma fxminargs c = else raise Partial; List.iter (check strict) rcargs | (Var _|Const _) when isEvalRef env h -> - (match reference_opt_value sigma env (destEvalRef h) with - Some h' -> + (let ev, u = destEvalRefU h in + match reference_opt_value sigma env ev u with + | Some h' -> let bak = !evm in (try List.iter (check false) rcargs with Partial -> @@ -465,7 +490,7 @@ let contract_cofix_use_function env sigma f let reduce_mind_case_use_function func env sigma mia = match kind_of_term mia.mconstr with - | Construct(ind_sp,i) -> + | Construct ((ind_sp,i),u) -> let real_cargs = List.skipn mia.mci.ci_npar mia.mcargs in applist (mia.mlf.(i-1), real_cargs) | CoFix (bodynum,(names,_,_) as cofix) -> @@ -481,12 +506,13 @@ let reduce_mind_case_use_function func env sigma mia = mutual inductive, try to reuse the global name if the block was indeed initially built as a global definition *) - let kn = con_with_label (destConst func) (Label.of_id id) + let kn = map_puniverses (fun x -> con_with_label x (Label.of_id id)) + (destConst func) in - try match constant_opt_value env kn with + try match constant_opt_value_in env kn with | None -> None (* TODO: check kn is correct *) - | Some _ -> Some (minargs,mkConst kn) + | Some _ -> Some (minargs,mkConstU kn) with Not_found -> None else fun _ -> None in @@ -495,21 +521,42 @@ let reduce_mind_case_use_function func env sigma mia = mkCase (mia.mci, mia.mP, applist(cofix_def,mia.mcargs), mia.mlf) | _ -> assert false + +let match_eval_ref env constr = + match kind_of_term constr with + | Const (sp, u) when is_evaluable env (EvalConstRef sp) -> + Some (EvalConst sp, u) + | Var id when is_evaluable env (EvalVarRef id) -> Some (EvalVar id, Univ.Instance.empty) + | Rel i -> Some (EvalRel i, Univ.Instance.empty) + | Evar ev -> Some (EvalEvar ev, Univ.Instance.empty) + | _ -> None + +let match_eval_ref_value sigma env constr = + match kind_of_term constr with + | Const (sp, u) when is_evaluable env (EvalConstRef sp) -> + Some (constant_value_in env (sp, u)) + | Var id when is_evaluable env (EvalVarRef id) -> + let (_,v,_) = lookup_named id env in v + | Rel n -> let (_,v,_) = lookup_rel n env in + Option.map (lift n) v + | Evar ev -> Evd.existential_opt_value sigma ev + | _ -> None + let special_red_case env sigma whfun (ci, p, c, lf) = let rec redrec s = let (constr, cargs) = whfun s in - if isEvalRef env constr then - let ref = destEvalRef constr in - match reference_opt_value sigma env ref with - | None -> raise Redelimination - | Some gvalue -> - if reducible_mind_case gvalue then - reduce_mind_case_use_function constr env sigma - {mP=p; mconstr=gvalue; mcargs=cargs; - mci=ci; mlf=lf} - else - redrec (applist(gvalue, cargs)) - else + match match_eval_ref env constr with + | Some (ref, u) -> + (match reference_opt_value sigma env ref u with + | None -> raise Redelimination + | Some gvalue -> + if reducible_mind_case gvalue then + reduce_mind_case_use_function constr env sigma + {mP=p; mconstr=gvalue; mcargs=cargs; + mci=ci; mlf=lf} + else + redrec (applist(gvalue, cargs))) + | None -> if reducible_mind_case constr then reduce_mind_case {mP=p; mconstr=constr; mcargs=cargs; @@ -524,6 +571,34 @@ let recargs = function | EvalConst c -> Option.map (fun (x,y,_) -> (x,y)) (ReductionBehaviour.get (ConstRef c)) +let reduce_projection env sigma proj (recarg'hd,stack') stack = + (match kind_of_term recarg'hd with + | Construct _ -> + let proj_narg = + let pb = Option.get ((lookup_constant proj env).Declarations.const_proj) in + pb.Declarations.proj_npars + pb.Declarations.proj_arg + in Reduced (List.nth stack' proj_narg, stack) + | _ -> NotReducible) + +let reduce_proj env sigma whfun c = + (* Pp.msgnl (str" reduce_proj: " ++ print_constr c); *) + let rec redrec s = + match kind_of_term s with + | Proj (proj, c) -> + let c' = try redrec c with Redelimination -> c in + let constr, cargs = whfun c' in + (* Pp.msgnl (str" reduce_proj: constructor: " ++ print_constr constr); *) + (match kind_of_term constr with + | Construct _ -> + let proj_narg = + let pb = Option.get ((lookup_constant proj env).Declarations.const_proj) in + pb.Declarations.proj_npars + pb.Declarations.proj_arg + in List.nth cargs proj_narg + | _ -> raise Redelimination) + | _ -> raise Redelimination + in redrec c + + let dont_expose_case = function | EvalVar _ | EvalRel _ | EvalEvar _ -> false | EvalConst c -> @@ -547,8 +622,8 @@ let whd_nothing_for_iota env sigma s = | Meta ev -> (try whrec (Evd.meta_value sigma ev, stack) with Not_found -> s) - | Const const when is_transparent_constant full_transparent_state const -> - (match constant_opt_value env const with + | Const const when is_transparent_constant full_transparent_state (fst const) -> + (match constant_opt_value_in env const with | Some body -> whrec (body, stack) | None -> s) | LetIn (_,b,_,c) -> stacklam whrec [b] c stack @@ -567,7 +642,7 @@ let whd_nothing_for_iota env sigma s = constants by keeping the name of the constants in the recursive calls; it fails if no redex is around *) -let rec red_elim_const env sigma ref largs = +let rec red_elim_const env sigma ref u largs = let nargs = List.length largs in let largs, unfold_anyway, unfold_nonelim = match recargs ref with @@ -586,39 +661,44 @@ let rec red_elim_const env sigma ref largs = n >= 0 && not is_empty && nargs >= n in try match reference_eval sigma env ref with | EliminationCases n when nargs >= n -> - let c = reference_value sigma env ref in + let c = reference_value sigma env ref u in let c', lrest = whd_nothing_for_iota env sigma (applist(c,largs)) in let whfun = whd_simpl_stack env sigma in (special_red_case env sigma whfun (destCase c'), lrest) + | EliminationProj n when nargs >= n -> + let c = reference_value sigma env ref u in + let c', lrest = whd_nothing_for_iota env sigma (applist(c,largs)) in + let whfun = whd_construct_stack env sigma in + (reduce_proj env sigma whfun c', lrest) | EliminationFix (min,minfxargs,infos) when nargs >= min -> - let c = reference_value sigma env ref in + let c = reference_value sigma env ref u in let d, lrest = whd_nothing_for_iota env sigma (applist(c,largs)) in - let f = make_elim_fun ([|Some (minfxargs,ref)|],infos) largs in + let f = make_elim_fun ([|Some (minfxargs,ref)|],infos) u largs in let whfun = whd_construct_stack env sigma in (match reduce_fix_use_function env sigma f whfun (destFix d) lrest with | NotReducible -> raise Redelimination | Reduced (c,rest) -> (nf_beta sigma c, rest)) | EliminationMutualFix (min,refgoal,refinfos) when nargs >= min -> - let rec descend ref args = - let c = reference_value sigma env ref in + let rec descend (ref,u) args = + let c = reference_value sigma env ref u in if evaluable_reference_eq ref refgoal then (c,args) else let c', lrest = whd_betalet_stack sigma (applist(c,args)) in - descend (destEvalRef c') lrest in - let (_, midargs as s) = descend ref largs in + descend (destEvalRefU c') lrest in + let (_, midargs as s) = descend (ref,u) largs in let d, lrest = whd_nothing_for_iota env sigma (applist s) in - let f = make_elim_fun refinfos midargs in + let f = make_elim_fun refinfos u midargs in let whfun = whd_construct_stack env sigma in (match reduce_fix_use_function env sigma f whfun (destFix d) lrest with | NotReducible -> raise Redelimination | Reduced (c,rest) -> (nf_beta sigma c, rest)) | NotAnElimination when unfold_nonelim -> - let c = reference_value sigma env ref in + let c = reference_value sigma env ref u in whd_betaiotazeta sigma (applist (c, largs)), [] | _ -> raise Redelimination with Redelimination when unfold_anyway -> - let c = reference_value sigma env ref in + let c = reference_value sigma env ref u in whd_betaiotazeta sigma (applist (c, largs)), [] (* reduce to whd normal form or to an applied constant that does not hide @@ -645,20 +725,31 @@ and whd_simpl_stack env sigma = | Reduced s' -> redrec (applist s') | NotReducible -> s' with Redelimination -> s') - | _ when isEvalRef env x -> - let ref = destEvalRef x in + + | Proj (p, c) -> + (try + (match recargs (EvalConst p) with + | Some (_, n) when n > 1 -> (* simpl never *) s' + | _ -> + match reduce_projection env sigma p (whd_construct_stack env sigma c) stack with + | Reduced s' -> redrec (applist s') + | NotReducible -> s') + with Redelimination -> s') + + | _ -> + match match_eval_ref env x with + | Some (ref, u) -> (try - let hd, _ as s'' = redrec (applist(red_elim_const env sigma ref stack)) in - let rec is_case x = match kind_of_term x with - | Lambda (_,_, x) | LetIn (_,_,_, x) | Cast (x, _,_) -> is_case x - | App (hd, _) -> is_case hd - | Case _ -> true - | _ -> false in - if dont_expose_case ref && is_case hd then raise Redelimination - else s'' - with Redelimination -> - s') - | _ -> s' + let hd, _ as s'' = redrec (applist(red_elim_const env sigma ref u stack)) in + let rec is_case x = match kind_of_term x with + | Lambda (_,_, x) | LetIn (_,_,_, x) | Cast (x, _,_) -> is_case x + | App (hd, _) -> is_case hd + | Case _ -> true + | _ -> false in + if dont_expose_case ref && is_case hd then raise Redelimination + else s'' + with Redelimination -> s') + | None -> s' in redrec @@ -667,13 +758,12 @@ and whd_simpl_stack env sigma = and whd_construct_stack env sigma s = let (constr, cargs as s') = whd_simpl_stack env sigma s in if reducible_mind_case constr then s' - else if isEvalRef env constr then - let ref = destEvalRef constr in - match reference_opt_value sigma env ref with - | None -> raise Redelimination - | Some gvalue -> whd_construct_stack env sigma (applist(gvalue, cargs)) - else - raise Redelimination + else match match_eval_ref env constr with + | Some (ref, u) -> + (match reference_opt_value sigma env ref u with + | None -> raise Redelimination + | Some gvalue -> whd_construct_stack env sigma (applist(gvalue, cargs))) + | _ -> raise Redelimination (************************************************************************) (* Special Purpose Reduction Strategies *) @@ -703,14 +793,24 @@ let try_red_product env sigma c = | Prod (x,a,b) -> mkProd (x, a, redrec (push_rel (x,None,a) env) b) | LetIn (x,a,b,t) -> redrec env (subst1 a t) | Case (ci,p,d,lf) -> simpfun (mkCase (ci,p,redrec env d,lf)) - | _ when isEvalRef env x -> + | Proj (p, c) -> + let c' = + match kind_of_term c with + | Construct _ -> c + | _ -> redrec env c + in + (match reduce_projection env sigma p (whd_betaiotazeta_stack sigma c') [] with + | Reduced s -> simpfun (applist s) + | NotReducible -> raise Redelimination) + | _ -> + (match match_eval_ref env x with + | Some (ref, u) -> (* TO DO: re-fold fixpoints after expansion *) (* to get true one-step reductions *) - let ref = destEvalRef x in - (match reference_opt_value sigma env ref with + (match reference_opt_value sigma env ref u with | None -> raise Redelimination | Some c -> c) - | _ -> raise Redelimination + | _ -> raise Redelimination) in redrec env c let red_product env sigma c = @@ -778,14 +878,13 @@ let whd_simpl_orelse_delta_but_fix_old env sigma c = let whd_simpl_orelse_delta_but_fix env sigma c = let rec redrec s = let (constr, stack as s') = whd_simpl_stack env sigma s in - if isEvalRef env constr then - match reference_opt_value sigma env (destEvalRef constr) with - | Some c -> - (match kind_of_term (strip_lam c) with - | CoFix _ | Fix _ -> s' - | _ -> redrec (applist(c, stack))) - | None -> s' - else s' in + match match_eval_ref_value sigma env constr with + | Some c -> + (match kind_of_term (strip_lam c) with + | CoFix _ | Fix _ -> s' + | _ -> redrec (applist(c, stack))) + | None -> s' + in let simpfun = clos_norm_flags betaiota env sigma in simpfun (applist (redrec c)) @@ -803,12 +902,14 @@ let simpl env sigma c = strong whd_simpl env sigma c let matches_head c t = match kind_of_term t with | App (f,_) -> ConstrMatching.matches c f + | Proj (p, _) -> ConstrMatching.matches c (mkConst p) | _ -> raise ConstrMatching.PatternMatchingFailure -let contextually byhead (occs,c) f env sigma t = +let e_contextually byhead (occs,c) f env sigma t = let (nowhere_except_in,locs) = Locusops.convert_occs occs in let maxocc = List.fold_right max locs 0 in let pos = ref 1 in + let evd = ref sigma in let rec traverse (env,c as envc) t = if nowhere_except_in && (!pos > maxocc) then t else @@ -821,11 +922,15 @@ let contextually byhead (occs,c) f env sigma t = incr pos; if ok then let subst' = Id.Map.map (traverse envc) subst in - f subst' env sigma t + let evm, t = f subst' env !evd t in + (evd := evm; t) else if byhead then (* find other occurrences of c in t; TODO: ensure left-to-right *) - let (f,l) = destApp t in - mkApp (f, Array.map_left (traverse envc) l) + (match kind_of_term t with + | App (f,l) -> + mkApp (f, Array.map_left (traverse envc) l) + | Proj (p,c) -> mkProj (p,traverse envc c) + | _ -> assert false) else t with ConstrMatching.PatternMatchingFailure -> @@ -835,30 +940,45 @@ let contextually byhead (occs,c) f env sigma t = in let t' = traverse (env,c) t in if List.exists (fun o -> o >= !pos) locs then error_invalid_occurrence locs; - t' + !evd, t' + +let contextually byhead occs f env sigma t = + let f' subst env sigma t = sigma, f subst env sigma t in + snd (e_contextually byhead occs f' env sigma t) (* linear bindings (following pretty-printer) of the value of name in c. * n is the number of the next occurence of name. * ol is the occurence list to find. *) -let substlin env evalref n (nowhere_except_in,locs) c = +let match_constr_evaluable_ref sigma c evref = + match kind_of_term c, evref with + | Const (c,u), EvalConstRef c' when eq_constant c c' -> Some u + | Proj (p,c), EvalConstRef p' when eq_constant p p' -> Some Univ.Instance.empty + | Var id, EvalVarRef id' when id_eq id id' -> Some Univ.Instance.empty + | _, _ -> None + +let substlin env sigma evalref n (nowhere_except_in,locs) c = let maxocc = List.fold_right max locs 0 in let pos = ref n in assert (List.for_all (fun x -> x >= 0) locs); - let value = value_of_evaluable_ref env evalref in - let term = constr_of_evaluable_ref evalref in + let value u = + value_of_evaluable_ref env evalref u + (* Some (whd_betaiotazeta sigma c) *) + in let rec substrec () c = if nowhere_except_in && !pos > maxocc then c - else if eq_constr c term then - let ok = - if nowhere_except_in then Int.List.mem !pos locs - else not (Int.List.mem !pos locs) in - incr pos; - if ok then value else c - else - map_constr_with_binders_left_to_right - (fun _ () -> ()) - substrec () c + else + match match_constr_evaluable_ref sigma c evalref with + | Some u -> + let ok = + if nowhere_except_in then Int.List.mem !pos locs + else not (Int.List.mem !pos locs) in + incr pos; + if ok then value u else c + | None -> + map_constr_with_binders_left_to_right + (fun _ () -> ()) + substrec () c in let t' = substrec () c in (!pos, t') @@ -881,7 +1001,7 @@ let unfold env sigma name = * Performs a betaiota reduction after unfolding. *) let unfoldoccs env sigma (occs,name) c = let unfo nowhere_except_in locs = - let (nbocc,uc) = substlin env name 1 (nowhere_except_in,locs) c in + let (nbocc,uc) = substlin env sigma name 1 (nowhere_except_in,locs) c in if Int.equal nbocc 1 then error ((string_of_evaluable_ref env name)^" does not occur."); let rest = List.filter (fun o -> o >= nbocc) locs in @@ -934,6 +1054,22 @@ let compute = cbv_betadeltaiota (* Pattern *) +let make_eq_univs_test evd c = + { match_fun = (fun evd c' -> + let b, cst = eq_constr_universes c c' in + if b then + try Evd.add_universe_constraints evd cst + with Evd.UniversesDiffer -> raise NotUnifiable + else raise NotUnifiable); + merge_fun = (fun evd _ -> evd); + testing_state = evd; + last_found = None +} +let subst_closed_term_univs_occ evd occs c t = + let test = make_eq_univs_test evd c in + let t' = subst_closed_term_occ_modulo occs test None t in + t', test.testing_state + (* gives [na:ta]c' such that c converts to ([na:ta]c' a), abstracting only * the specified occurrences. *) @@ -944,7 +1080,8 @@ let abstract_scheme env sigma (locc,a) c = if occur_meta a then mkLambda (na,ta,c) else - mkLambda (na,ta,subst_closed_term_occ locc a c) + let c', sigma' = subst_closed_term_univs_occ sigma locc a c in + mkLambda (na,ta,c') let pattern_occs loccs_trm env sigma c = let abstr_trm = List.fold_right (abstract_scheme env sigma) loccs_trm c in @@ -1011,11 +1148,11 @@ let one_step_reduce env sigma c = | Reduced s' -> s' | NotReducible -> raise NotStepReducible) | _ when isEvalRef env x -> - let ref = destEvalRef x in + let ref,u = destEvalRefU x in (try - red_elim_const env sigma ref stack + red_elim_const env sigma ref u stack with Redelimination -> - match reference_opt_value sigma env ref with + match reference_opt_value sigma env ref u with | Some d -> (d, stack) | None -> raise NotStepReducible) @@ -1027,7 +1164,7 @@ let isIndRef = function IndRef _ -> true | _ -> false let reduce_to_ref_gen allow_product env sigma ref t = if isIndRef ref then - let (mind,t) = reduce_to_ind_gen allow_product env sigma t in + let ((mind,u),t) = reduce_to_ind_gen allow_product env sigma t in begin match ref with | IndRef mind' when eq_ind mind mind' -> t | _ -> diff --git a/pretyping/tacred.mli b/pretyping/tacred.mli index 34aca3e33..5146cd345 100644 --- a/pretyping/tacred.mli +++ b/pretyping/tacred.mli @@ -59,8 +59,17 @@ val unfoldn : (** Fold *) val fold_commands : constr list -> reduction_function +val make_eq_univs_test : evar_map -> constr -> evar_map Termops.testing_function + +(** [subst_closed_term_occ occl c d] replaces occurrences of closed [c] at + positions [occl] by [Rel 1] in [d] (see also Note OCC), unifying universes + which results in a set of constraints. *) +val subst_closed_term_univs_occ : evar_map -> occurrences -> constr -> constr -> + constr * evar_map + (** Pattern *) -val pattern_occs : (occurrences * constr) list -> reduction_function +val pattern_occs : (occurrences * constr) list -> env -> evar_map -> constr -> + constr (** Rem: Lazy strategies are defined in Reduction *) @@ -74,12 +83,12 @@ val cbv_norm_flags : Closure.RedFlags.reds -> reduction_function (** [reduce_to_atomic_ind env sigma t] puts [t] in the form [t'=(I args)] with [I] an inductive definition; returns [I] and [t'] or fails with a user error *) -val reduce_to_atomic_ind : env -> evar_map -> types -> inductive * types +val reduce_to_atomic_ind : env -> evar_map -> types -> pinductive * types (** [reduce_to_quantified_ind env sigma t] puts [t] in the form [t'=(x1:A1)..(xn:An)(I args)] with [I] an inductive definition; returns [I] and [t'] or fails with a user error *) -val reduce_to_quantified_ind : env -> evar_map -> types -> inductive * types +val reduce_to_quantified_ind : env -> evar_map -> types -> pinductive * types (** [reduce_to_quantified_ref env sigma ref t] try to put [t] in the form [t'=(x1:A1)..(xn:An)(ref args)] and fails with user error if not possible *) @@ -90,7 +99,10 @@ val reduce_to_atomic_ref : env -> evar_map -> global_reference -> types -> types val find_hnf_rectype : - env -> evar_map -> types -> inductive * constr list + env -> evar_map -> types -> pinductive * constr list val contextually : bool -> occurrences * constr_pattern -> (patvar_map -> reduction_function) -> reduction_function + +val e_contextually : bool -> occurrences * constr_pattern -> + (patvar_map -> e_reduction_function) -> e_reduction_function diff --git a/pretyping/term_dnet.ml b/pretyping/term_dnet.ml index 10ec651fa..e05f4bcfe 100644 --- a/pretyping/term_dnet.ml +++ b/pretyping/term_dnet.ml @@ -261,9 +261,9 @@ struct | Rel _ -> Term DRel | Sort _ -> Term DSort | Var i -> Term (DRef (VarRef i)) - | Const c -> Term (DRef (ConstRef c)) - | Ind i -> Term (DRef (IndRef i)) - | Construct c -> Term (DRef (ConstructRef c)) + | Const (c,u) -> Term (DRef (ConstRef c)) + | Ind (i,u) -> Term (DRef (IndRef i)) + | Construct (c,u)-> Term (DRef (ConstructRef c)) | Term.Meta _ -> assert false | Evar (i,_) -> let meta = @@ -287,6 +287,8 @@ struct | App (f,ca) -> Array.fold_left (fun c a -> Term (DApp (c,a))) (pat_of_constr f) (Array.map pat_of_constr ca) + | Proj (p,c) -> + Term (DApp (Term (DRef (ConstRef p)), pat_of_constr c)) and ctx_of_constr ctx c = match kind_of_term c with | Prod (_,t,c) -> ctx_of_constr (Term(DCons((pat_of_constr t,None),ctx))) c diff --git a/pretyping/termops.ml b/pretyping/termops.ml index 741601167..b3fa53eee 100644 --- a/pretyping/termops.ml +++ b/pretyping/termops.ml @@ -22,7 +22,7 @@ open Locus let print_sort = function | Prop Pos -> (str "Set") | Prop Null -> (str "Prop") - | Type u -> (str "Type(" ++ Univ.pr_uni u ++ str ")") + | Type u -> (str "Type(" ++ Univ.Universe.pr u ++ str ")") let pr_sort_family = function | InSet -> (str "Set") @@ -44,6 +44,10 @@ let pr_fix pr_constr ((t,i),(lna,tl,bl)) = cut() ++ str":=" ++ pr_constr bd) (Array.to_list fixl)) ++ str"}") +let pr_puniverses p u = + if Univ.Instance.is_empty u then p + else p ++ str"(*" ++ Univ.Instance.pr u ++ str"*)" + let rec pr_constr c = match kind_of_term c with | Rel n -> str "#"++int n | Meta n -> str "Meta(" ++ int n ++ str ")" @@ -71,10 +75,11 @@ let rec pr_constr c = match kind_of_term c with | Evar (e,l) -> hov 1 (str"Evar#" ++ int (Evar.repr e) ++ str"{" ++ prlist_with_sep spc pr_constr (Array.to_list l) ++str"}") - | Const c -> str"Cst(" ++ pr_con c ++ str")" - | Ind (sp,i) -> str"Ind(" ++ pr_mind sp ++ str"," ++ int i ++ str")" - | Construct ((sp,i),j) -> - str"Constr(" ++ pr_mind sp ++ str"," ++ int i ++ str"," ++ int j ++ str")" + | Const (c,u) -> str"Cst(" ++ pr_puniverses (pr_con c) u ++ str")" + | Ind ((sp,i),u) -> str"Ind(" ++ pr_puniverses (pr_mind sp ++ str"," ++ int i) u ++ str")" + | Construct (((sp,i),j),u) -> + str"Constr(" ++ pr_puniverses (pr_mind sp ++ str"," ++ int i ++ str"," ++ int j) u ++ str")" + | Proj (p,c) -> str"Proj(" ++ pr_con p ++ str"," ++ pr_constr c ++ str")" | Case (ci,p,c,bl) -> v 0 (hv 0 (str"<"++pr_constr p++str">"++ cut() ++ str"Case " ++ pr_constr c ++ str"of") ++ cut() ++ @@ -145,41 +150,6 @@ let print_env env = in (sign_env ++ db_env) -(*let current_module = ref DirPath.empty - -let set_module m = current_module := m*) - -let new_univ_level, set_remote_new_univ_level = - RemoteCounter.new_counter ~name:"univ_level" 0 ~incr:((+) 1) - ~build:(fun n -> Univ.UniverseLevel.make (Lib.library_dp()) n) - -let new_univ () = Univ.Universe.make (new_univ_level ()) -let new_Type () = mkType (new_univ ()) -let new_Type_sort () = Type (new_univ ()) - -(* This refreshes universes in types; works only for inferred types (i.e. for - types of the form (x1:A1)...(xn:An)B with B a sort or an atom in - head normal form) *) -let refresh_universes_gen strict t = - let modified = ref false in - let rec refresh t = match kind_of_term t with - | Sort (Type u) when strict || not (Univ.is_type0m_univ u) -> - modified := true; new_Type () - | Prod (na,u,v) -> mkProd (na,u,refresh v) - | _ -> t in - let t' = refresh t in - if !modified then t' else t - -let refresh_universes = refresh_universes_gen false -let refresh_universes_strict = refresh_universes_gen true - -let new_sort_in_family = function - | InProp -> prop_sort - | InSet -> set_sort - | InType -> Type (new_univ ()) - - - (* [Rel (n+m);...;Rel(n+1)] *) let rel_vect n m = Array.init m (fun i -> mkRel(n+m-i)) @@ -319,6 +289,7 @@ let map_constr_with_named_binders g f l c = match kind_of_term c with | Lambda (na,t,c) -> mkLambda (na, f l t, f (g na l) c) | LetIn (na,b,t,c) -> mkLetIn (na, f l b, f l t, f (g na l) c) | App (c,al) -> mkApp (f l c, Array.map (f l) al) + | Proj (p,c) -> mkProj (p, f l c) | Evar (e,al) -> mkEvar (e, Array.map (f l) al) | Case (ci,p,c,bl) -> mkCase (ci, f l p, f l c, Array.map (f l) bl) | Fix (ln,(lna,tl,bl)) -> @@ -375,6 +346,8 @@ let map_constr_with_binders_left_to_right g f l c = match kind_of_term c with let a = al.(Array.length al - 1) in let hd = f l (mkApp (c, Array.sub al 0 (Array.length al - 1))) in mkApp (hd, [| f l a |]) + | Proj (p,c) -> + mkProj (p, f l c) | Evar (e,al) -> mkEvar (e, Array.map_left (f l) al) | Case (ci,p,c,bl) -> (* In v8 concrete syntax, predicate is after the term to match! *) @@ -415,6 +388,9 @@ let map_constr_with_full_binders g f l cstr = match kind_of_term cstr with let c' = f l c in let al' = Array.map (f l) al in if c==c' && Array.for_all2 (==) al al' then cstr else mkApp (c', al') + | Proj (p,c) -> + let c' = f l c in + if c' == c then cstr else mkProj (p, c') | Evar (e,al) -> let al' = Array.map (f l) al in if Array.for_all2 (==) al al' then cstr else mkEvar (e, al') @@ -456,6 +432,7 @@ let fold_constr_with_binders g f n acc c = match kind_of_term c with | Lambda (_,t,c) -> f (g n) (f n acc t) c | LetIn (_,b,t,c) -> f (g n) (f n (f n acc b) t) c | App (c,l) -> Array.fold_left (f n) (f n acc c) l + | Proj (p,c) -> f n acc c | Evar (_,l) -> Array.fold_left (f n) acc l | Case (_,p,c,bl) -> Array.fold_left (f n) (f n (f n acc p) c) bl | Fix (_,(lna,tl,bl)) -> @@ -480,6 +457,7 @@ let iter_constr_with_full_binders g f l c = match kind_of_term c with | Lambda (na,t,c) -> f l t; f (g (na,None,t) l) c | LetIn (na,b,t,c) -> f l b; f l t; f (g (na,Some b,t) l) c | App (c,args) -> f l c; Array.iter (f l) args + | Proj (p,c) -> f l c | Evar (_,args) -> Array.iter (f l) args | Case (_,p,c,bl) -> f l p; f l c; Array.iter (f l) bl | Fix (_,(lna,tl,bl)) -> @@ -516,6 +494,13 @@ let occur_meta_or_existential c = | _ -> iter_constr occrec c in try occrec c; false with Occur -> true +let occur_const s c = + let rec occur_rec c = match kind_of_term c with + | Const (sp,_) when sp=s -> raise Occur + | _ -> iter_constr occur_rec c + in + try occur_rec c; false with Occur -> true + let occur_evar n c = let rec occur_rec c = match kind_of_term c with | Evar (sp,_) when Evar.equal sp n -> raise Occur @@ -573,9 +558,10 @@ let collect_vars c = (* Tests whether [m] is a subterm of [t]: [m] is appropriately lifted through abstractions of [t] *) -let dependent_main noevar m t = +let dependent_main noevar univs m t = + let eqc x y = if univs then fst (eq_constr_universes x y) else eq_constr_nounivs x y in let rec deprec m t = - if eq_constr m t then + if eqc m t then raise Occur else match kind_of_term m, kind_of_term t with @@ -590,8 +576,11 @@ let dependent_main noevar m t = in try deprec m t; false with Occur -> true -let dependent = dependent_main false -let dependent_no_evar = dependent_main true +let dependent = dependent_main false false +let dependent_no_evar = dependent_main true false + +let dependent_univs = dependent_main false true +let dependent_univs_no_evar = dependent_main true true let count_occurrences m t = let n = ref 0 in @@ -725,7 +714,7 @@ let error_cannot_unify_occurrences nested (cl2,pos2,t2) (cl1,pos1,t1) = exception NotUnifiable type 'a testing_function = { - match_fun : constr -> 'a; + match_fun : 'a -> constr -> 'a; merge_fun : 'a -> 'a -> 'a; mutable testing_state : 'a; mutable last_found : ((Id.t * hyp_location_flag) option * int * constr) option @@ -746,7 +735,7 @@ let subst_closed_term_occ_gen_modulo occs test cl occ t = let rec substrec k t = if nowhere_except_in && !pos > maxocc then t else try - let subst = test.match_fun t in + let subst = test.match_fun test.testing_state t in if Locusops.is_selected !pos occs then (add_subst t subst; incr pos; (* Check nested matching subterms *) @@ -781,7 +770,7 @@ let proceed_with_occurrences f occs x = x let make_eq_test c = { - match_fun = (fun c' -> if eq_constr c c' then () else raise NotUnifiable); + match_fun = (fun () c' -> if eq_constr c c' then () else raise NotUnifiable); merge_fun = (fun () () -> ()); testing_state = (); last_found = None @@ -879,10 +868,7 @@ let isGlobalRef c = | Const _ | Ind _ | Construct _ | Var _ -> true | _ -> false -let has_polymorphic_type c = - match (Global.lookup_constant c).Declarations.const_type with - | Declarations.PolymorphicArity _ -> true - | _ -> false +let has_polymorphic_type c = (Global.lookup_constant c).Declarations.const_polymorphic let base_sort_cmp pb s0 s1 = match (s0,s1) with @@ -1117,9 +1103,11 @@ let coq_unit_judge = let na2 = Name (Id.of_string "H") in fun () -> match !impossible_default_case with - | Some (id,type_of_id) -> - make_judge id type_of_id + | Some fn -> + let (id,type_of_id), ctx = fn () in + make_judge id type_of_id, ctx | None -> (* In case the constants id/ID are not defined *) make_judge (mkLambda (na1,mkProp,mkLambda(na2,mkRel 1,mkRel 1))) - (mkProd (na1,mkProp,mkArrow (mkRel 1) (mkRel 2))) + (mkProd (na1,mkProp,mkArrow (mkRel 1) (mkRel 2))), + Univ.ContextSet.empty diff --git a/pretyping/termops.mli b/pretyping/termops.mli index d0d3fd767..eec4a9b9d 100644 --- a/pretyping/termops.mli +++ b/pretyping/termops.mli @@ -13,18 +13,6 @@ open Context open Environ open Locus -(** TODO: merge this with Term *) - -(** Universes *) -val new_univ_level : unit -> Univ.universe_level -val set_remote_new_univ_level : Univ.universe_level RemoteCounter.installer -val new_univ : unit -> Univ.universe -val new_sort_in_family : sorts_family -> sorts -val new_Type : unit -> types -val new_Type_sort : unit -> sorts -val refresh_universes : types -> types -val refresh_universes_strict : types -> types - (** printers *) val print_sort : sorts -> std_ppcmds val pr_sort_family : sorts_family -> std_ppcmds @@ -120,6 +108,8 @@ val free_rels : constr -> Int.Set.t (** [dependent m t] tests whether [m] is a subterm of [t] *) val dependent : constr -> constr -> bool val dependent_no_evar : constr -> constr -> bool +val dependent_univs : constr -> constr -> bool +val dependent_univs_no_evar : constr -> constr -> bool val count_occurrences : constr -> constr -> int val collect_metas : constr -> int list val collect_vars : constr -> Id.Set.t (** for visible vars only *) @@ -168,7 +158,7 @@ val subst_closed_term_occ_gen : required too *) type 'a testing_function = { - match_fun : constr -> 'a; + match_fun : 'a -> constr -> 'a; merge_fun : 'a -> 'a -> 'a; mutable testing_state : 'a; mutable last_found : ((Id.t * hyp_location_flag) option * int * constr) option @@ -290,5 +280,5 @@ val on_judgment_value : (types -> types) -> unsafe_judgment -> unsafe_judgment val on_judgment_type : (types -> types) -> unsafe_judgment -> unsafe_judgment (** {6 Functions to deal with impossible cases } *) -val set_impossible_default_clause : constr * types -> unit -val coq_unit_judge : unit -> unsafe_judgment +val set_impossible_default_clause : (unit -> (constr * types) Univ.in_universe_context_set) -> unit +val coq_unit_judge : unit -> unsafe_judgment Univ.in_universe_context_set diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml index b5735bc64..fac73670b 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -20,7 +20,6 @@ open Typeclasses_errors open Libobject (*i*) - let (add_instance_hint, add_instance_hint_hook) = Hook.make () let add_instance_hint id = Hook.get add_instance_hint id @@ -64,6 +63,7 @@ type instance = { -1 for discard, 0 for none, mutable to avoid redeclarations when multiple rebuild_object happen. *) is_global: int; + is_poly: bool; is_impl: global_reference; } @@ -73,7 +73,7 @@ let instance_impl is = is.is_impl let instance_priority is = is.is_pri -let new_instance cl pri glob impl = +let new_instance cl pri glob poly impl = let global = if glob then Lib.sections_depth () else -1 @@ -81,6 +81,7 @@ let new_instance cl pri glob impl = { is_class = cl.cl_impl; is_pri = pri ; is_global = global ; + is_poly = poly; is_impl = impl } (* @@ -90,12 +91,35 @@ let new_instance cl pri glob impl = let classes : typeclasses ref = Summary.ref Refmap.empty ~name:"classes" let instances : instances ref = Summary.ref Refmap.empty ~name:"instances" +open Declarations + +let typeclass_univ_instance (cl,u') = + let subst = + let u = + match cl.cl_impl with + | ConstRef c -> + let cb = Global.lookup_constant c in + if cb.const_polymorphic then Univ.UContext.instance (Future.force cb.const_universes) + else Univ.Instance.empty + | IndRef c -> + let mib,oib = Global.lookup_inductive c in + if mib.mind_polymorphic then Univ.UContext.instance mib.mind_universes + else Univ.Instance.empty + | _ -> Univ.Instance.empty + in Array.fold_left2 (fun subst u u' -> Univ.LMap.add u u' subst) + Univ.LMap.empty (Univ.Instance.to_array u) (Univ.Instance.to_array u') + in + let subst_ctx = Context.map_rel_context (subst_univs_level_constr subst) in + { cl with cl_context = fst cl.cl_context, subst_ctx (snd cl.cl_context); + cl_props = subst_ctx cl.cl_props}, u' + let class_info c = try Refmap.find c !classes - with Not_found -> not_a_class (Global.env()) (constr_of_global c) + with Not_found -> not_a_class (Global.env()) (printable_constr_of_global c) let global_class_of_constr env c = - try class_info (global_of_constr c) + try let gr, u = Universes.global_of_constr c in + class_info gr, u with Not_found -> not_a_class env c let dest_class_app env c = @@ -110,16 +134,19 @@ let class_of_constr c = try Some (dest_class_arity (Global.env ()) c) with e when Errors.noncritical e -> None -let rec is_class_type evd c = - match kind_of_term c with - | Prod (_, _, t) -> is_class_type evd t - | Evar (e, _) when is_defined evd e -> is_class_type evd (Evarutil.nf_evar evd c) - | _ -> - begin match class_of_constr c with - | Some _ -> true - | None -> false - end +let is_class_constr c = + try let gr, u = Universes.global_of_constr c in + Refmap.mem gr !classes + with Not_found -> false +let rec is_class_type evd c = + let c, args = decompose_app c in + match kind_of_term c with + | Prod (_, _, t) -> is_class_type evd t + | Evar (e, _) when Evd.is_defined evd e -> + is_class_type evd (Evarutil.whd_head_evar evd c) + | _ -> is_class_constr c + let is_class_evar evd evi = is_class_type evd evi.Evd.evar_concl @@ -133,7 +160,7 @@ let load_class (_, cl) = let cache_class = load_class let subst_class (subst,cl) = - let do_subst_con c = fst (Mod_subst.subst_con subst c) + let do_subst_con c = Mod_subst.subst_constant subst c and do_subst c = Mod_subst.subst_mps subst c and do_subst_gr gr = fst (subst_global subst gr) in let do_subst_ctx ctx = List.smartmap @@ -142,7 +169,8 @@ let subst_class (subst,cl) = let do_subst_context (grs,ctx) = List.smartmap (Option.smartmap (fun (gr,b) -> do_subst_gr gr, b)) grs, do_subst_ctx ctx in - let do_subst_projs projs = List.smartmap (fun (x, y, z) -> (x, y, Option.smartmap do_subst_con z)) projs in + let do_subst_projs projs = List.smartmap (fun (x, y, z) -> + (x, y, Option.smartmap do_subst_con z)) projs in { cl_impl = do_subst_gr cl.cl_impl; cl_context = do_subst_context cl.cl_context; cl_props = do_subst_ctx cl.cl_props; @@ -174,7 +202,7 @@ let discharge_class (_,cl) = let newgrs = List.map (fun (_, _, t) -> match class_of_constr t with | None -> None - | Some (_, (tc, _)) -> Some (tc.cl_impl, true)) + | Some (_, ((tc,_), _)) -> Some (tc.cl_impl, true)) ctx' in List.smartmap (Option.smartmap (fun (gr, b) -> Lib.discharge_global gr, b)) grs @@ -182,7 +210,7 @@ let discharge_class (_,cl) = in grs', discharge_rel_context subst 1 ctx @ ctx' in let cl_impl' = Lib.discharge_global cl.cl_impl in if cl_impl' == cl.cl_impl then cl else - let ctx = abs_context cl in + let ctx, uctx = abs_context cl in let ctx, subst = rel_of_variable_context ctx in let context = discharge_context ctx subst cl.cl_context in let props = discharge_rel_context subst (succ (List.length (fst cl.cl_context))) cl.cl_props in @@ -217,7 +245,7 @@ let check_instance env sigma c = try let (evd, c) = resolve_one_typeclass env sigma (Retyping.get_type_of env sigma c) in - Evd.has_undefined evd + not (Evd.has_undefined evd) with e when Errors.noncritical e -> false let build_subclasses ~check env sigma glob pri = @@ -231,7 +259,7 @@ let build_subclasses ~check env sigma glob pri = let ty = Evarutil.nf_evar sigma (Retyping.get_type_of env sigma c) in match class_of_constr ty with | None -> [] - | Some (rels, (tc, args)) -> + | Some (rels, ((tc,u), args)) -> let instapp = Reductionops.whd_beta sigma (appvectc c (Termops.extended_rel_vect 0 rels)) in @@ -243,7 +271,7 @@ let build_subclasses ~check env sigma glob pri = | Some (Backward, _) -> None | Some (Forward, pri') -> let proj = Option.get proj in - let body = it_mkLambda_or_LetIn (mkApp (mkConst proj, projargs)) rels in + let body = it_mkLambda_or_LetIn (mkApp (mkConstU (proj,u), projargs)) rels in if check && check_instance env sigma body then None else let pri = @@ -259,7 +287,7 @@ let build_subclasses ~check env sigma glob pri = let rest = aux pri body path' in hints @ (path', pri, body) :: rest in List.fold_left declare_proj [] projs - in aux pri (constr_of_global glob) [glob] + in aux pri (Universes.constr_of_global glob) [glob] (* * instances persistent object @@ -305,9 +333,11 @@ let discharge_instance (_, (action, inst)) = let is_local i = Int.equal i.is_global (-1) let add_instance check inst = - add_instance_hint (IsGlobal inst.is_impl) [inst.is_impl] (is_local inst) inst.is_pri; + let poly = Global.is_polymorphic inst.is_impl in + add_instance_hint (IsGlobal inst.is_impl) [inst.is_impl] (is_local inst) + inst.is_pri poly; List.iter (fun (path, pri, c) -> add_instance_hint (IsConstr c) path - (is_local inst) pri) + (is_local inst) pri poly) (build_subclasses ~check:(check && not (isVarRef inst.is_impl)) (Global.env ()) Evd.empty inst.is_impl inst.is_pri) @@ -342,11 +372,10 @@ let remove_instance i = remove_instance_hint i.is_impl let declare_instance pri local glob = - let c = constr_of_global glob in - let ty = Retyping.get_type_of (Global.env ()) Evd.empty c in + let ty = Global.type_of_global_unsafe (*FIXME*) glob in match class_of_constr ty with - | Some (rels, (tc, args) as _cl) -> - add_instance (new_instance tc pri (not local) glob) + | Some (rels, ((tc,_), args) as _cl) -> + add_instance (new_instance tc pri (not local) (Flags.use_polymorphic_flag ()) glob) (* let path, hints = build_subclasses (not local) (Global.env ()) Evd.empty glob in *) (* let entries = List.map (fun (path, pri, c) -> (pri, local, path, c)) hints in *) (* Auto.add_hints local [typeclasses_db] (Auto.HintsResolveEntry entries); *) @@ -367,9 +396,9 @@ let add_class cl = open Declarations - +(* FIXME: deal with universe instances *) let add_constant_class cst = - let ty = Typeops.type_of_constant (Global.env ()) cst in + let ty = Typeops.type_of_constant_in (Global.env ()) (cst,Univ.Instance.empty) in let ctx, arity = decompose_prod_assum ty in let tc = { cl_impl = ConstRef cst; @@ -386,7 +415,8 @@ let add_inductive_class ind = let ctx = oneind.mind_arity_ctxt in let ty = Inductive.type_of_inductive_knowing_parameters (push_rel_context ctx (Global.env ())) - oneind (Array.map (fun x -> lazy x) (Termops.extended_rel_vect 0 ctx)) + ((mind,oneind),Univ.Instance.empty) + (Array.map (fun x -> lazy x) (Termops.extended_rel_vect 0 ctx)) in { cl_impl = IndRef ind; cl_context = List.map (const None) ctx, ctx; @@ -398,7 +428,7 @@ let add_inductive_class ind = * interface functions *) -let instance_constructor cl args = +let instance_constructor (cl,u) args = let filter (_, b, _) = match b with | None -> true | Some _ -> false @@ -406,14 +436,17 @@ let instance_constructor cl args = let lenpars = List.length (List.filter filter (snd cl.cl_context)) in let pars = fst (List.chop lenpars args) in match cl.cl_impl with - | IndRef ind -> Some (applistc (mkConstruct (ind, 1)) args), - applistc (mkInd ind) pars + | IndRef ind -> + let ind = ind, u in + (Some (applistc (mkConstructUi (ind, 1)) args), + applistc (mkIndU ind) pars) | ConstRef cst -> + let cst = cst, u in let term = match args with - | [] -> None - | _ -> Some (List.last args) + | [] -> None + | _ -> Some (List.last args) in - term, applistc (mkConst cst) pars + (term, applistc (mkConstU cst) pars) | _ -> assert false let typeclasses () = Refmap.fold (fun _ l c -> l :: c) !classes [] @@ -504,12 +537,19 @@ let mark_resolvables sigma = mark_resolvability all_evars true sigma let has_typeclasses filter evd = let check ev evi = - filter ev (snd evi.evar_source) && is_class_evar evd evi && is_resolvable evi + filter ev (snd evi.evar_source) && is_resolvable evi && is_class_evar evd evi in Evar.Map.exists check (Evd.undefined_map evd) let solve_instanciations_problem = ref (fun _ _ _ _ _ -> assert false) +let solve_problem env evd filter split fail = + !solve_instanciations_problem env evd filter split fail + +(** Profiling resolution of typeclasses *) +(* let solve_classeskey = Profile.declare_profile "solve_typeclasses" *) +(* let solve_problem = Profile.profile5 solve_classeskey solve_problem *) + let resolve_typeclasses ?(filter=no_goals) ?(split=true) ?(fail=true) env evd = if not (has_typeclasses filter evd) then evd - else !solve_instanciations_problem env evd filter split fail + else solve_problem env evd filter split fail diff --git a/pretyping/typeclasses.mli b/pretyping/typeclasses.mli index c36293525..a8ce9ca7c 100644 --- a/pretyping/typeclasses.mli +++ b/pretyping/typeclasses.mli @@ -48,18 +48,24 @@ val add_constant_class : constant -> unit val add_inductive_class : inductive -> unit -val new_instance : typeclass -> int option -> bool -> global_reference -> instance +val new_instance : typeclass -> int option -> bool -> Decl_kinds.polymorphic -> + global_reference -> instance val add_instance : instance -> unit val remove_instance : instance -> unit val class_info : global_reference -> typeclass (** raises a UserError if not a class *) -(** These raise a UserError if not a class. *) -val dest_class_app : env -> constr -> typeclass * constr list +(** These raise a UserError if not a class. + Caution: the typeclass structures is not instantiated w.r.t. the universe instance. + This is done separately by typeclass_univ_instance. *) +val dest_class_app : env -> constr -> typeclass puniverses * constr list + +(** Get the instantiated typeclass structure for a given universe instance. *) +val typeclass_univ_instance : typeclass puniverses -> typeclass puniverses (** Just return None if not a class *) -val class_of_constr : constr -> (rel_context * (typeclass * constr list)) option +val class_of_constr : constr -> (rel_context * (typeclass puniverses * constr list)) option val instance_impl : instance -> global_reference @@ -73,7 +79,8 @@ val is_implicit_arg : Evar_kinds.t -> bool (** Returns the term and type for the given instance of the parameters and fields of the type class. *) -val instance_constructor : typeclass -> constr list -> constr option * types +val instance_constructor : typeclass puniverses -> constr list -> + constr option * types (** Filter which evars to consider for resolution. *) type evar_filter = existential_key -> Evar_kinds.t -> bool @@ -104,10 +111,10 @@ val classes_transparent_state : unit -> transparent_state val add_instance_hint_hook : (global_reference_or_constr -> global_reference list -> - bool (* local? *) -> int option -> unit) Hook.t + bool (* local? *) -> int option -> Decl_kinds.polymorphic -> unit) Hook.t val remove_instance_hint_hook : (global_reference -> unit) Hook.t val add_instance_hint : global_reference_or_constr -> global_reference list -> - bool -> int option -> unit + bool -> int option -> Decl_kinds.polymorphic -> unit val remove_instance_hint : global_reference -> unit val solve_instanciations_problem : (env -> evar_map -> evar_filter -> bool -> bool -> evar_map) ref diff --git a/pretyping/typing.ml b/pretyping/typing.ml index 0cd9099e3..bd559ddd5 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -27,12 +27,12 @@ let meta_type evd mv = let constant_type_knowing_parameters env cst jl = let paramstyp = Array.map (fun j -> lazy j.uj_type) jl in - type_of_constant_knowing_parameters env (constant_type env cst) paramstyp + type_of_constant_knowing_parameters env (constant_type_in env cst) paramstyp -let inductive_type_knowing_parameters env ind jl = - let (mib,mip) = lookup_mind_specif env ind in +let inductive_type_knowing_parameters env (ind,u) jl = + let mspec = lookup_mind_specif env ind in let paramstyp = Array.map (fun j -> lazy j.uj_type) jl in - Inductive.type_of_inductive_knowing_parameters env mip paramstyp + Inductive.type_of_inductive_knowing_parameters env (mspec,u) paramstyp let e_type_judgment env evdref j = match kind_of_term (whd_betadeltaiota env !evdref j.uj_type) with @@ -69,12 +69,12 @@ let e_judge_of_apply env evdref funj argjv = in apply_rec 1 funj.uj_type (Array.to_list argjv) -let e_check_branch_types env evdref ind cj (lfj,explft) = +let e_check_branch_types env evdref (ind,u) cj (lfj,explft) = if not (Int.equal (Array.length lfj) (Array.length explft)) then error_number_branches env cj (Array.length explft); for i = 0 to Array.length explft - 1 do if not (Evarconv.e_cumul env evdref lfj.(i).uj_type explft.(i)) then - error_ill_formed_branch env cj.uj_val (ind,i+1) lfj.(i).uj_type explft.(i) + error_ill_formed_branch env cj.uj_val ((ind,i+1),u) lfj.(i).uj_type explft.(i) done let max_sort l = @@ -95,8 +95,8 @@ let e_is_correct_arity env evdref c pj ind specif params = if not (Sorts.List.mem (Sorts.family s) allowed_sorts) then error () | Evar (ev,_), [] -> - let s = Termops.new_sort_in_family (max_sort allowed_sorts) in - evdref := Evd.define ev (mkSort s) !evdref + let evd, s = Evd.fresh_sort_in_family env !evdref (max_sort allowed_sorts) in + evdref := Evd.define ev (mkSort s) evd | _, (_,Some _,_ as d)::ar' -> srec (push_rel d env) (lift 1 pt') ar' | _ -> @@ -105,7 +105,7 @@ let e_is_correct_arity env evdref c pj ind specif params = srec env pj.uj_type (List.rev arsign) let e_type_case_branches env evdref (ind,largs) pj c = - let specif = lookup_mind_specif env ind in + let specif = lookup_mind_specif env (fst ind) in let nparams = inductive_params specif in let (params,realargs) = List.chop nparams largs in let p = pj.uj_val in @@ -126,10 +126,11 @@ let e_judge_of_case env evdref ci pj cj lfj = { uj_val = mkCase (ci, pj.uj_val, cj.uj_val, Array.map j_val lfj); uj_type = rslty } +(* FIXME: might depend on the level of actual parameters!*) let check_allowed_sort env sigma ind c p = let pj = Retyping.get_judgment_of env sigma p in let ksort = family_of_sort (sort_of_arity env sigma pj.uj_type) in - let specif = Global.lookup_inductive ind in + let specif = Global.lookup_inductive (fst ind) in let sorts = elim_sorts specif in if not (List.exists ((==) ksort) sorts) then let s = inductive_sort_family (snd specif) in @@ -196,7 +197,11 @@ let rec execute env evdref cstr = judge_of_prop_contents c | Sort (Type u) -> - judge_of_type u + judge_of_type u + + | Proj (p, c) -> + let cj = execute env evdref c in + judge_of_projection env p (Evarutil.j_nf_evar !evdref cj) | App (f,args) -> let jl = execute_array env evdref args in @@ -236,7 +241,7 @@ let rec execute env evdref cstr = let j1 = execute env evdref c1 in let j2 = execute env evdref c2 in let j2 = e_type_judgment env evdref j2 in - let _ = judge_of_cast env j1 DEFAULTcast j2 in + let _ = e_judge_of_cast env evdref j1 DEFAULTcast j2 in let env1 = push_rel (name,Some j1.uj_val,j2.utj_val) env in let j3 = execute env1 evdref c3 in judge_of_letin env name j1 j2 j3 @@ -268,9 +273,7 @@ let check env evd c t = let type_of env evd c = let j = execute env (ref evd) c in - (* We are outside the kernel: we take fresh universes *) - (* to avoid tactics and co to refresh universes themselves *) - Termops.refresh_universes j.uj_type + j.uj_type (* Sort of a type *) @@ -286,7 +289,7 @@ let e_type_of env evd c = let evdref = ref evd in let j = execute env evdref c in (* side-effect on evdref *) - !evdref, Termops.refresh_universes j.uj_type + !evdref, j.uj_type let solve_evars env evdref c = let c = (execute env evdref c).uj_val in diff --git a/pretyping/typing.mli b/pretyping/typing.mli index 084bdbc4f..8b194a9c9 100644 --- a/pretyping/typing.mli +++ b/pretyping/typing.mli @@ -34,5 +34,5 @@ val solve_evars : env -> evar_map ref -> constr -> constr (** Raise an error message if incorrect elimination for this inductive *) (** (first constr is term to match, second is return predicate) *) -val check_allowed_sort : env -> evar_map -> inductive -> constr -> constr -> +val check_allowed_sort : env -> evar_map -> pinductive -> constr -> constr -> unit diff --git a/pretyping/unification.ml b/pretyping/unification.ml index bfcc469c5..f7379b4a0 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -33,7 +33,9 @@ let occur_meta_or_undefined_evar evd c = | Evar_defined c -> occrec c; Array.iter occrec args | Evar_empty -> raise Occur) - | Sort s when is_sort_variable evd s -> raise Occur + (* | Sort (Type _) (\* FIXME could be finer *\) -> raise Occur *) + | Const (_, i) (* | Ind (_, i) | Construct (_, i) *) + when not (Univ.Instance.is_empty i) -> raise Occur | _ -> iter_constr occrec c in try occrec c; false with Occur | Not_found -> true @@ -49,16 +51,19 @@ let occur_meta_evd sigma mv c = (* if lname_typ is [xn,An;..;x1,A1] and l is a list of terms, gives [x1:A1]..[xn:An]c' such that c converts to ([x1:A1]..[xn:An]c' l) *) -let abstract_scheme env c l lname_typ = +let abstract_scheme env evd c l lname_typ = List.fold_left2 - (fun t (locc,a) (na,_,ta) -> + (fun (t,evd) (locc,a) (na,_,ta) -> let na = match kind_of_term a with Var id -> Name id | _ -> na in (* [occur_meta ta] test removed for support of eelim/ecase but consequences are unclear... if occur_meta ta then error "cannot find a type for the generalisation" - else *) if occur_meta a then mkLambda_name env (na,ta,t) - else mkLambda_name env (na,ta,subst_closed_term_occ locc a t)) - c + else *) + if occur_meta a then mkLambda_name env (na,ta,t), evd + else + let t', evd' = Tacred.subst_closed_term_univs_occ evd locc a t in + mkLambda_name env (na,ta,t'), evd') + (c,evd) (List.rev l) lname_typ @@ -67,15 +72,15 @@ let abstract_scheme env c l lname_typ = let abstract_list_all env evd typ c l = let ctxt,_ = splay_prod_n env evd (List.length l) typ in let l_with_all_occs = List.map (function a -> (AllOccurrences,a)) l in - let p = abstract_scheme env c l_with_all_occs ctxt in - let typp = - try Typing.type_of env evd p + let p,evd = abstract_scheme env evd c l_with_all_occs ctxt in + let evd,typp = + try Typing.e_type_of env evd p with | UserError _ -> error_cannot_find_well_typed_abstraction env evd p l None | Type_errors.TypeError (env',x) -> error_cannot_find_well_typed_abstraction env evd p l (Some (env',x)) in - (p,typp) + evd,(p,typp) let set_occurrences_of_last_arg args = Some AllOccurrences :: List.tl (Array.map_to_list (fun _ -> None) args) @@ -88,7 +93,7 @@ let abstract_list_all_with_dependencies env evd typ c l = Evarconv.second_order_matching empty_transparent_state env evd ev' argoccs c in let p = nf_evar evd (existential_value evd (destEvar ev)) in - if b then p else error_cannot_find_well_typed_abstraction env evd p l None + if b then evd, p else error_cannot_find_well_typed_abstraction env evd p l None (**) @@ -251,11 +256,12 @@ type unify_flags = { (* Default flag for unifying a type against a type (e.g. apply) *) (* We set all conversion flags (no flag should be modified anymore) *) -let default_unify_flags = { - modulo_conv_on_closed_terms = Some full_transparent_state; +let default_unify_flags () = + let ts = Names.full_transparent_state in + { modulo_conv_on_closed_terms = Some ts; use_metas_eagerly_in_conv_on_closed_terms = true; - modulo_delta = full_transparent_state; - modulo_delta_types = full_transparent_state; + modulo_delta = ts; + modulo_delta_types = ts; modulo_delta_in_merge = None; check_applied_meta_types = true; resolve_evars = false; @@ -279,7 +285,7 @@ let set_merge_flags flags = (* type against a type (e.g. apply) *) (* We set only the flags available at the time the new "apply" extends *) (* out of "simple apply" *) -let default_no_delta_unify_flags = { default_unify_flags with +let default_no_delta_unify_flags () = { (default_unify_flags ()) with modulo_delta = empty_transparent_state; check_applied_meta_types = false; use_pattern_unification = false; @@ -292,13 +298,13 @@ let default_no_delta_unify_flags = { default_unify_flags with (* allow_K) because only closed terms are involved in *) (* induction/destruct/case/elim and w_unify_to_subterm_list does not *) (* call w_unify for induction/destruct/case/elim (13/6/2011) *) -let elim_flags = { default_unify_flags with +let elim_flags () = { (default_unify_flags ()) with restrict_conv_on_strict_subterms = false; (* ? *) modulo_betaiota = false; allow_K_in_toplevel_higher_order_unification = true } -let elim_no_delta_flags = { elim_flags with +let elim_no_delta_flags () = { (elim_flags ()) with modulo_delta = empty_transparent_state; check_applied_meta_types = false; use_pattern_unification = false; @@ -314,10 +320,28 @@ let use_metas_pattern_unification flags nb l = flags.use_meta_bound_pattern_unification) && Array.for_all (fun c -> isRel c && destRel c <= nb) l -let expand_key env = function - | Some (ConstKey cst) -> constant_opt_value env cst - | Some (VarKey id) -> (try named_body id env with Not_found -> None) - | Some (RelKey _) -> None +type key = + | IsKey of Closure.table_key + | IsProj of constant * constr + +let expand_table_key env = function + | ConstKey cst -> constant_opt_value_in env cst + | VarKey id -> (try named_body id env with Not_found -> None) + | RelKey _ -> None + +let unfold_projection env p stk = + (match try Some (lookup_projection p env) with Not_found -> None with + | Some pb -> + let s = Stack.Proj (pb.Declarations.proj_npars, pb.Declarations.proj_arg, p) in + s :: stk + | None -> assert false) + +let expand_key ts env sigma = function + | Some (IsKey k) -> expand_table_key env k + | Some (IsProj (p, c)) -> + let red = Stack.zip (fst (whd_betaiota_deltazeta_for_iota_state ts env sigma + Cst_stack.empty (c, unfold_projection env p []))) + in if eq_constr (mkProj (p, c)) red then None else Some red | None -> None let subterm_restriction is_subterm flags = @@ -326,14 +350,24 @@ let subterm_restriction is_subterm flags = let key_of env b flags f = if subterm_restriction b flags then None else match kind_of_term f with - | Const cst when is_transparent env (ConstKey cst) && - Cpred.mem cst (snd flags.modulo_delta) -> - Some (ConstKey cst) - | Var id when is_transparent env (VarKey id) && - Id.Pred.mem id (fst flags.modulo_delta) -> - Some (VarKey id) + | Const (cst, u) when Cpred.mem cst (snd flags.modulo_delta) -> + Some (IsKey (ConstKey (cst, u))) + | Var id when Id.Pred.mem id (fst flags.modulo_delta) -> + Some (IsKey (VarKey id)) + | Proj (p, c) when Cpred.mem p (snd flags.modulo_delta) -> + Some (IsProj (p, c)) | _ -> None + +let translate_key = function + | ConstKey (cst,u) -> ConstKey cst + | VarKey id -> VarKey id + | RelKey n -> RelKey n + +let translate_key = function + | IsKey k -> translate_key k + | IsProj (c, _) -> ConstKey c + let oracle_order env cf1 cf2 = match cf1 with | None -> @@ -344,8 +378,36 @@ let oracle_order env cf1 cf2 = match cf2 with | None -> Some true | Some k2 -> - Some (Conv_oracle.oracle_order (Environ.oracle env) false k1 k2) + Some (Conv_oracle.oracle_order (Environ.oracle env) false (translate_key k1) (translate_key k2)) + +let is_rigid_head flags t = + match kind_of_term t with + | Const (cst,u) -> not (Cpred.mem cst (snd flags.modulo_delta)) + | Ind (i,u) -> true + | _ -> false +let force_eqs c = + Univ.UniverseConstraints.fold + (fun ((l,d,r) as c) acc -> + let c' = if d == Univ.ULub then (l,Univ.UEq,r) else c in + Univ.UniverseConstraints.add c' acc) + c Univ.UniverseConstraints.empty + +let constr_cmp pb sigma flags t u = + let b, cstrs = + if pb == Reduction.CONV then eq_constr_universes t u + else leq_constr_universes t u + in + if b then + try Evd.add_universe_constraints sigma cstrs, b + with Univ.UniverseInconsistency _ -> sigma, false + | Evd.UniversesDiffer -> + if is_rigid_head flags t then + try Evd.add_universe_constraints sigma (force_eqs cstrs), b + with Univ.UniverseInconsistency _ -> sigma, false + else sigma, false + else sigma, b + let do_reduce ts (env, nb) sigma c = Stack.zip (fst (whd_betaiota_deltazeta_for_iota_state ts env sigma Cst_stack.empty (c, Stack.empty))) @@ -356,14 +418,14 @@ let isAllowedEvar flags c = match kind_of_term c with | Evar (evk,_) -> not (Evar.Set.mem evk flags.frozen_evars) | _ -> false -let check_compatibility env (sigma,metasubst,evarsubst) tyM tyN = +let check_compatibility env flags (sigma,metasubst,evarsubst) tyM tyN = match subst_defined_metas metasubst tyM with | None -> () | Some m -> match subst_defined_metas metasubst tyN with | None -> () | Some n -> - if not (is_trans_fconv CONV full_transparent_state env sigma m n) + if not (is_trans_fconv CONV flags.modulo_delta env sigma m n) && is_ground_term sigma m && is_ground_term sigma n then error_cannot_unify env sigma (m,n) @@ -379,7 +441,7 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag if wt && flags.check_applied_meta_types then (let tyM = Typing.meta_type sigma k1 in let tyN = Typing.meta_type sigma k2 in - check_compatibility curenv substn tyM tyN); + check_compatibility curenv flags substn tyM tyN); if k2 < k1 then sigma,(k1,cN,stN)::metasubst,evarsubst else sigma,(k2,cM,stM)::metasubst,evarsubst | Meta k, _ @@ -388,7 +450,7 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag (try let tyM = Typing.meta_type sigma k in let tyN = get_type_of curenv ~lax:true sigma cN in - check_compatibility curenv substn tyM tyN + check_compatibility curenv flags substn tyM tyN with RetypeError _ -> (* Renounce, maybe metas/evars prevents typing *) ()); (* Here we check that [cN] does not contain any local variables *) @@ -405,7 +467,7 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag (try let tyM = get_type_of curenv ~lax:true sigma cM in let tyN = Typing.meta_type sigma k in - check_compatibility curenv substn tyM tyN + check_compatibility curenv flags substn tyM tyN with RetypeError _ -> (* Renounce, maybe metas/evars prevents typing *) ()); (* Here we check that [cM] does not contain any local variables *) @@ -431,7 +493,7 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag | Sort s1, Sort s2 -> (try let sigma' = - if cv_pb == CUMUL + if pb == CUMUL then Evd.set_leq_sort sigma s1 s2 else Evd.set_eq_sort sigma s1 s2 in (sigma', metasubst, evarsubst) @@ -455,6 +517,8 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag unirec_rec (push (na,t2) curenvnb) CONV true wt substn (mkApp (lift 1 cM,[|mkRel 1|])) c2 + (* TODO: eta for records *) + | Case (_,p1,c1,cl1), Case (_,p2,c2,cl2) -> (try Array.fold_left2 (unirec_rec curenvnb CONV true wt) @@ -493,6 +557,22 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag | App (f1,l1), App (f2,l2) -> unify_app curenvnb pb b substn cM f1 l1 cN f2 l2 + | Proj (p1,c1), Proj (p2,c2) -> + if eq_constant p1 p2 then + try + let c1, c2, substn = + if isCast c1 && isCast c2 then + let (c1,_,tc1) = destCast c1 in + let (c2,_,tc2) = destCast c2 in + c1, c2, unirec_rec curenvnb CONV true false substn tc1 tc2 + else c1, c2, substn + in + unirec_rec curenvnb CONV true wt substn c1 c2 + with ex when precatchable_exception ex -> + unify_not_same_head curenvnb pb b wt substn cM cN + else + unify_not_same_head curenvnb pb b wt substn cM cN + | _ -> unify_not_same_head curenvnb pb b wt substn cM cN @@ -508,20 +588,22 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag with ex when precatchable_exception ex -> expand curenvnb pb b false substn cM f1 l1 cN f2 l2 - and unify_not_same_head curenvnb pb b wt substn cM cN = + and unify_not_same_head curenvnb pb b wt (sigma, metas, evars as substn) cM cN = try canonical_projections curenvnb pb b cM cN substn with ex when precatchable_exception ex -> - if constr_cmp cv_pb cM cN then substn else - try reduce curenvnb pb b wt substn cM cN - with ex when precatchable_exception ex -> - let (f1,l1) = - match kind_of_term cM with App (f,l) -> (f,l) | _ -> (cM,[||]) in - let (f2,l2) = - match kind_of_term cN with App (f,l) -> (f,l) | _ -> (cN,[||]) in - expand curenvnb pb b wt substn cM f1 l1 cN f2 l2 + let sigma', b = constr_cmp cv_pb sigma flags cM cN in + if b then (sigma', metas, evars) + else + try reduce curenvnb pb b wt substn cM cN + with ex when precatchable_exception ex -> + let (f1,l1) = + match kind_of_term cM with App (f,l) -> (f,l) | _ -> (cM,[||]) in + let (f2,l2) = + match kind_of_term cN with App (f,l) -> (f,l) | _ -> (cN,[||]) in + expand curenvnb pb b wt substn cM f1 l1 cN f2 l2 and reduce curenvnb pb b wt (sigma, metas, evars as substn) cM cN = - if use_full_betaiota flags && not (subterm_restriction b flags) then + if not (subterm_restriction b flags) && use_full_betaiota flags then let cM' = do_reduce flags.modulo_delta curenvnb sigma cM in if not (eq_constr cM cM') then unirec_rec curenvnb pb b wt substn cM' cN @@ -530,12 +612,10 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag if not (eq_constr cN cN') then unirec_rec curenvnb pb b wt substn cM cN' else error_cannot_unify (fst curenvnb) sigma (cM,cN) - else - error_cannot_unify (fst curenvnb) sigma (cM,cN) + else error_cannot_unify (fst curenvnb) sigma (cM,cN) - and expand (curenv,_ as curenvnb) pb b wt (sigma,metasubst,_ as substn) cM f1 l1 cN f2 l2 = - - if + and expand (curenv,_ as curenvnb) pb b wt (sigma,metasubst,evarsubst as substn) cM f1 l1 cN f2 l2 = + let res = (* Try full conversion on meta-free terms. *) (* Back to 1995 (later on called trivial_unify in 2002), the heuristic was to apply conversion on meta-free (but not @@ -548,48 +628,50 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag (it is used by apply and rewrite); it might now be redundant with the support for delta-expansion (which is used essentially for apply)... *) - not (subterm_restriction b flags) && + if subterm_restriction b flags then None else match flags.modulo_conv_on_closed_terms with - | None -> false + | None -> None | Some convflags -> let subst = if flags.use_metas_eagerly_in_conv_on_closed_terms then metasubst else ms in match subst_defined_metas subst cM with - | None -> (* some undefined Metas in cM *) false + | None -> (* some undefined Metas in cM *) None | Some m1 -> match subst_defined_metas subst cN with - | None -> (* some undefined Metas in cN *) false + | None -> (* some undefined Metas in cN *) None | Some n1 -> (* No subterm restriction there, too much incompatibilities *) - if is_trans_fconv pb convflags env sigma m1 n1 - then true else - if is_ground_term sigma m1 && is_ground_term sigma n1 then - error_cannot_unify curenv sigma (cM,cN) - else false - then - substn - else + let b = check_conv ~pb ~ts:convflags env sigma m1 n1 in + if b then Some (sigma, metasubst, evarsubst) + else + if is_ground_term sigma m1 && is_ground_term sigma n1 then + error_cannot_unify curenv sigma (cM,cN) + else None + in + match res with + | Some substn -> substn + | None -> let cf1 = key_of env b flags f1 and cf2 = key_of env b flags f2 in match oracle_order curenv cf1 cf2 with | None -> error_cannot_unify curenv sigma (cM,cN) | Some true -> - (match expand_key curenv cf1 with + (match expand_key flags.modulo_delta curenv sigma cf1 with | Some c -> unirec_rec curenvnb pb b wt substn (whd_betaiotazeta sigma (mkApp(c,l1))) cN | None -> - (match expand_key curenv cf2 with + (match expand_key flags.modulo_delta curenv sigma cf2 with | Some c -> unirec_rec curenvnb pb b wt substn cM (whd_betaiotazeta sigma (mkApp(c,l2))) | None -> error_cannot_unify curenv sigma (cM,cN))) | Some false -> - (match expand_key curenv cf2 with + (match expand_key flags.modulo_delta curenv sigma cf2 with | Some c -> unirec_rec curenvnb pb b wt substn cM (whd_betaiotazeta sigma (mkApp(c,l2))) | None -> - (match expand_key curenv cf1 with + (match expand_key flags.modulo_delta curenv sigma cf1 with | Some c -> unirec_rec curenvnb pb b wt substn (whd_betaiotazeta sigma (mkApp(c,l1))) cN @@ -623,11 +705,12 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag else error_cannot_unify (fst curenvnb) sigma (cM,cN) and solve_canonical_projection curenvnb pb b cM f1l1 cN f2l2 (sigma,ms,es) = - let (c,bs,(params,params1),(us,us2),(ts,ts1),c1,(n,t2)) = + let (ctx,c,bs,(params,params1),(us,us2),(ts,ts1),c1,(n,t2)) = try Evarconv.check_conv_record f1l1 f2l2 with Not_found -> error_cannot_unify (fst curenvnb) sigma (cM,cN) in if Reductionops.Stack.compare_shape ts ts1 then + let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx in let (evd,ks,_) = List.fold_left (fun (evd,ks,m) b -> @@ -652,19 +735,24 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag else error_cannot_unify (fst curenvnb) sigma (cM,cN) in let evd = sigma in - if (if occur_meta_or_undefined_evar evd m || occur_meta_or_undefined_evar evd n - || subterm_restriction conv_at_top flags then false - else if (match flags.modulo_conv_on_closed_terms with - | Some convflags -> is_trans_fconv cv_pb convflags env sigma m n - | _ -> constr_cmp cv_pb m n) then true - else if (match flags.modulo_conv_on_closed_terms, flags.modulo_delta with + let res = + if occur_meta_or_undefined_evar evd m || occur_meta_or_undefined_evar evd n + || subterm_restriction conv_at_top flags then None + else + let sigma, b = match flags.modulo_conv_on_closed_terms with + | Some convflags -> infer_conv ~pb:cv_pb ~ts:convflags env sigma m n + | _ -> constr_cmp cv_pb sigma flags m n in + if b then Some sigma + else if (match flags.modulo_conv_on_closed_terms, flags.modulo_delta with | Some (cv_id, cv_k), (dl_id, dl_k) -> Id.Pred.subset dl_id cv_id && Cpred.subset dl_k cv_k | None,(dl_id, dl_k) -> Id.Pred.is_empty dl_id && Cpred.is_empty dl_k) - then error_cannot_unify env sigma (m, n) else false) - then subst - else unirec_rec (env,0) cv_pb conv_at_top false subst m n + then error_cannot_unify env sigma (m, n) else None + in + match res with + | Some sigma -> sigma, ms, es + | None -> unirec_rec (env,0) cv_pb conv_at_top false subst m n let unify_0 env sigma = unify_0_with_initial_metas (sigma,[],[]) true env @@ -792,7 +880,7 @@ let applyHead env evd n c = let is_mimick_head ts f = match kind_of_term f with - | Const c -> not (Closure.is_transparent_constant ts c) + | Const (c,u) -> not (Closure.is_transparent_constant ts c) | Var id -> not (Closure.is_transparent_variable ts id) | (Rel _|Construct _|Ind _) -> true | _ -> false @@ -820,7 +908,7 @@ let w_coerce env evd mv c = w_coerce_to_type env evd c cty mvty let unify_to_type env sigma flags c status u = - let c = refresh_universes c in + let sigma, c = refresh_universes false sigma c in let t = get_type_of env sigma (nf_meta sigma c) in let t = nf_betaiota sigma (nf_meta sigma t) in unify_0 env sigma CUMUL flags t u @@ -957,7 +1045,7 @@ let w_merge env with_types flags (evd,metas,evars) = (* merge constraints *) w_merge_rec evd (order_metas metas) (List.rev evars) [] -let w_unify_meta_types env ?(flags=default_unify_flags) evd = +let w_unify_meta_types env ?(flags=default_unify_flags ()) evd = let metas,evd = retract_coercible_metas evd in w_merge env true flags (evd,metas,[]) @@ -1032,7 +1120,7 @@ let iter_fail f a = (* Tries to find an instance of term [cl] in term [op]. Unifies [cl] to every subterm of [op] until it finds a match. Fails if no match is found *) -let w_unify_to_subterm env evd ?(flags=default_unify_flags) (op,cl) = +let w_unify_to_subterm env evd ?(flags=default_unify_flags ()) (op,cl) = let rec matchrec cl = let cl = strip_outer_cast cl in (try @@ -1061,6 +1149,8 @@ let w_unify_to_subterm env evd ?(flags=default_unify_flags) (op,cl) = with ex when precatchable_exception ex -> matchrec c2) + | Proj (p,c) -> matchrec c + | Fix(_,(_,types,terms)) -> (try iter_fail matchrec types @@ -1092,7 +1182,7 @@ let w_unify_to_subterm env evd ?(flags=default_unify_flags) (op,cl) = (* Tries to find all instances of term [cl] in term [op]. Unifies [cl] to every subterm of [op] and return all the matches. Fails if no match is found *) -let w_unify_to_subterm_all env evd ?(flags=default_unify_flags) (op,cl) = +let w_unify_to_subterm_all env evd ?(flags=default_unify_flags ()) (op,cl) = let return a b = let (evd,c as a) = a () in if List.exists (fun (evd',c') -> eq_constr c c') b then b else a :: b @@ -1130,6 +1220,8 @@ let w_unify_to_subterm_all env evd ?(flags=default_unify_flags) (op,cl) = | Case(_,_,c,lf) -> (* does not search in the predicate *) bind (matchrec c) (bind_iter matchrec lf) + | Proj (p,c) -> matchrec c + | LetIn(_,c1,_,c2) -> bind (matchrec c1) (matchrec c2) @@ -1173,7 +1265,8 @@ let w_unify_to_subterm_list env evd flags hdmeta oplist t = List.exists (fun op -> eq_constr op cl) l then error_non_linear_unification env evd hdmeta cl else (evd',cl::l) - else if flags.allow_K_in_toplevel_higher_order_unification || dependent op t + else if flags.allow_K_in_toplevel_higher_order_unification + || dependent_univs op t then (evd,op::l) else @@ -1187,15 +1280,24 @@ let secondOrderAbstraction env evd flags typ (p, oplist) = let flags = { flags with modulo_delta = (fst flags.modulo_delta, Cpred.empty) } in let (evd',cllist) = w_unify_to_subterm_list env evd flags p oplist typ in let typp = Typing.meta_type evd' p in - let pred,predtyp = abstract_list_all env evd' typp typ cllist in - if not (is_conv_leq env evd predtyp typp) then - error_wrong_abstraction_type env evd - (Evd.meta_name evd p) pred typp predtyp; - w_merge env false flags (evd',[p,pred,(Conv,TypeProcessed)],[]) + let evd',(pred,predtyp) = abstract_list_all env evd' typp typ cllist in + let evd', b = infer_conv ~pb:CUMUL env evd' predtyp typp in + if not b then + error_wrong_abstraction_type env evd' + (Evd.meta_name evd p) pred typp predtyp; + w_merge env false flags (evd',[p,pred,(Conv,TypeProcessed)],[]) + + (* let evd',metas,evars = *) + (* try unify_0 env evd' CUMUL flags predtyp typp *) + (* with NotConvertible -> *) + (* error_wrong_abstraction_type env evd *) + (* (Evd.meta_name evd p) pred typp predtyp *) + (* in *) + (* w_merge env false flags (evd',(p,pred,(Conv,TypeProcessed))::metas,evars) *) let secondOrderDependentAbstraction env evd flags typ (p, oplist) = let typp = Typing.meta_type evd p in - let pred = abstract_list_all_with_dependencies env evd typp typ oplist in + let evd, pred = abstract_list_all_with_dependencies env evd typp typ oplist in w_merge env false flags (evd,[p,pred,(Conv,TypeProcessed)],[]) let secondOrderAbstractionAlgo dep = @@ -1233,7 +1335,7 @@ let w_unify2 env evd flags dep cv_pb ty1 ty2 = Before, second-order was used if the type of Meta(1) and [x:A]t was convertible and first-order otherwise. But if failed if e.g. the type of Meta(1) had meta-variables in it. *) -let w_unify env evd cv_pb ?(flags=default_unify_flags) ty1 ty2 = +let w_unify env evd cv_pb ?(flags=default_unify_flags ()) ty1 ty2 = let hd1,l1 = decompose_appvect (whd_nored evd ty1) in let hd2,l2 = decompose_appvect (whd_nored evd ty2) in let is_empty1 = Array.is_empty l1 in @@ -1267,3 +1369,14 @@ let w_unify env evd cv_pb ?(flags=default_unify_flags) ty1 ty2 = (* General case: try first order *) | _ -> w_typed_unify env evd cv_pb flags ty1 ty2 + +(* Profiling *) +(* let wunifkey = Profile.declare_profile "w_unify";; *) + +(* let w_unify env evd cv_pb flags ty1 ty2 = *) +(* w_unify env evd cv_pb ~flags:flags ty1 ty2 *) + +(* let w_unify = Profile.profile6 wunifkey w_unify *) + +(* let w_unify env evd cv_pb ?(flags=default_unify_flags ()) ty1 ty2 = *) +(* w_unify env evd cv_pb flags ty1 ty2 *) diff --git a/pretyping/unification.mli b/pretyping/unification.mli index 04e65b862..3f93d817d 100644 --- a/pretyping/unification.mli +++ b/pretyping/unification.mli @@ -27,11 +27,11 @@ type unify_flags = { allow_K_in_toplevel_higher_order_unification : bool } -val default_unify_flags : unify_flags -val default_no_delta_unify_flags : unify_flags +val default_unify_flags : unit -> unify_flags +val default_no_delta_unify_flags : unit -> unify_flags -val elim_flags : unify_flags -val elim_no_delta_flags : unify_flags +val elim_flags : unit -> unify_flags +val elim_no_delta_flags : unit -> unify_flags (** The "unique" unification fonction *) val w_unify : @@ -59,8 +59,7 @@ val w_coerce_to_type : env -> evar_map -> constr -> types -> types -> abstracts the terms in l over c to get a term of type t (exported for inv.ml) *) val abstract_list_all : - env -> evar_map -> constr -> constr -> constr list -> constr * types - + env -> evar_map -> constr -> constr -> constr list -> evar_map * (constr * types) (* For tracing *) @@ -77,3 +76,15 @@ val unify_0 : Environ.env -> Evd.evar_map * Evd.metabinding list * (Environ.env * Term.types Term.pexistential * Term.constr) list +val unify_0_with_initial_metas : + Evd.evar_map * Evd.metabinding list * + (Environ.env * Term.types Term.pexistential * Term.constr) list -> + bool -> + Environ.env -> + Evd.conv_pb -> + unify_flags -> + Term.types -> + Term.types -> + Evd.evar_map * Evd.metabinding list * + (Environ.env * Term.types Term.pexistential * Term.constr) list + diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index b2fa631cd..16eeaa293 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -55,9 +55,11 @@ let find_rectype_a env c = (* Instantiate inductives and parameters in constructor type *) -let type_constructor mind mib typ params = - let s = ind_subst mind mib in +let type_constructor mind mib u typ params = + let s = ind_subst mind mib u in let ctyp = substl s typ in + let usubst = make_inductive_subst mib u in + let ctyp = subst_univs_constr usubst ctyp in let nparams = Array.length params in if Int.equal nparams 0 then ctyp else @@ -67,11 +69,11 @@ let type_constructor mind mib typ params = let construct_of_constr const env tag typ = - let (mind,_ as ind), allargs = find_rectype_a env typ in + let ((mind,_ as ind), u) as indu, allargs = find_rectype_a env typ in (* spiwack : here be a branch for specific decompilation handled by retroknowledge *) try if const then - ((retroknowledge Retroknowledge.get_vm_decompile_constant_info env (mkInd ind) tag), + ((retroknowledge Retroknowledge.get_vm_decompile_constant_info env (mkIndU indu) tag), typ) (*spiwack: this may need to be changed in case there are parameters in the type which may cause a constant value to have an arity. (type_constructor seems to be all about parameters actually) @@ -84,18 +86,19 @@ let construct_of_constr const env tag typ = let nparams = mib.mind_nparams in let i = invert_tag const tag mip.mind_reloc_tbl in let params = Array.sub allargs 0 nparams in - let ctyp = type_constructor mind mib (mip.mind_nf_lc.(i-1)) params in - (mkApp(mkConstruct(ind,i), params), ctyp) + let ctyp = type_constructor mind mib u (mip.mind_nf_lc.(i-1)) params in + (mkApp(mkConstructUi(indu,i), params), ctyp) let construct_of_constr_const env tag typ = fst (construct_of_constr true env tag typ) let construct_of_constr_block = construct_of_constr false +(* FIXME: treatment of universes *) let constr_type_of_idkey env idkey = match idkey with | ConstKey cst -> - mkConst cst, Typeops.type_of_constant env cst + mkConst cst, (Environ.lookup_constant cst env).const_type | VarKey id -> let (_,_,ty) = lookup_named id env in mkVar id, ty @@ -104,17 +107,17 @@ let constr_type_of_idkey env idkey = let (_,_,ty) = lookup_rel n env in mkRel n, lift n ty -let type_of_ind env ind = - type_of_inductive env (Inductive.lookup_mind_specif env ind) +let type_of_ind env ind u = + type_of_inductive env (Inductive.lookup_mind_specif env ind, u) -let build_branches_type env (mind,_ as _ind) mib mip params dep p = +let build_branches_type env (mind,_ as _ind) mib mip u params dep p = let rtbl = mip.mind_reloc_tbl in (* [build_one_branch i cty] construit le type de la ieme branche (commence a 0) et les lambda correspondant aux realargs *) let build_one_branch i cty = - let typi = type_constructor mind mib cty params in + let typi = type_constructor mind mib u cty params in let decl,indapp = decompose_prod_assum typi in - let ind,cargs = find_rectype_a env indapp in + let ((ind,u),cargs) = find_rectype_a env indapp in let nparams = Array.length params in let carity = snd (rtbl.(i)) in let crealargs = Array.sub cargs nparams (Array.length cargs - nparams) in @@ -123,7 +126,7 @@ let build_branches_type env (mind,_ as _ind) mib mip params dep p = if dep then let cstr = ith_constructor_of_inductive ind (i+1) in let relargs = Array.init carity (fun i -> mkRel (carity-i)) in - let dep_cstr = mkApp(mkApp(mkConstruct cstr,params),relargs) in + let dep_cstr = mkApp(mkApp(mkConstructU (cstr,u),params),relargs) in mkApp(papp,[|dep_cstr|]) else papp in @@ -170,7 +173,7 @@ and nf_whd env whd typ = | Vatom_stk(Aiddef(idkey,v), stk) -> nf_whd env (whd_stack v stk) typ | Vatom_stk(Aind ind, stk) -> - nf_stk env (mkInd ind) (type_of_ind env ind) stk + nf_stk env (mkInd ind) (type_of_ind env ind Univ.Instance.empty (*FIXME*)) stk and nf_stk env c t stk = match stk with @@ -183,16 +186,16 @@ and nf_stk env c t stk = let _,_,codom = try decompose_prod env typ with DestKO -> exit 120 in nf_stk env (mkApp(fa,[|c|])) (subst1 c codom) stk | Zswitch sw :: stk -> - let (mind,_ as ind),allargs = find_rectype_a env t in + let ((mind,_ as ind), u), allargs = find_rectype_a env t in let (mib,mip) = Inductive.lookup_mind_specif env ind in let nparams = mib.mind_nparams in let params,realargs = Util.Array.chop nparams allargs in let pT = - hnf_prod_applist env (type_of_ind env ind) (Array.to_list params) in + hnf_prod_applist env (type_of_ind env ind u) (Array.to_list params) in let pT = whd_betadeltaiota env pT in let dep, p = nf_predicate env ind mip params (type_of_switch sw) pT in (* Calcul du type des branches *) - let btypes = build_branches_type env ind mib mip params dep p in + let btypes = build_branches_type env ind mib mip u params dep p in (* calcul des branches *) let bsw = branch_of_switch (nb_rel env) sw in let mkbranch i (n,v) = diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml index 92b4bf496..950594397 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -118,6 +118,12 @@ let pr_name = pr_name let pr_qualid = pr_qualid let pr_patvar = pr_id +let pr_universe_instance l = + pr_opt (pr_in_comment Univ.Instance.pr) l + +let pr_cref ref us = + pr_reference ref ++ pr_universe_instance us + let pr_expl_args pr (a,expl) = match expl with | None -> pr (lapp,L) a @@ -397,9 +403,10 @@ let pr_simple_return_type pr na po = let pr_proj pr pr_app a f l = hov 0 (pr (lproj,E) a ++ cut() ++ str ".(" ++ pr_app pr f l ++ str ")") -let pr_appexpl pr f l = +let pr_appexpl pr (f,us) l = hov 2 ( str "@" ++ pr_reference f ++ + pr_universe_instance us ++ prlist (pr_sep_com spc (pr (lapp,L))) l) let pr_app pr a l = @@ -421,7 +428,7 @@ let pr_dangling_with_for sep pr inherited a = let pr pr sep inherited a = let (strm,prec) = match a with - | CRef r -> pr_reference r, latom + | CRef (r,us) -> pr_cref r us, latom | CFix (_,id,fix) -> hov 0 (str"fix " ++ pr_recursive @@ -458,19 +465,19 @@ let pr pr sep inherited a = pr spc ltop a ++ str " in") ++ pr spc ltop b), lletin - | CAppExpl (_,(Some i,f),l) -> + | CAppExpl (_,(Some i,f,us),l) -> let l1,l2 = List.chop i l in let c,l1 = List.sep_last l1 in - let p = pr_proj (pr mt) pr_appexpl c f l1 in + let p = pr_proj (pr mt) pr_appexpl c (f,us) l1 in if not (List.is_empty l2) then p ++ prlist (pr spc (lapp,L)) l2, lapp else p, lproj - | CAppExpl (_,(None,Ident (_,var)),[t]) - | CApp (_,(_,CRef(Ident(_,var))),[t,None]) + | CAppExpl (_,(None,Ident (_,var),us),[t]) + | CApp (_,(_,CRef(Ident(_,var),us)),[t,None]) when Id.equal var Notation_ops.ldots_var -> hov 0 (str ".." ++ pr spc (latom,E) t ++ spc () ++ str ".."), larg - | CAppExpl (_,(None,f),l) -> pr_appexpl (pr mt) f l, lapp + | CAppExpl (_,(None,f,us),l) -> pr_appexpl (pr mt) (f,us) l, lapp | CApp (_,(Some i,f),l) -> let l1,l2 = List.chop i l in let c,l1 = List.sep_last l1 in @@ -567,7 +574,7 @@ let rec fix rf x =rf (fix rf) x let pr = fix modular_constr_pr mt let pr_simpleconstr = function - | CAppExpl (_,(None,f),[]) -> str "@" ++ pr_reference f + | CAppExpl (_,(None,f,us),[]) -> str "@" ++ pr_cref f us | c -> pr lsimpleconstr c let default_term_pr = { diff --git a/printing/ppvernac.ml b/printing/ppvernac.ml index ecc80c2cf..e2d237815 100644 --- a/printing/ppvernac.ml +++ b/printing/ppvernac.ml @@ -176,7 +176,8 @@ let pr_hints db h pr_c pr_pat = match pri with Some x -> spc () ++ str"(" ++ int x ++ str")" | None -> mt ()) l | HintsImmediate l -> - str"Immediate" ++ spc() ++ prlist_with_sep sep (pr_reference_or_constr pr_c) l + str"Immediate" ++ spc() ++ + prlist_with_sep sep (fun c -> pr_reference_or_constr pr_c c) l | HintsUnfold l -> str "Unfold " ++ prlist_with_sep sep pr_reference l | HintsTransparency (l, b) -> @@ -374,6 +375,11 @@ let pr_priority = function | None -> mt () | Some i -> spc () ++ str "|" ++ spc () ++ int i +let pr_poly p = + if Flags.is_universe_polymorphism () then + if not p then str"Monomorphic " else mt () + else if p then str"Polymorphic " else mt () + (**************************************) (* Pretty printer for vernac commands *) (**************************************) @@ -466,6 +472,9 @@ in let pr_using e = str (Proof_using.to_string e) in let rec pr_vernac = function + | VernacPolymorphic (poly, v) -> + let s = if poly then str"Polymorphic" else str"Monomorphic" in + s ++ pr_vernac v | VernacProgram v -> str"Program" ++ spc() ++ pr_vernac v | VernacLocal (local, v) -> pr_locality local ++ spc() ++ pr_vernac v @@ -579,7 +588,7 @@ let rec pr_vernac = function | VernacDefinition (d,id,b) -> (* A verifier... *) let pr_def_token (l,dk) = let l = match l with Some x -> x | None -> Decl_kinds.Global in - str (Kindops.string_of_definition_kind (l,dk)) in + str (Kindops.string_of_definition_kind (l,false,dk)) in let pr_reduce = function | None -> mt() | Some r -> @@ -619,7 +628,6 @@ let rec pr_vernac = function (pr_assumption_token (n > 1) stre ++ spc() ++ pr_ne_params_list pr_lconstr_expr l) | VernacInductive (f,i,l) -> - let pr_constructor (coe,(id,c)) = hov 2 (pr_lident id ++ str" " ++ (if coe then str":>" else str":") ++ diff --git a/printing/prettyp.ml b/printing/prettyp.ml index 89808ef4d..e885f5978 100644 --- a/printing/prettyp.ml +++ b/printing/prettyp.ml @@ -66,7 +66,7 @@ let int_or_no n = if Int.equal n 0 then str "no" else int n let print_basename sp = pr_global (ConstRef sp) let print_ref reduce ref = - let typ = Global.type_of_global ref in + let typ = Global.type_of_global_unsafe ref in let typ = if reduce then let ctx,ccl = Reductionops.splay_prod_assum (Global.env()) Evd.empty typ @@ -122,7 +122,7 @@ let print_renames_list prefix l = hv 2 (prlist_with_sep pr_comma (fun x -> x) (List.map pr_name l))] let need_expansion impl ref = - let typ = Global.type_of_global ref in + let typ = Global.type_of_global_unsafe ref in let ctx = prod_assum typ in let nprods = List.length (List.filter (fun (_,b,_) -> Option.is_empty b) ctx) in not (List.is_empty impl) && List.length impl >= nprods && @@ -371,25 +371,23 @@ let print_body = function let print_typed_body (val_0,typ) = (print_body val_0 ++ fnl () ++ str " : " ++ pr_ltype typ) -let ungeneralized_type_of_constant_type = function - | PolymorphicArity (ctx,a) -> mkArity (ctx, Type a.poly_level) - | NonPolymorphicType t -> t +let ungeneralized_type_of_constant_type t = t let print_constant with_values sep sp = let cb = Global.lookup_constant sp in let val_0 = Declareops.body_of_constant cb in let typ = ungeneralized_type_of_constant_type cb.const_type in - hov 0 ( + hov 0 (pr_polymorphic cb.const_polymorphic ++ match val_0 with | None -> str"*** [ " ++ print_basename sp ++ str " : " ++ cut () ++ pr_ltype typ ++ str" ]" ++ - Printer.pr_univ_cstr (Declareops.constraints_of_constant cb) + Printer.pr_universe_ctx (Future.force cb.const_universes) | _ -> print_basename sp ++ str sep ++ cut () ++ (if with_values then print_typed_body (val_0,typ) else pr_ltype typ)++ - Printer.pr_univ_cstr (Declareops.constraints_of_constant cb)) + Printer.pr_universe_ctx (Future.force cb.const_universes)) let gallina_print_constant_with_infos sp = print_constant true " = " sp ++ @@ -626,7 +624,7 @@ let print_opaque_name qid = | IndRef (sp,_) -> print_inductive sp | ConstructRef cstr -> - let ty = Inductiveops.type_of_constructor env cstr in + let ty = Inductiveops.type_of_constructor env (cstr,Univ.Instance.empty) in print_typed_value (mkConstruct cstr, ty) | VarRef id -> let (_,c,ty) = lookup_named id env in diff --git a/printing/printer.ml b/printing/printer.ml index 935153bff..91156e21f 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -119,12 +119,11 @@ let _ = Termops.set_print_constr pr_lconstr_env let pr_in_comment pr x = str "(* " ++ pr x ++ str " *)" let pr_univ_cstr (c:Univ.constraints) = - if !Detyping.print_universes && not (Univ.is_empty_constraint c) then + if !Detyping.print_universes && not (Univ.Constraint.is_empty c) then fnl()++pr_in_comment (fun c -> v 0 (Univ.pr_constraints c)) c else mt() - (** Term printers resilient to [Nametab] errors *) (** When the nametab isn't up-to-date, the term printers above @@ -179,6 +178,11 @@ let safe_pr_constr_env = safe_gen pr_constr_env let safe_pr_lconstr t = safe_pr_lconstr_env (Global.env()) t let safe_pr_constr t = safe_pr_constr_env (Global.env()) t +let pr_universe_ctx c = + if !Detyping.print_universes && not (Univ.UContext.is_empty c) then + fnl()++pr_in_comment (fun c -> v 0 (Univ.pr_universe_context c)) c + else + mt() (**********************************************************************) (* Global references *) @@ -186,12 +190,22 @@ let safe_pr_constr t = safe_pr_constr_env (Global.env()) t let pr_global_env = pr_global_env let pr_global = pr_global_env Id.Set.empty +let pr_puniverses f env (c,u) = + f env c ++ + (if !Constrextern.print_universes then + str"(*" ++ Univ.Instance.pr u ++ str"*)" + else mt ()) + let pr_constant env cst = pr_global_env (Termops.vars_of_env env) (ConstRef cst) let pr_existential_key evk = str (string_of_existential evk) let pr_existential env ev = pr_lconstr_env env (mkEvar ev) let pr_inductive env ind = pr_lconstr_env env (mkInd ind) let pr_constructor env cstr = pr_lconstr_env env (mkConstruct cstr) +let pr_pconstant = pr_puniverses pr_constant +let pr_pinductive = pr_puniverses pr_inductive +let pr_pconstructor = pr_puniverses pr_constructor + let pr_evaluable_reference ref = pr_global (Tacred.global_of_evaluable_reference ref) @@ -713,6 +727,17 @@ let pr_assumptionset env s = ] in prlist_with_sep fnl (fun x -> x) (Option.List.flatten assums) +open Typeclasses + +let xor a b = + (a && not b) || (not a && b) + +let pr_polymorphic b = + let print = xor (Flags.is_universe_polymorphism ()) b in + if print then + if b then str"Polymorphic " else str"Monomorphic " + else mt () + (** Inductive declarations *) open Termops @@ -730,17 +755,17 @@ let print_constructors envpar names types = hv 0 (str " " ++ pc) let build_ind_type env mip = - match mip.mind_arity with - | Monomorphic ar -> ar.mind_user_arity - | Polymorphic ar -> - it_mkProd_or_LetIn (mkSort (Type ar.poly_level)) mip.mind_arity_ctxt + mip.mind_arity.mind_user_arity let print_one_inductive env mib ((_,i) as ind) = let mip = mib.mind_packets.(i) in let params = mib.mind_params_ctxt in let args = extended_rel_list 0 params in let arity = hnf_prod_applist env (build_ind_type env mip) args in - let cstrtypes = Inductive.type_of_constructors ind (mib,mip) in + let u = if mib.mind_polymorphic then + Univ.UContext.instance mib.mind_universes + else Univ.Instance.empty in + let cstrtypes = Inductive.type_of_constructors (ind,u) (mib,mip) in let cstrtypes = Array.map (fun c -> hnf_prod_applist env c args) cstrtypes in let envpar = push_rel_context params env in hov 0 ( @@ -751,11 +776,11 @@ let print_one_inductive env mib ((_,i) as ind) = let print_mutual_inductive env mind mib = let inds = List.init (Array.length mib.mind_packets) (fun x -> (mind, x)) in - hov 0 ( + hov 0 (pr_polymorphic mib.mind_polymorphic ++ str (if mib.mind_finite then "Inductive " else "CoInductive ") ++ prlist_with_sep (fun () -> fnl () ++ str" with ") (print_one_inductive env mib) inds ++ - pr_univ_cstr mib.mind_constraints) + pr_universe_ctx mib.mind_universes) let get_fields = let rec prodec_rec l subst c = @@ -774,13 +799,17 @@ let print_record env mind mib = let mip = mib.mind_packets.(0) in let params = mib.mind_params_ctxt in let args = extended_rel_list 0 params in + let u = if mib.mind_polymorphic then + Univ.UContext.instance mib.mind_universes + else Univ.Instance.empty in let arity = hnf_prod_applist env (build_ind_type env mip) args in - let cstrtypes = Inductive.type_of_constructors (mind,0) (mib,mip) in + let cstrtypes = Inductive.type_of_constructors ((mind,0),u) (mib,mip) in let cstrtype = hnf_prod_applist env cstrtypes.(0) args in let fields = get_fields cstrtype in let envpar = push_rel_context params env in hov 0 ( hov 0 ( + pr_polymorphic mib.mind_polymorphic ++ str "Record " ++ pr_id mip.mind_typename ++ brk(1,4) ++ print_params env params ++ str ": " ++ pr_lconstr_env envpar arity ++ brk(1,2) ++ @@ -791,10 +820,10 @@ let print_record env mind mib = (fun (id,b,c) -> pr_id id ++ str (if b then " : " else " := ") ++ pr_lconstr_env envpar c) fields) ++ str" }" ++ - pr_univ_cstr mib.mind_constraints) + pr_universe_ctx mib.mind_universes) let pr_mutual_inductive_body env mind mib = - if mib.mind_record && not !Flags.raw_print then + if mib.mind_record <> None && not !Flags.raw_print then print_record env mind mib else print_mutual_inductive env mind mib diff --git a/printing/printer.mli b/printing/printer.mli index 6ca55b16b..eb181d426 100644 --- a/printing/printer.mli +++ b/printing/printer.mli @@ -80,7 +80,9 @@ val pr_sort : sorts -> std_ppcmds (** Universe constraints *) +val pr_polymorphic : bool -> std_ppcmds val pr_univ_cstr : Univ.constraints -> std_ppcmds +val pr_universe_ctx : Univ.universe_context -> std_ppcmds (** Printing global references using names as short as possible *) @@ -94,6 +96,11 @@ val pr_constructor : env -> constructor -> std_ppcmds val pr_inductive : env -> inductive -> std_ppcmds val pr_evaluable_reference : evaluable_global_reference -> std_ppcmds +val pr_pconstant : env -> pconstant -> std_ppcmds +val pr_pinductive : env -> pinductive -> std_ppcmds +val pr_pconstructor : env -> pconstructor -> std_ppcmds + + (** Contexts *) val pr_ne_context_of : std_ppcmds -> env -> std_ppcmds diff --git a/printing/printmod.ml b/printing/printmod.ml index 112abeec9..da5546bac 100644 --- a/printing/printmod.ml +++ b/printing/printmod.ml @@ -146,8 +146,7 @@ let print_body is_impl env mp (l,body) = | None -> mt () | Some env -> str " :" ++ spc () ++ - hov 0 (Printer.pr_ltype_env env - (Typeops.type_of_constant_type env cb.const_type)) ++ + hov 0 (Printer.pr_ltype_env env cb.const_type) ++ (match cb.const_body with | Def l when is_impl -> spc () ++ diff --git a/proofs/clenv.ml b/proofs/clenv.ml index 64a9f0024..afc8d3b70 100644 --- a/proofs/clenv.ml +++ b/proofs/clenv.ml @@ -42,12 +42,27 @@ type clausenv = { let cl_env ce = ce.env let cl_sigma ce = ce.evd +let map_clenv sub clenv = + { templval = map_fl sub clenv.templval; + templtyp = map_fl sub clenv.templtyp; + evd = cmap sub clenv.evd; + env = clenv.env } + let clenv_nf_meta clenv c = nf_meta clenv.evd c let clenv_term clenv c = meta_instance clenv.evd c let clenv_meta_type clenv mv = Typing.meta_type clenv.evd mv let clenv_value clenv = meta_instance clenv.evd clenv.templval let clenv_type clenv = meta_instance clenv.evd clenv.templtyp +let refresh_undefined_univs clenv = + match kind_of_term clenv.templval.rebus with + | Var _ -> clenv, Univ.empty_level_subst + | App (f, args) when isVar f -> clenv, Univ.empty_level_subst + | _ -> + let evd', subst = Evd.refresh_undefined_universes clenv.evd in + let map_freelisted f = { f with rebus = subst_univs_level_constr subst f.rebus } in + { clenv with evd = evd'; templval = map_freelisted clenv.templval; + templtyp = map_freelisted clenv.templtyp }, subst let clenv_hnf_constr ce t = hnf_constr (cl_env ce) (cl_sigma ce) t @@ -239,14 +254,14 @@ let clenv_dependent ce = clenv_dependent_gen false ce (******************************************************************) -let clenv_unify ?(flags=default_unify_flags) cv_pb t1 t2 clenv = +let clenv_unify ?(flags=default_unify_flags ()) cv_pb t1 t2 clenv = { clenv with evd = w_unify ~flags clenv.env clenv.evd cv_pb t1 t2 } -let clenv_unify_meta_types ?(flags=default_unify_flags) clenv = +let clenv_unify_meta_types ?(flags=default_unify_flags ()) clenv = { clenv with evd = w_unify_meta_types ~flags:flags clenv.env clenv.evd } -let clenv_unique_resolver ?(flags=default_unify_flags) clenv gl = +let clenv_unique_resolver ?(flags=default_unify_flags ()) clenv gl = let concl = Goal.V82.concl clenv.evd (sig_it gl) in if isMeta (fst (decompose_appvect (whd_nored clenv.evd clenv.templtyp.rebus))) then clenv_unify CUMUL ~flags (clenv_type clenv) concl @@ -305,6 +320,9 @@ let connect_clenv gls clenv = evd = evd ; env = Goal.V82.env evd (sig_it gls) } +(* let connect_clenv_key = Profile.declare_profile "connect_clenv";; *) +(* let connect_clenv = Profile.profile2 connect_clenv_key connect_clenv *) + (* [clenv_fchain mv clenv clenv'] * * Resolves the value of "mv" (which must be undefined) in clenv to be @@ -329,11 +347,11 @@ let connect_clenv gls clenv = In particular, it assumes that [env'] and [sigma'] extend [env] and [sigma]. *) -let fchain_flags = - { default_unify_flags with +let fchain_flags () = + { (default_unify_flags ()) with allow_K_in_toplevel_higher_order_unification = true } -let clenv_fchain ?(flags=fchain_flags) mv clenv nextclenv = +let clenv_fchain ?(flags=fchain_flags ()) mv clenv nextclenv = (* Add the metavars of [nextclenv] to [clenv], with their name-environment *) let clenv' = { templval = clenv.templval; diff --git a/proofs/clenv.mli b/proofs/clenv.mli index ab4f3af79..35bed8f40 100644 --- a/proofs/clenv.mli +++ b/proofs/clenv.mli @@ -23,6 +23,9 @@ type clausenv = { out *) templtyp : constr freelisted (** its type *)} + +val map_clenv : (constr -> constr) -> clausenv -> clausenv + (** subject of clenv (instantiated) *) val clenv_value : clausenv -> constr @@ -41,6 +44,9 @@ val mk_clenv_from_n : val mk_clenv_type_of : Goal.goal sigma -> constr -> clausenv val mk_clenv_from_env : env -> evar_map -> int option -> constr * types -> clausenv +(** Refresh the universes in a clenv *) +val refresh_undefined_univs : clausenv -> clausenv * Univ.universe_level_subst + (** {6 linking of clenvs } *) val connect_clenv : Goal.goal sigma -> clausenv -> clausenv diff --git a/proofs/clenvtac.ml b/proofs/clenvtac.ml index 7a1a14bde..112402bca 100644 --- a/proofs/clenvtac.ml +++ b/proofs/clenvtac.ml @@ -29,6 +29,7 @@ let clenv_cast_meta clenv = match kind_of_term u with | App _ | Case _ -> crec_hd u | Cast (c,_,_) when isMeta c -> u + | Proj (p, c) -> mkProj (p, crec_hd c) | _ -> map_constr crec u and crec_hd u = @@ -43,6 +44,7 @@ let clenv_cast_meta clenv = | App(f,args) -> mkApp (crec_hd f, Array.map crec args) | Case(ci,p,c,br) -> mkCase (ci, crec_hd p, crec_hd c, Array.map crec br) + | Proj (p, c) -> mkProj (p, crec_hd c) | _ -> u in crec @@ -68,15 +70,15 @@ let clenv_refine with_evars ?(with_classes=true) clenv gls = in let clenv = { clenv with evd = evd' } in tclTHEN - (tclEVARS evd') - (refine (clenv_cast_meta clenv (clenv_value clenv))) + (tclEVARS (Evd.clear_metas evd')) + (refine_no_check (clenv_cast_meta clenv (clenv_value clenv))) gls open Unification let dft = default_unify_flags -let res_pf clenv ?(with_evars=false) ?(flags=dft) gls = +let res_pf clenv ?(with_evars=false) ?(flags=dft ()) gls = clenv_refine with_evars (clenv_unique_resolver ~flags clenv gls) gls (* [unifyTerms] et [unify] ne semble pas gérer les Meta, en diff --git a/proofs/logic.ml b/proofs/logic.ml index 054e6db6c..02f3a16d8 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -324,6 +324,7 @@ let collect_meta_variables c = | Meta mv -> if deep then error_unsupported_deep_meta () else mv::acc | Cast(c,_,_) -> collrec deep acc c | (App _| Case _) -> fold_constr (collrec deep) acc c + | Proj (_, c) -> collrec deep acc c | _ -> fold_constr (collrec true) acc c in List.rev (collrec false [] c) @@ -333,12 +334,15 @@ let check_meta_variables c = raise (RefinerError (NonLinearProof c)) let check_conv_leq_goal env sigma arg ty conclty = - if !check && not (is_conv_leq env sigma ty conclty) then - raise (RefinerError (BadType (arg,ty,conclty))) + if !check then + let evm, b = Reductionops.infer_conv env sigma ty conclty in + if b then evm + else raise (RefinerError (BadType (arg,ty,conclty))) + else sigma let goal_type_of env sigma c = if !check then type_of env sigma c - else Retyping.get_type_of ~refresh:true env sigma c + else Retyping.get_type_of env sigma c let rec mk_refgoals sigma goal goalacc conclty trm = let env = Goal.V82.env sigma goal in @@ -346,17 +350,22 @@ let rec mk_refgoals sigma goal goalacc conclty trm = let mk_goal hyps concl = Goal.V82.mk_goal sigma hyps concl (Goal.V82.extra sigma goal) in - match kind_of_term trm with - | Meta _ -> + if (not !check) && not (occur_meta trm) then + let t'ty = Retyping.get_type_of env sigma trm in + let sigma = check_conv_leq_goal env sigma trm t'ty conclty in + (goalacc,t'ty,sigma,trm) + else + match kind_of_term trm with + | Meta _ -> let conclty = nf_betaiota sigma conclty in if !check && occur_meta conclty then raise (RefinerError (MetaInType conclty)); let (gl,ev,sigma) = mk_goal hyps conclty in gl::goalacc, conclty, sigma, ev - | Cast (t,k, ty) -> + | Cast (t,k, ty) -> check_typability env sigma ty; - check_conv_leq_goal env sigma trm ty conclty; + let sigma = check_conv_leq_goal env sigma trm ty conclty in let res = mk_refgoals sigma goal goalacc ty t in (** we keep the casts (in particular VMcast and NATIVEcast) except when they are annotating metas *) @@ -368,11 +377,11 @@ let rec mk_refgoals sigma goal goalacc conclty trm = let ans = if ans == t then trm else mkCast(ans,k,ty) in (gls,cty,sigma,ans) - | App (f,l) -> + | App (f,l) -> let (acc',hdty,sigma,applicand) = match kind_of_term f with | Ind _ | Const _ - when (isInd f || has_polymorphic_type (destConst f)) -> + when (isInd f || has_polymorphic_type (fst (destConst f))) -> (* Sort-polymorphism of definition and inductive types *) goalacc, type_of_global_reference_knowing_conclusion env sigma f conclty, @@ -381,13 +390,19 @@ let rec mk_refgoals sigma goal goalacc conclty trm = mk_hdgoals sigma goal goalacc f in let ((acc'',conclty',sigma), args) = mk_arggoals sigma goal acc' hdty l in - check_conv_leq_goal env sigma trm conclty' conclty; + let sigma = check_conv_leq_goal env sigma trm conclty' conclty in let ans = if applicand == f && args == l then trm else Term.mkApp (applicand, args) in (acc'',conclty',sigma, ans) - | Case (ci,p,c,lf) -> + | Proj (p,c) -> + let (acc',cty,sigma,c') = mk_hdgoals sigma goal goalacc c in + let c = mkProj (p, c') in + let ty = get_type_of env sigma c in + (acc',ty,sigma,c) + + | Case (ci,p,c,lf) -> let (acc',lbrty,conclty',sigma,p',c') = mk_casegoals sigma goal goalacc p c in - check_conv_leq_goal env sigma trm conclty' conclty; + let sigma = check_conv_leq_goal env sigma trm conclty' conclty in let (acc'',sigma, rbranches) = Array.fold_left2 (fun (lacc,sigma,bacc) ty fi -> @@ -401,13 +416,12 @@ let rec mk_refgoals sigma goal goalacc conclty trm = in (acc'',conclty',sigma, ans) - | _ -> + | _ -> if occur_meta trm then anomaly (Pp.str "refiner called with a meta in non app/case subterm"); - - let t'ty = goal_type_of env sigma trm in - check_conv_leq_goal env sigma trm t'ty conclty; - (goalacc,t'ty,sigma, trm) + let t'ty = goal_type_of env sigma trm in + let sigma = check_conv_leq_goal env sigma trm t'ty conclty in + (goalacc,t'ty,sigma, trm) (* Same as mkREFGOALS but without knowing the type of the term. Therefore, * Metas should be casted. *) @@ -454,6 +468,12 @@ and mk_hdgoals sigma goal goalacc trm = in (acc'',conclty',sigma, ans) + | Proj (p,c) -> + let (acc',cty,sigma,c') = mk_hdgoals sigma goal goalacc c in + let c = mkProj (p, c') in + let ty = get_type_of env sigma c in + (acc',ty,sigma,c) + | _ -> if !check && occur_meta trm then anomaly (Pp.str "refine called with a dependent meta"); @@ -569,12 +589,12 @@ let prim_refiner r sigma goal = check_ind (push_rel (na,None,c1) env) (k-1) b | _ -> error "Not enough products." in - let (sp,_) = check_ind env n cl in + let ((sp,_),u) = check_ind env n cl in let firsts,lasts = List.chop j rest in let all = firsts@(f,n,cl)::lasts in let rec mk_sign sign = function | (f,n,ar)::oth -> - let (sp',_) = check_ind env n ar in + let ((sp',_),u') = check_ind env n ar in if not (eq_mind sp sp') then error ("Fixpoints should be on the same " ^ "mutual inductive declaration."); @@ -652,13 +672,11 @@ let prim_refiner r sigma goal = (* Conversion rules *) | Convert_concl (cl',k) -> check_typability env sigma cl'; - if (not !check) || is_conv_leq env sigma cl' cl then - let (sg,ev,sigma) = mk_goal sign cl' in - let ev = if k != DEFAULTcast then mkCast(ev,k,cl) else ev in - let sigma = Goal.V82.partial_solution sigma goal ev in + let (sg,ev,sigma) = mk_goal sign cl' in + let sigma = check_conv_leq_goal env sigma cl' cl' cl in + let ev = if k != DEFAULTcast then mkCast(ev,k,cl) else ev in + let sigma = Goal.V82.partial_solution sigma goal ev in ([sg], sigma) - else - error "convert-concl rule passed non-converting term" | Convert_hyp (id,copt,ty) -> let (gl,ev,sigma) = mk_goal (convert_hyp sign sigma (id,copt,ty)) cl in diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index f45eb2a3a..3fc01c0bc 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -118,26 +118,28 @@ open Decl_kinds let next = let n = ref 0 in fun () -> incr n; !n -let build_constant_by_tactic id sign ?(goal_kind = Global,Proof Theorem) typ tac = +let build_constant_by_tactic id sign ?(goal_kind = Global, false, Proof Theorem) typ tac = + let substref = ref Univ.LMap.empty in (** FIXME: Something wrong here with subst *) start_proof id goal_kind sign typ (fun _ -> ()); try let status = by tac in let _,(const,_) = cook_proof () in delete_current_proof (); - const, status + const, status, !substref with reraise -> let reraise = Errors.push reraise in delete_current_proof (); raise reraise -let build_by_tactic env typ tac = +let build_by_tactic env ?(poly=false) typ tac = let id = Id.of_string ("temporary_proof"^string_of_int (next())) in let sign = val_of_named_context (named_context env) in - let ce,status = build_constant_by_tactic id sign typ tac in + let gk = Global, poly, Proof Theorem in + let ce, status, subst = build_constant_by_tactic id sign ~goal_kind:gk typ tac in let ce = Term_typing.handle_side_effects env ce in let cb, se = Future.force ce.const_entry_body in - assert(Declareops.side_effects_is_empty (Declareops.no_seff)); - cb,status + assert(Declareops.side_effects_is_empty se); + cb, status, subst (**********************************************************************) (* Support for resolution of evars in tactic interpretation, including @@ -156,6 +158,9 @@ let solve_by_implicit_tactic env sigma evk = when Context.named_context_equal (Environ.named_context_of_val evi.evar_hyps) (Environ.named_context env) -> - (try fst (build_by_tactic env evi.evar_concl (Proofview.tclTHEN tac (Proofview.tclEXTEND [] (Proofview.tclZERO (Errors.UserError ("",Pp.str"Proof is not complete."))) []))) + let tac = Proofview.tclTHEN tac (Proofview.tclEXTEND [] (Proofview.tclZERO (Errors.UserError ("",Pp.str"Proof is not complete."))) []) in + (try + let (ans, _, _) = build_by_tactic env (evi.evar_concl, Evd.get_universe_context_set sigma) tac in + ans with e when Logic.catchable_exception e -> raise Exit) | _ -> raise Exit diff --git a/proofs/pfedit.mli b/proofs/pfedit.mli index fea1b701e..877b7c858 100644 --- a/proofs/pfedit.mli +++ b/proofs/pfedit.mli @@ -56,7 +56,7 @@ val delete_all_proofs : unit -> unit type lemma_possible_guards = Proof_global.lemma_possible_guards val start_proof : - Id.t -> goal_kind -> named_context_val -> constr -> + Id.t -> goal_kind -> named_context_val -> constr Univ.in_universe_context_set -> ?init_tac:unit Proofview.tactic -> Proof_global.proof_terminator -> unit @@ -149,8 +149,10 @@ val instantiate_nth_evar_com : int -> Constrexpr.constr_expr -> unit val build_constant_by_tactic : Id.t -> named_context_val -> ?goal_kind:goal_kind -> - types -> unit Proofview.tactic -> Entries.definition_entry * bool -val build_by_tactic : env -> types -> unit Proofview.tactic -> constr * bool + types Univ.in_universe_context_set -> unit Proofview.tactic -> Entries.definition_entry * bool * Universes.universe_opt_subst +val build_by_tactic : env -> ?poly:polymorphic -> + types Univ.in_universe_context_set -> unit Proofview.tactic -> + constr * bool * Universes.universe_opt_subst (** Declare the default tactic to fill implicit arguments *) @@ -161,10 +163,3 @@ val clear_implicit_tactic : unit -> unit (* Raise Exit if cannot solve *) val solve_by_implicit_tactic : env -> Evd.evar_map -> Evd.evar -> constr - - - - - - - diff --git a/proofs/proof.mli b/proofs/proof.mli index ac922ac50..30b65d0ce 100644 --- a/proofs/proof.mli +++ b/proofs/proof.mli @@ -51,9 +51,8 @@ val proof : proof -> (*** General proof functions ***) -val start : Evd.evar_map -> (Environ.env * Term.types) list -> proof +val start : Evd.evar_map -> (Environ.env * Term.types Univ.in_universe_context_set) list -> proof val dependent_start : Evd.evar_map -> Proofview.telescope -> proof - val initial_goals : proof -> (Term.constr * Term.types) list (* Returns [true] if the considered proof is completed, that is if no goal remain diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index 3cdecb633..7434979f8 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -68,6 +68,7 @@ type proof_object = { id : Names.Id.t; entries : Entries.definition_entry list; persistence : Decl_kinds.goal_kind; + opt_subst : Universes.universe_opt_subst; } type proof_ending = @@ -78,6 +79,10 @@ type proof_ending = type proof_terminator = proof_ending -> unit type closed_proof = proof_object * proof_terminator +type 'a proof_decl_hook = + Universes.universe_opt_subst Univ.in_universe_context -> + Decl_kinds.locality -> Globnames.global_reference -> 'a + type pstate = { pid : Id.t; terminator : proof_terminator Ephemeron.key; @@ -264,18 +269,29 @@ let get_open_goals () = let close_proof ?feedback_id ~now fpl = let { pid; section_vars; strength; proof; terminator } = cur_pstate () in let initial_goals = Proof.initial_goals proof in - let entries = - Future.map2 (fun p (c, t) -> { Entries. - const_entry_body = p; - const_entry_secctx = section_vars; - const_entry_feedback = feedback_id; - const_entry_type = Some t; - const_entry_inline_code = false; - const_entry_opaque = true }) - fpl initial_goals in + let evdref = ref (Proof.return proof) in + let nf,subst = Evarutil.e_nf_evars_and_universes evdref in + let initial_goals = List.map (fun (c,t) -> (nf c, nf t)) initial_goals in + let ctx = Evd.universe_context !evdref in + let entries = Future.map2 (fun p (c, t) -> + let univs = + Univ.LSet.union (Universes.universes_of_constr c) + (Universes.universes_of_constr t) + in + let ctx = Universes.restrict_universe_context (Univ.ContextSet.of_context ctx) univs in + { Entries. + const_entry_body = p; + const_entry_secctx = section_vars; + const_entry_type = Some t; + const_entry_feedback = feedback_id; + const_entry_inline_code = false; + const_entry_opaque = true; + const_entry_universes = Univ.ContextSet.to_context ctx; + const_entry_polymorphic = pi2 strength; + const_entry_proj = None}) fpl initial_goals in if now then - List.iter (fun x ->ignore(Future.force x.Entries.const_entry_body)) entries; - { id = pid; entries = entries; persistence = strength }, + List.iter (fun x -> ignore(Future.force x.Entries.const_entry_body)) entries; + { id = pid; entries = entries; persistence = strength; opt_subst = subst }, Ephemeron.get terminator let return_proof () = @@ -312,6 +328,9 @@ let set_terminator hook = | [] -> raise NoCurrentProof | p :: ps -> pstates := { p with terminator = Ephemeron.create hook } :: ps + + + (**********************************************************) (* *) (* Bullets *) diff --git a/proofs/proof_global.mli b/proofs/proof_global.mli index 47d63e2eb..e651bdfae 100644 --- a/proofs/proof_global.mli +++ b/proofs/proof_global.mli @@ -46,6 +46,10 @@ exception NoCurrentProof val give_me_the_proof : unit -> Proof.proof (** @raise NoCurrentProof when outside proof mode. *) +type 'a proof_decl_hook = + Universes.universe_opt_subst Univ.in_universe_context -> + Decl_kinds.locality -> Globnames.global_reference -> 'a + (** When a proof is closed, it is reified into a [proof_object], where [id] is the name of the proof, [entries] the list of the proof terms (in a form suitable for definitions). Together with the [terminator] @@ -57,6 +61,7 @@ type proof_object = { id : Names.Id.t; entries : Entries.definition_entry list; persistence : Decl_kinds.goal_kind; + opt_subst : Universes.universe_opt_subst; } type proof_ending = @@ -74,7 +79,7 @@ type closed_proof = proof_object * proof_terminator closing commands and the xml plugin); [terminator] is used at the end of the proof to close the proof. *) val start_proof : - Names.Id.t -> Decl_kinds.goal_kind -> (Environ.env * Term.types) list -> + Names.Id.t -> Decl_kinds.goal_kind -> (Environ.env * Term.types Univ.in_universe_context_set) list -> proof_terminator -> unit (** Like [start_proof] except that there may be dependencies between diff --git a/proofs/proofview.ml b/proofs/proofview.ml index 22d908e94..d0a477431 100644 --- a/proofs/proofview.ml +++ b/proofs/proofview.ml @@ -36,10 +36,11 @@ let proofview p = let init sigma = let rec aux = function | [] -> [], { solution = sigma; comb = []; } - | (env, typ) :: l -> + | (env, (typ,ctx)) :: l -> let ret, { solution = sol; comb = comb } = aux l in let (new_defs , econstr) = Evarutil.new_evar sol env typ in let (e, _) = Term.destEvar econstr in + let new_defs = Evd.merge_context_set Evd.univ_rigid new_defs ctx in let gl = Goal.build e in let entry = (econstr, typ) :: ret in entry, { solution = new_defs; comb = gl::comb; } @@ -88,6 +89,12 @@ let partial_proof entry pv = List.map (return_constr pv) (List.map fst entry) let emit_side_effects eff x = { x with solution = Evd.emit_side_effects eff x.solution } +(* let return { initial=init; solution=defs } = *) +(* let evdref = ref defs in *) +(* let nf,subst = Evarutil.e_nf_evars_and_universes evdref in *) +(* ((List.map (fun (c,t) -> (nf c, nf t)) init, subst), *) +(* Evd.universe_context !evdref) *) + (* spiwack: this function should probably go in the Util section, but I'd rather have Util (or a separate module for lists) raise proper exceptions before *) diff --git a/proofs/proofview.mli b/proofs/proofview.mli index 55d93f92e..bfb88c897 100644 --- a/proofs/proofview.mli +++ b/proofs/proofview.mli @@ -37,7 +37,7 @@ type entry (* Initialises a proofview, the argument is a list of environement, conclusion types, creating that many initial goals. *) -val init : Evd.evar_map -> (Environ.env * Term.types) list -> entry * proofview +val init : Evd.evar_map -> (Environ.env * Term.types Univ.in_universe_context_set) list -> entry * proofview type telescope = | TNil diff --git a/proofs/refiner.ml b/proofs/refiner.ml index 9a78a79fd..663e24f9f 100644 --- a/proofs/refiner.ml +++ b/proofs/refiner.ml @@ -27,6 +27,10 @@ let refiner pr goal_sigma = let (sgl,sigma') = prim_refiner pr goal_sigma.sigma goal_sigma.it in { it = sgl; sigma = sigma'; } +(* Profiling refiner *) +(* let refiner_key = Profile.declare_profile "refiner" *) +(* let refiner = Profile.profile2 refiner_key refiner *) + (*********************) (* Tacticals *) (*********************) @@ -318,6 +322,19 @@ let rec tclREPEAT_MAIN t g = (* Change evars *) let tclEVARS sigma gls = tclIDTAC {gls with sigma=sigma} +(* Push universe context *) +let tclPUSHCONTEXT rigid ctx tac gl = + tclTHEN (tclEVARS (Evd.merge_context_set rigid (project gl) ctx)) tac gl + +let tclPUSHEVARUNIVCONTEXT ctx gl = + tclEVARS (Evd.merge_universe_context (project gl) ctx) gl + +let tclPUSHCONSTRAINTS cst gl = + tclEVARS (Evd.add_constraints (project gl) cst) gl + +let tclPUSHUNIVERSECONSTRAINTS cst gl = + tclEVARS (Evd.add_universe_constraints (project gl) cst) gl + (* Check that holes in arguments have been resolved *) let check_evars env sigma extsigma origsigma = diff --git a/proofs/refiner.mli b/proofs/refiner.mli index f73bdaf93..25ab1fb76 100644 --- a/proofs/refiner.mli +++ b/proofs/refiner.mli @@ -34,6 +34,12 @@ val tclIDTAC_MESSAGE : Pp.std_ppcmds -> tactic (** [tclEVARS sigma] changes the current evar map *) val tclEVARS : evar_map -> tactic +val tclPUSHCONTEXT : Evd.rigid -> Univ.universe_context_set -> tactic -> tactic +val tclPUSHEVARUNIVCONTEXT : Evd.evar_universe_context -> tactic + +val tclPUSHCONSTRAINTS : Univ.constraints -> tactic +val tclPUSHUNIVERSECONSTRAINTS : Univ.UniverseConstraints.t -> tactic + (** [tclTHEN tac1 tac2 gls] applies the tactic [tac1] to [gls] and applies [tac2] to every resulting subgoals *) val tclTHEN : tactic -> tactic -> tactic diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml index 855529ac2..2faf18355 100644 --- a/proofs/tacmach.ml +++ b/proofs/tacmach.ml @@ -86,8 +86,10 @@ let pf_unfoldn ubinds = pf_reduce (unfoldn ubinds) let pf_type_of = pf_reduce type_of let pf_get_type_of = pf_reduce Retyping.get_type_of -let pf_conv_x = pf_reduce is_conv -let pf_conv_x_leq = pf_reduce is_conv_leq +let pf_conv_x gl = pf_reduce test_conversion gl Reduction.CONV +let pf_conv_x_leq gl = pf_reduce test_conversion gl Reduction.CUMUL +let pf_const_value = pf_reduce (fun env _ -> constant_value_in env) + let pf_reduce_to_quantified_ind = pf_reduce reduce_to_quantified_ind let pf_reduce_to_atomic_ind = pf_reduce reduce_to_atomic_ind diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli index 7bac4c6e9..326d14bf6 100644 --- a/proofs/tacmach.mli +++ b/proofs/tacmach.mli @@ -62,12 +62,13 @@ val pf_whd_betadeltaiota : goal sigma -> constr -> constr val pf_hnf_constr : goal sigma -> constr -> constr val pf_nf : goal sigma -> constr -> constr val pf_nf_betaiota : goal sigma -> constr -> constr -val pf_reduce_to_quantified_ind : goal sigma -> types -> inductive * types -val pf_reduce_to_atomic_ind : goal sigma -> types -> inductive * types +val pf_reduce_to_quantified_ind : goal sigma -> types -> pinductive * types +val pf_reduce_to_atomic_ind : goal sigma -> types -> pinductive * types val pf_compute : goal sigma -> constr -> constr val pf_unfoldn : (occurrences * evaluable_global_reference) list -> goal sigma -> constr -> constr +val pf_const_value : goal sigma -> pconstant -> constr val pf_conv_x : goal sigma -> constr -> constr -> bool val pf_conv_x_leq : goal sigma -> constr -> constr -> bool @@ -125,7 +126,7 @@ module New : sig val pf_last_hyp : [ `NF ] Proofview.Goal.t -> named_declaration val pf_nf_concl : [ `LZ ] Proofview.Goal.t -> types - val pf_reduce_to_quantified_ind : 'a Proofview.Goal.t -> types -> inductive * types + val pf_reduce_to_quantified_ind : 'a Proofview.Goal.t -> types -> pinductive * types val pf_hnf_constr : 'a Proofview.Goal.t -> constr -> types val pf_hnf_type_of : 'a Proofview.Goal.t -> constr -> types diff --git a/stm/lemmas.ml b/stm/lemmas.ml index 8f16ad5a4..2aeb8141e 100644 --- a/stm/lemmas.ml +++ b/stm/lemmas.ml @@ -73,7 +73,7 @@ let find_mutually_recursive_statements thms = | Some (Some (_,id),CStructRec) -> let i,b,typ = lookup_rel_id id hyps in (match kind_of_term t with - | Ind (kn,_ as ind) when + | Ind ((kn,_ as ind), u) when let mind = Global.lookup_mind kn in mind.mind_finite && Option.is_empty b -> [ind,x,i],[] @@ -90,7 +90,7 @@ let find_mutually_recursive_statements thms = let ind_hyps = List.flatten (List.map_i (fun i (_,b,t) -> match kind_of_term t with - | Ind (kn,_ as ind) when + | Ind ((kn,_ as ind),u) when let mind = Global.lookup_mind kn in mind.mind_finite && Option.is_empty b -> [ind,x,i] @@ -100,7 +100,7 @@ let find_mutually_recursive_statements thms = let cclenv = push_rel_context hyps (Global.env()) in let whnf_ccl,_ = whd_betadeltaiota_stack cclenv Evd.empty ccl in match kind_of_term whnf_ccl with - | Ind (kn,_ as ind) when + | Ind ((kn,_ as ind),u) when let mind = Global.lookup_mind kn in Int.equal mind.mind_ntypes n && not mind.mind_finite -> [ind,x,0] @@ -167,9 +167,11 @@ let look_for_possibly_mutual_statements = function (* Saving a goal *) -let save id const do_guard (locality,kind) hook = +let save id const cstrs do_guard (locality,poly,kind) hook = let const = adjust_guardness_conditions const do_guard in let k = Kindops.logical_kind_of_goal_kind kind in + (* Add global constraints necessary to check the type of the proof *) + let () = Global.add_constraints cstrs in let l,r = match locality with | Discharge when Lib.sections_are_opened () -> let c = SectionLocalDef const in @@ -198,14 +200,14 @@ let compute_proof_name locality = function | None -> next_global_ident_away default_thm_id (Pfedit.get_all_proof_names ()) -let save_remaining_recthms (locality,kind) body opaq i (id,(t_i,(_,imps))) = +let save_remaining_recthms (locality,p,kind) body opaq i (id,((t_i,ctx_i),(_,imps))) = match body with | None -> (match locality with | Discharge -> let impl = false in (* copy values from Vernacentries *) let k = IsAssumption Conjectural in - let c = SectionLocalAssum (t_i,impl) in + let c = SectionLocalAssum ((t_i,ctx_i),p,impl) in let _ = declare_variable id (Lib.cwd(),c,k) in (Discharge, VarRef id,imps) | Local | Global -> @@ -215,7 +217,8 @@ let save_remaining_recthms (locality,kind) body opaq i (id,(t_i,(_,imps))) = | Global -> false | Discharge -> assert false in - let decl = (ParameterEntry (None,t_i,None), k) in + let ctx = Univ.ContextSet.to_context ctx_i in + let decl = (ParameterEntry (None,p,(t_i,ctx),None), k) in let kn = declare_constant id ~local decl in (locality,ConstRef kn,imps)) | Some body -> @@ -230,27 +233,26 @@ let save_remaining_recthms (locality,kind) body opaq i (id,(t_i,(_,imps))) = Future.from_val (body_i,Declareops.no_seff); const_entry_secctx = None; const_entry_type = Some t_i; + const_entry_proj = None; const_entry_opaque = opaq; - const_entry_inline_code = false; const_entry_feedback = None; + const_entry_inline_code = false; + const_entry_polymorphic = p; + const_entry_universes = Univ.ContextSet.to_context ctx_i } in let c = SectionLocalDef const in let _ = declare_variable id (Lib.cwd(), c, k) in (Discharge,VarRef id,imps) | Local | Global -> + let ctx = Univ.ContextSet.to_context ctx_i in let local = match locality with | Local -> true | Global -> false | Discharge -> assert false in - let const = { const_entry_body = - Future.from_val (body_i,Declareops.no_seff); - const_entry_secctx = None; - const_entry_type = Some t_i; - const_entry_opaque = opaq; - const_entry_inline_code = false; - const_entry_feedback = None; - } in + let const = + Declare.definition_entry ~types:t_i ~poly:p ~univs:ctx ~opaque:opaq body_i + in let kn = declare_constant id ~local (DefinitionEntry const, k) in (locality,ConstRef kn,imps) @@ -258,8 +260,8 @@ let save_hook = ref ignore let set_save_hook f = save_hook := f let save_named proof = - let id,const,do_guard,persistence,hook = proof in - save id const do_guard persistence hook + let id,const,cstrs,do_guard,persistence,hook = proof in + save id const cstrs do_guard persistence hook let check_anonymity id save_ident = if not (String.equal (atompart_of_id id) (Id.to_string (default_thm_id))) then @@ -267,25 +269,29 @@ let check_anonymity id save_ident = let save_anonymous proof save_ident = - let id,const,do_guard,persistence,hook = proof in + let id,const,cstrs,do_guard,persistence,hook = proof in check_anonymity id save_ident; - save save_ident const do_guard persistence hook + save save_ident const cstrs do_guard persistence hook let save_anonymous_with_strength proof kind save_ident = - let id,const,do_guard,_,hook = proof in + let id,const,cstrs,do_guard,_,hook = proof in check_anonymity id save_ident; (* we consider that non opaque behaves as local for discharge *) - save save_ident const do_guard (Global, Proof kind) hook + save save_ident const cstrs do_guard (Global, const.const_entry_polymorphic, Proof kind) hook (* Admitted *) let admit hook () = let (id,k,typ) = Pfedit.current_proof_statement () in - let e = Pfedit.get_used_variables(), typ, None in - let kn = declare_constant id (ParameterEntry e,IsAssumption Conjectural) in - let () = match fst k with - | Global -> () - | Local | Discharge -> + let ctx = + let evd = fst (Pfedit.get_current_goal_context ()) in + Evd.universe_context evd + in + let e = Pfedit.get_used_variables(), pi2 k, (typ, ctx), None in + let kn = declare_constant id (ParameterEntry e, IsAssumption Conjectural) in + let () = match k with + | Global, _, _ -> () + | Local, _, _ | Discharge, _, _ -> msg_warning (str "Let definition" ++ spc () ++ pr_id id ++ spc () ++ str "declared as an axiom.") in @@ -302,7 +308,8 @@ let get_proof proof do_guard hook opacity = let (id,(const,persistence)) = Pfedit.cook_this_proof proof in - id,{const with const_entry_opaque = opacity},do_guard,persistence,hook + (** FIXME *) + id,{const with const_entry_opaque = opacity},Univ.Constraint.empty,do_guard,persistence,hook let standard_proof_terminator compute_guard hook = let open Proof_global in function @@ -325,13 +332,14 @@ let start_proof id kind ?sign c ?init_tac ?(compute_guard=[]) hook = | Some sign -> sign | None -> initialize_named_context_for_proof () in - !start_hook c; + !start_hook (fst c); Pfedit.start_proof id kind sign c ?init_tac terminator +(* FIXME: forgetting about the universes here *) let rec_tac_initializer finite guard thms snl = if finite then - match List.map (fun (id,(t,_)) -> (id,t)) thms with + match List.map (fun (id,(t,_)) -> (id,fst t)) thms with | (id,_)::l -> Tactics.mutual_cofix id l 0 | _ -> assert false else @@ -339,7 +347,7 @@ let rec_tac_initializer finite guard thms snl = let nl = match snl with | None -> List.map succ (List.map List.last guard) | Some nl -> nl - in match List.map2 (fun (id,(t,_)) n -> (id,n,t)) thms nl with + in match List.map2 (fun (id,(t,_)) n -> (id,n,fst t)) thms nl with | (id,n,_)::l -> Tactics.mutual_fix id n l 0 | _ -> assert false @@ -382,19 +390,24 @@ let start_proof_with_initialization kind recguard thms snl hook = start_proof id kind t ?init_tac hook ~compute_guard:guard let start_proof_com kind thms hook = - let evdref = ref Evd.empty in let env0 = Global.env () in + let evdref = ref (Evd.from_env env0) in let thms = List.map (fun (sopt,(bl,t,guard)) -> let impls, ((env, ctx), imps) = interp_context_evars evdref env0 bl in let t', imps' = interp_type_evars_impls ~impls evdref env t in check_evars_are_solved env Evd.empty !evdref; let ids = List.map pi1 ctx in - (compute_proof_name (fst kind) sopt, + (compute_proof_name (pi1 kind) sopt, (nf_evar !evdref (it_mkProd_or_LetIn t' ctx), (ids, imps @ lift_implicits (List.length ids) imps'), guard))) thms in let recguard,thms,snl = look_for_possibly_mutual_statements thms in + let evd, nf = Evarutil.nf_evars_and_universes !evdref in + let ctxset = Evd.get_universe_context_set evd in + let thms = List.map (fun (n, (t, info)) -> (n, ((nf t, ctxset), info))) + thms + in start_proof_with_initialization kind recguard thms snl hook @@ -419,13 +432,3 @@ let get_current_context () = try Pfedit.get_current_goal_context () with e when Logic.catchable_exception e -> (Evd.empty, Global.env()) - - - - - - - - - - diff --git a/stm/lemmas.mli b/stm/lemmas.mli index bbe383a85..f8694a096 100644 --- a/stm/lemmas.mli +++ b/stm/lemmas.mli @@ -17,7 +17,7 @@ open Pfedit (** A hook start_proof calls on the type of the definition being started *) val set_start_hook : (types -> unit) -> unit -val start_proof : Id.t -> goal_kind -> ?sign:Environ.named_context_val -> types -> +val start_proof : Id.t -> goal_kind -> ?sign:Environ.named_context_val -> types Univ.in_universe_context_set -> ?init_tac:unit Proofview.tactic -> ?compute_guard:lemma_possible_guards -> unit declaration_hook -> unit @@ -27,7 +27,7 @@ val start_proof_com : goal_kind -> val start_proof_with_initialization : goal_kind -> (bool * lemma_possible_guards * unit Proofview.tactic list option) option -> - (Id.t * (types * (Name.t list * Impargs.manual_explicitation list))) list + (Id.t * (types Univ.in_universe_context_set * (Name.t list * Impargs.manual_explicitation list))) list -> int list option -> unit declaration_hook -> unit val standard_proof_terminator : diff --git a/stm/stm.ml b/stm/stm.ml index 6fe3fd03a..0218c923b 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -741,8 +741,9 @@ end = struct let l = Future.force (build_proof_here exn_info loc eop) in List.iter (fun (_,se) -> Declareops.iter_side_effects (function | Declarations.SEsubproof(_, - { Declarations.const_body = Declarations.OpaqueDef f } ) -> - Opaqueproof.join_opaque f + { Declarations.const_body = Declarations.OpaqueDef f; + const_universes = univs } ) -> + Opaqueproof.join_opaque f; ignore (Future.join univs) (* FIXME: MS: needed?*) | _ -> ()) se) l; l, Unix.gettimeofday () -. wall_clock in @@ -814,7 +815,7 @@ end = struct let extra = Future.join uc in u.(bucket) <- uc; p.(bucket) <- pr; - u, Univ.union_constraints cst extra, false + u, Univ.union_constraint cst extra, false | _ -> assert false let check_task name l i = @@ -982,13 +983,13 @@ end = struct Pp.feedback (Interface.InProgress ~-1) *) last_task := None; raise KillRespawn - | _, RespGetCounterFreshLocalUniv -> - marshal_more_data oc (MoreDataLocalUniv - (CList.init 10 (fun _ -> Univ.fresh_local_univ ()))); - if !cancel_switch then raise KillRespawn else loop () + | _, RespGetCounterFreshLocalUniv -> assert false (* Deprecated function *) + (* marshal_more_data oc (MoreDataLocalUniv *) + (* (CList.init 10 (fun _ -> Universes.fresh_local_univ ()))); *) + (* loop () *) | _, RespGetCounterNewUnivLevel -> marshal_more_data oc (MoreDataUnivLevel - (CList.init 10 (fun _ -> Termops.new_univ_level ()))); + (CList.init 10 (fun _ -> Universes.new_univ_level (Global.current_dirpath ())))); loop () | _, RespFeedback {id = State state_id; content = msg} -> Pp.feedback ~state_id msg; @@ -1082,14 +1083,10 @@ end = struct Marshal.to_channel oc (RespFeedback fb) []; flush oc in Pp.set_feeder (slave_feeder !slave_oc); - Termops.set_remote_new_univ_level (bufferize (fun () -> + Universes.set_remote_new_univ_level (bufferize (fun () -> marshal_response !slave_oc RespGetCounterNewUnivLevel; match unmarshal_more_data !slave_ic with | MoreDataUnivLevel l -> l | _ -> assert false)); - Univ.set_remote_fresh_local_univ (bufferize (fun () -> - marshal_response !slave_oc RespGetCounterFreshLocalUniv; - match unmarshal_more_data !slave_ic with - | MoreDataLocalUniv l -> l | _ -> assert false)); let working = ref false in slave_handshake (); while true do diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index 49cbcd246..3bd83f46b 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -66,6 +66,7 @@ let rec classify_vernac e = (* Nested vernac exprs *) | VernacProgram e -> classify_vernac e | VernacLocal (_,e) -> classify_vernac e + | VernacPolymorphic (b, e) -> classify_vernac e | VernacTimeout (_,e) -> classify_vernac e | VernacTime e -> classify_vernac e | VernacFail e -> (* Fail Qed or Fail Lemma must not join/fork the DAG *) diff --git a/tactics/auto.ml b/tactics/auto.ml index 152556c74..0f296c6af 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -36,16 +36,17 @@ open Tacexpr open Mod_subst open Locus open Proofview.Notations +open Decl_kinds (****************************************************************************) (* The Type of Constructions Autotactic Hints *) (****************************************************************************) type 'a auto_tactic = - | Res_pf of constr * 'a (* Hint Apply *) - | ERes_pf of constr * 'a (* Hint EApply *) - | Give_exact of constr - | Res_pf_THEN_trivial_fail of constr * 'a (* Hint Immediate *) + | Res_pf of 'a (* Hint Apply *) + | ERes_pf of 'a (* Hint EApply *) + | Give_exact of 'a + | Res_pf_THEN_trivial_fail of 'a (* Hint Immediate *) | Unfold_nth of evaluable_global_reference (* Hint Unfold *) | Extern of glob_tactic_expr (* Hint Extern *) @@ -61,16 +62,22 @@ type hints_path = | PathEmpty | PathEpsilon +type hint_term = + | IsGlobRef of global_reference + | IsConstr of constr * Univ.universe_context_set + type 'a gen_auto_tactic = { pri : int; (* A number lower is higher priority *) + poly : polymorphic; (** Is the hint polymorpic and hence should be refreshed at each application *) pat : constr_pattern option; (* A pattern for the concl of the Goal *) name : hints_path_atom; (* A potential name to refer to the hint *) code : 'a auto_tactic (* the tactic to apply when the concl matches pat *) } -type pri_auto_tactic = clausenv gen_auto_tactic +type pri_auto_tactic = (constr * clausenv) gen_auto_tactic -type hint_entry = global_reference option * types gen_auto_tactic +type hint_entry = global_reference option * + (constr * types * Univ.universe_context_set) gen_auto_tactic let eq_hints_path_atom p1 p2 = match p1, p2 with | PathHints gr1, PathHints gr2 -> List.equal eq_gr gr1 gr2 @@ -80,7 +87,7 @@ let eq_hints_path_atom p1 p2 = match p1, p2 with let eq_auto_tactic t1 t2 = match t1, t2 with | Res_pf (c1, _), Res_pf (c2, _) -> Constr.equal c1 c2 | ERes_pf (c1, _), ERes_pf (c2, _) -> Constr.equal c1 c2 -| Give_exact c1, Give_exact c2 -> Constr.equal c1 c2 +| Give_exact (c1, _), Give_exact (c2, _) -> Constr.equal c1 c2 | Res_pf_THEN_trivial_fail (c1, _), Res_pf_THEN_trivial_fail (c2, _) -> Constr.equal c1 c2 | Unfold_nth gr1, Unfold_nth gr2 -> eq_egr gr1 gr2 | Extern tac1, Extern tac2 -> tac1 == tac2 (** May cause redundancy in addkv *) @@ -134,17 +141,23 @@ type search_entry = stored_data list * stored_data list * Bounded_net.t let empty_se = ([],[],Bounded_net.create ()) +let eq_constr_or_reference x y = + match x, y with + | IsConstr (x,_), IsConstr (y,_) -> eq_constr x y + | IsGlobRef x, IsGlobRef y -> eq_gr x y + | _, _ -> false + let eq_pri_auto_tactic (_, x) (_, y) = if Int.equal x.pri y.pri && Option.equal constr_pattern_eq x.pat y.pat then match x.code,y.code with - | Res_pf(cstr,_),Res_pf(cstr1,_) -> + | Res_pf (cstr,_),Res_pf (cstr1,_) -> eq_constr cstr cstr1 - | ERes_pf(cstr,_),ERes_pf(cstr1,_) -> + | ERes_pf (cstr,_),ERes_pf (cstr1,_) -> eq_constr cstr cstr1 - | Give_exact cstr,Give_exact cstr1 -> + | Give_exact (cstr,_),Give_exact (cstr1,_) -> eq_constr cstr cstr1 - | Res_pf_THEN_trivial_fail(cstr,_) - ,Res_pf_THEN_trivial_fail(cstr1,_) -> + | Res_pf_THEN_trivial_fail (cstr,_) + ,Res_pf_THEN_trivial_fail (cstr1,_) -> eq_constr cstr cstr1 | _,_ -> false else @@ -176,20 +189,44 @@ let is_transparent_gr (ids, csts) = function let dummy_goal = Goal.V82.dummy_goal -let translate_hint (go,p) = - let mk_clenv (c,t) = - let cl = mk_clenv_from dummy_goal (c,t) in {cl with env = empty_env } +let instantiate_constr_or_ref env sigma c = + let c, ctx = Universes.fresh_global_or_constr_instance env c in + let cty = Retyping.get_type_of env sigma c in + (c, cty), ctx + +let strip_params env c = + match kind_of_term c with + | App (f, args) -> + (match kind_of_term f with + | Const (p,_) -> + let cb = lookup_constant p env in + (match cb.Declarations.const_proj with + | Some pb -> + let n = pb.Declarations.proj_npars in + mkApp (mkProj (p, args.(n)), + Array.sub args (n+1) (Array.length args - (n + 1))) + | None -> c) + | _ -> c) + | _ -> c + +let instantiate_hint p = + let mk_clenv c cty ctx = + let sigma = Evd.merge_context_set univ_flexible dummy_goal.sigma ctx in + let goal = { dummy_goal with sigma = sigma } in + let cl = mk_clenv_from goal (c,cty) in + {cl with templval = + { cl.templval with rebus = strip_params (Global.env()) cl.templval.rebus }; + env = empty_env} in let code = match p.code with - | Res_pf (c,t) -> Res_pf (c, mk_clenv (c,t)) - | ERes_pf (c,t) -> ERes_pf (c, mk_clenv (c,t)) - | Res_pf_THEN_trivial_fail (c,t) -> - Res_pf_THEN_trivial_fail (c, mk_clenv (c,t)) - | Give_exact c -> Give_exact c + | Res_pf (c, cty, ctx) -> Res_pf (c, mk_clenv c cty ctx) + | ERes_pf (c, cty, ctx) -> ERes_pf (c, mk_clenv c cty ctx) + | Res_pf_THEN_trivial_fail (c, cty, ctx) -> + Res_pf_THEN_trivial_fail (c, mk_clenv c cty ctx) + | Give_exact (c, cty, ctx) -> Give_exact (c, mk_clenv c cty ctx) | Unfold_nth e -> Unfold_nth e | Extern t -> Extern t - in - (go,{ p with code = code }) + in { pri = p.pri; poly = p.poly; name = p.name; pat = p.pat; code = code } let hints_path_atom_eq h1 h2 = match h1, h2 with | PathHints l1, PathHints l2 -> List.equal eq_gr l1 l2 @@ -350,17 +387,19 @@ module Hint_db = struct try Constr_map.find key db.hintdb_map with Not_found -> empty_se + let realize_tac (id,tac) = tac + let map_none db = - List.map snd (List.merge pri_order_int (List.map snd db.hintdb_nopat) []) + List.map realize_tac (Sort.merge pri_order (List.map snd db.hintdb_nopat) []) let map_all k db = let (l,l',_) = find k db in - List.map snd (List.merge pri_order_int (List.map snd db.hintdb_nopat @ l) l') + List.map realize_tac (Sort.merge pri_order (List.map snd db.hintdb_nopat @ l) l') let map_auto (k,c) db = let st = if db.use_dn then Some db.hintdb_state else None in let l' = lookup_tacs (k,c) st (find k db) in - List.map snd (List.merge pri_order_int (List.map snd db.hintdb_nopat) l') + List.map realize_tac (Sort.merge pri_order (List.map snd db.hintdb_nopat) l') let is_exact = function | Give_exact _ -> true @@ -384,6 +423,7 @@ module Hint_db = struct (** ppedrot: this equality here is dubious. Maybe we can remove it? *) let is_present (_, (_, v')) = eq_gen_auto_tactic v v' in if not (List.exists is_present db.hintdb_nopat) then + (** FIXME *) { db with hintdb_nopat = (gr,idv) :: db.hintdb_nopat } else db | Some gr -> @@ -397,8 +437,8 @@ module Hint_db = struct in List.fold_left (fun db (gr,(id,v)) -> addkv gr id v db) db' db.hintdb_nopat - let add_one kv db = - let (k,v) = translate_hint kv in + let add_one (k, v) db = + let v = instantiate_hint v in let st',db,rebuild = match v.code with | Unfold_nth egr -> @@ -432,8 +472,8 @@ module Hint_db = struct let remove_one gr db = remove_list [gr] db let iter f db = - f None (List.map (fun x -> snd (snd x)) db.hintdb_nopat); - Constr_map.iter (fun k (l,l',_) -> f (Some k) (List.map snd (l@l'))) db.hintdb_map + f None (List.map (fun x -> realize_tac (snd x)) db.hintdb_nopat); + Constr_map.iter (fun k (l,l',_) -> f (Some k) (List.map realize_tac (l@l'))) db.hintdb_map let fold f db accu = let accu = f None (List.map (fun x -> snd (snd x)) db.hintdb_nopat) accu in @@ -516,7 +556,7 @@ let try_head_pattern c = try head_pattern_bound c with BoundPattern -> error "Bound head variable." -let make_exact_entry sigma pri ?(name=PathAny) (c,cty) = +let make_exact_entry env sigma pri poly ?(name=PathAny) (c, cty, ctx) = let cty = strip_outer_cast cty in match kind_of_term cty with | Prod _ -> failwith "make_exact_entry" @@ -528,15 +568,17 @@ let make_exact_entry sigma pri ?(name=PathAny) (c,cty) = in (Some hd, { pri = (match pri with None -> 0 | Some p -> p); + poly = poly; pat = Some pat; name = name; - code = Give_exact c }) + code = Give_exact (c, cty, ctx) }) -let make_apply_entry env sigma (eapply,hnf,verbose) pri ?(name=PathAny) (c,cty) = +let make_apply_entry env sigma (eapply,hnf,verbose) pri poly ?(name=PathAny) (c, cty, ctx) = let cty = if hnf then hnf_constr env sigma cty else cty in match kind_of_term cty with | Prod _ -> - let ce = mk_clenv_from dummy_goal (c,cty) in + let sigma' = Evd.merge_context_set univ_flexible dummy_goal.sigma ctx in + let ce = mk_clenv_from { dummy_goal with sigma = sigma' } (c,cty) in let c' = clenv_type (* ~reduce:false *) ce in let pat = snd (Patternops.pattern_of_constr sigma c') in let hd = @@ -546,9 +588,10 @@ let make_apply_entry env sigma (eapply,hnf,verbose) pri ?(name=PathAny) (c,cty) if Int.equal nmiss 0 then (Some hd, { pri = (match pri with None -> nb_hyp cty | Some p -> p); + poly = poly; pat = Some pat; name = name; - code = Res_pf(c,cty) }) + code = Res_pf(c,cty,ctx) }) else begin if not eapply then failwith "make_apply_entry"; if verbose then @@ -556,9 +599,10 @@ let make_apply_entry env sigma (eapply,hnf,verbose) pri ?(name=PathAny) (c,cty) str " will only be used by eauto"); (Some hd, { pri = (match pri with None -> nb_hyp cty + nmiss | Some p -> p); + poly = poly; pat = Some pat; name = name; - code = ERes_pf(c,cty) }) + code = ERes_pf(c,cty,ctx) }) end | _ -> failwith "make_apply_entry" @@ -566,12 +610,18 @@ let make_apply_entry env sigma (eapply,hnf,verbose) pri ?(name=PathAny) (c,cty) c is a constr cty is the type of constr *) -let make_resolves env sigma flags pri ?name c = +let fresh_global_or_constr env sigma poly cr = + match cr with + | IsGlobRef gr -> Universes.fresh_global_instance env gr + | IsConstr (c, ctx) -> (c, ctx) + +let make_resolves env sigma flags pri poly ?name cr = + let c, ctx = fresh_global_or_constr env sigma poly cr in let cty = Retyping.get_type_of env sigma c in let try_apply f = - try Some (f (c, cty)) with Failure _ -> None in + try Some (f (c, cty, ctx)) with Failure _ -> None in let ents = List.map_filter try_apply - [make_exact_entry sigma pri ?name; make_apply_entry env sigma flags pri ?name] + [make_exact_entry env sigma pri poly ?name; make_apply_entry env sigma flags pri poly ?name] in if List.is_empty ents then errorlabstrm "Hint" @@ -583,9 +633,9 @@ let make_resolves env sigma flags pri ?name c = (* used to add an hypothesis to the local hint database *) let make_resolve_hyp env sigma (hname,_,htyp) = try - [make_apply_entry env sigma (true, true, false) None + [make_apply_entry env sigma (true, true, false) None false ~name:(PathHints [VarRef hname]) - (mkVar hname, htyp)] + (mkVar hname, htyp, Univ.ContextSet.empty)] with | Failure _ -> [] | e when Logic.catchable_exception e -> anomaly (Pp.str "make_resolve_hyp") @@ -595,6 +645,7 @@ let make_unfold eref = let g = global_of_evaluable_reference eref in (Some g, { pri = 4; + poly = false; pat = None; name = PathHints [g]; code = Unfold_nth eref }) @@ -603,19 +654,21 @@ let make_extern pri pat tacast = let hdconstr = Option.map try_head_pattern pat in (hdconstr, { pri = pri; + poly = false; pat = pat; name = PathAny; code = Extern tacast }) -let make_trivial env sigma ?(name=PathAny) r = - let c = constr_of_global_or_constr r in +let make_trivial env sigma poly ?(name=PathAny) r = + let c,ctx = fresh_global_or_constr env sigma poly r in let t = hnf_constr env sigma (type_of env sigma c) in - let hd = head_of_constr_reference (fst (head_constr t)) in + let hd = head_of_constr_reference (head_constr t) in let ce = mk_clenv_from dummy_goal (c,t) in (Some hd, { pri=1; + poly = poly; pat = Some (snd (Patternops.pattern_of_constr sigma (clenv_type ce))); name = name; - code=Res_pf_THEN_trivial_fail(c,t) }) + code=Res_pf_THEN_trivial_fail(c,t,ctx) }) open Vernacexpr @@ -675,11 +728,21 @@ let cache_autohint (_,(local,name,hints)) = let (forward_subst_tactic, extern_subst_tactic) = Hook.make () + (* let subst_mps_or_ref subst cr = *) + (* match cr with *) + (* | IsConstr c -> let c' = subst_mps subst c in *) + (* if c' == c then cr *) + (* else IsConstr c' *) + (* | IsGlobal r -> let r' = subst_global_reference subst r in *) + (* if r' == r then cr *) + (* else IsGlobal r' *) + (* in *) + let subst_autohint (subst,(local,name,hintlist as obj)) = let subst_key gr = let (lab'', elab') = subst_global subst gr in let gr' = - (try head_of_constr_reference (fst (head_constr_bound elab')) + (try head_of_constr_reference (head_constr_bound elab') with Tactics.Bound -> lab'') in if gr' == gr then gr else gr' in @@ -687,21 +750,22 @@ let subst_autohint (subst,(local,name,hintlist as obj)) = let k' = Option.smartmap subst_key k in let pat' = Option.smartmap (subst_pattern subst) data.pat in let code' = match data.code with - | Res_pf (c,t) -> + | Res_pf (c,t,ctx) -> let c' = subst_mps subst c in let t' = subst_mps subst t in - if c==c' && t'==t then data.code else Res_pf (c', t') - | ERes_pf (c,t) -> + if c==c' && t'==t then data.code else Res_pf (c', t',ctx) + | ERes_pf (c,t,ctx) -> let c' = subst_mps subst c in let t' = subst_mps subst t in - if c==c' && t'==t then data.code else ERes_pf (c',t') - | Give_exact c -> + if c==c' && t'==t then data.code else ERes_pf (c',t',ctx) + | Give_exact (c,t,ctx) -> let c' = subst_mps subst c in - if c==c' then data.code else Give_exact c' - | Res_pf_THEN_trivial_fail (c,t) -> + let t' = subst_mps subst t in + if c==c' && t'== t then data.code else Give_exact (c',t',ctx) + | Res_pf_THEN_trivial_fail (c,t,ctx) -> let c' = subst_mps subst c in let t' = subst_mps subst t in - if c==c' && t==t' then data.code else Res_pf_THEN_trivial_fail (c',t') + if c==c' && t==t' then data.code else Res_pf_THEN_trivial_fail (c',t',ctx) | Unfold_nth ref -> let ref' = subst_evaluable_reference subst ref in if ref==ref' then data.code else Unfold_nth ref' @@ -765,13 +829,9 @@ let add_resolves env sigma clist local dbnames = Lib.add_anonymous_leaf (inAutoHint (local,dbname, AddHints - (List.flatten (List.map (fun (x, hnf, path, gr) -> - let c = - match gr with - | IsConstr c -> c - | IsGlobal gr -> constr_of_global gr - in - make_resolves env sigma (true,hnf,Flags.is_verbose()) x ~name:path c) clist))))) + (List.flatten (List.map (fun (pri, poly, hnf, path, gr) -> + make_resolves env sigma (true,hnf,Flags.is_verbose()) + pri poly ~name:path gr) clist))))) dbnames let add_unfolds l local dbnames = @@ -808,14 +868,20 @@ let add_trivials env sigma l local dbnames = (fun dbname -> Lib.add_anonymous_leaf ( inAutoHint(local,dbname, - AddHints (List.map (fun (name, c) -> make_trivial env sigma ~name c) l)))) + AddHints (List.map (fun (name, poly, c) -> make_trivial env sigma poly ~name c) l)))) dbnames let (forward_intern_tac, extern_intern_tac) = Hook.make () +type hnf = bool + +let pr_hint_term = function + | IsConstr (c,_) -> pr_constr c + | IsGlobRef gr -> pr_global gr + type hints_entry = - | HintsResolveEntry of (int option * bool * hints_path_atom * global_reference_or_constr) list - | HintsImmediateEntry of (hints_path_atom * global_reference_or_constr) list + | HintsResolveEntry of (int option * polymorphic * hnf * hints_path_atom * hint_term) list + | HintsImmediateEntry of (hints_path_atom * polymorphic * hint_term) list | HintsCutEntry of hints_path | HintsUnfoldEntry of evaluable_global_reference list | HintsTransparencyEntry of evaluable_global_reference list * bool @@ -826,7 +892,7 @@ let h = Id.of_string "H" exception Found of constr * types -let prepare_hint env (sigma,c) = +let prepare_hint check env init (sigma,c) = let sigma = Typeclasses.resolve_typeclasses ~fail:false env sigma in (* We re-abstract over uninstantiated evars. It is actually a bit stupid to generalize over evars since the first @@ -853,15 +919,16 @@ let prepare_hint env (sigma,c) = vars := Id.Set.add id !vars; subst := (evar,mkVar id)::!subst; mkNamedLambda id t (iter (replace_term evar (mkVar id) c)) in - iter c + let c' = iter c in + if check then Evarutil.check_evars (Global.env()) Evd.empty sigma c'; + let diff = Evd.diff sigma init in + IsConstr (c', Evd.get_universe_context_set diff) -let interp_hints = +let interp_hints poly = fun h -> let f c = let evd,c = Constrintern.interp_open_constr Evd.empty (Global.env()) c in - let c = prepare_hint (Global.env()) (evd,c) in - Evarutil.check_evars (Global.env()) Evd.empty evd c; - c in + prepare_hint true (Global.env()) Evd.empty (evd,c) in let fr r = let gr = global_with_alias r in let r' = evaluable_of_global_reference (Global.env()) gr in @@ -871,12 +938,17 @@ let interp_hints = match c with | HintsReference c -> let gr = global_with_alias c in - (PathHints [gr], IsGlobal gr) - | HintsConstr c -> (PathAny, IsConstr (f c)) + (PathHints [gr], poly, IsGlobRef gr) + | HintsConstr c -> + (* if poly then *) + (* errorlabstrm "Hint" (Ppconstr.pr_constr_expr c ++ spc () ++ *) + (* str" is a term and cannot be made a polymorphic hint," ++ *) + (* str" only global references can be polymorphic hints.") *) + (* else *) (PathAny, poly, f c) in - let fres (o, b, c) = - let path, gr = fi c in - (o, b, path, gr) + let fres (pri, b, r) = + let path, poly, gr = fi r in + (pri, poly, b, path, gr) in let fp = Constrintern.intern_constr_pattern (Global.env()) in match h with @@ -888,11 +960,14 @@ let interp_hints = | HintsConstructors lqid -> let constr_hints_of_ind qid = let ind = global_inductive_with_alias qid in + let mib,_ = Global.lookup_inductive ind in Dumpglob.dump_reference (fst (qualid_of_reference qid)) "<>" (string_of_reference qid) "ind"; - List.init (nconstructors ind) (fun i -> let c = (ind,i+1) in - let gr = ConstructRef c in - None, true, PathHints [gr], IsGlobal gr) in - HintsResolveEntry (List.flatten (List.map constr_hints_of_ind lqid)) + List.init (nconstructors ind) + (fun i -> let c = (ind,i+1) in + let gr = ConstructRef c in + None, mib.Declarations.mind_polymorphic, true, + PathHints [gr], IsGlobRef gr) + in HintsResolveEntry (List.flatten (List.map constr_hints_of_ind lqid)) | HintsExtern (pri, patcom, tacexp) -> let pat = Option.map fp patcom in let l = match pat with None -> [] | Some (l, _) -> l in @@ -922,7 +997,7 @@ let pr_autotactic = function | Res_pf (c,clenv) -> (str"apply " ++ pr_constr c) | ERes_pf (c,clenv) -> (str"eapply " ++ pr_constr c) - | Give_exact c -> (str"exact " ++ pr_constr c) + | Give_exact (c,clenv) -> (str"exact " ++ pr_constr c) | Res_pf_THEN_trivial_fail (c,clenv) -> (str"apply " ++ pr_constr c ++ str" ; trivial") | Unfold_nth c -> (str"unfold " ++ pr_evaluable_reference c) @@ -970,11 +1045,11 @@ let pr_hint_term cl = let dbs = current_db () in let valid_dbs = let fn = try - let (hdc,args) = head_constr_bound cl in + let hdc = head_constr_bound cl in let hd = head_of_constr_reference hdc in if occur_existential cl then Hint_db.map_all hd - else Hint_db.map_auto (hd, applist (hdc,args)) + else Hint_db.map_auto (hd, cl) with Bound -> Hint_db.map_none in let fn db = List.map (fun x -> 0, x) (fn db) in @@ -1072,40 +1147,52 @@ let auto_unif_flags = { (* Try unification with the precompiled clause, then use registered Apply *) -let unify_resolve_nodelta (c,clenv) gl = - let clenv' = connect_clenv gl clenv in +let unify_resolve_nodelta poly (c,clenv) gl = + let clenv' = if poly then fst (Clenv.refresh_undefined_univs clenv) else clenv in + let clenv' = connect_clenv gl clenv' in let clenv'' = clenv_unique_resolver ~flags:auto_unif_flags clenv' gl in Clenvtac.clenv_refine false clenv'' gl -let unify_resolve flags (c,clenv) gl = - let clenv' = connect_clenv gl clenv in +let unify_resolve poly flags (c,clenv) gl = + let clenv' = if poly then fst (Clenv.refresh_undefined_univs clenv) else clenv in + let clenv' = connect_clenv gl clenv' in let clenv'' = clenv_unique_resolver ~flags clenv' gl in Clenvtac.clenv_refine false clenv'' gl -let unify_resolve_gen = function - | None -> unify_resolve_nodelta - | Some flags -> unify_resolve flags - +let unify_resolve_gen poly = function + | None -> unify_resolve_nodelta poly + | Some flags -> unify_resolve poly flags + +let exact poly (c,clenv) = + let c' = + if poly then + let evd', subst = Evd.refresh_undefined_universes clenv.evd in + subst_univs_level_constr subst c + else c + in exact_check c' + (* Util *) -let expand_constructor_hints env lems = - List.map_append (fun (sigma,lem) -> +let expand_constructor_hints env sigma lems = + List.map_append (fun (evd,lem) -> match kind_of_term lem with - | Ind ind -> - List.init (nconstructors ind) (fun i -> mkConstruct (ind,i+1)) + | Ind (ind,u) -> + List.init (nconstructors ind) + (fun i -> IsConstr (mkConstructU ((ind,i+1),u), + Univ.ContextSet.empty)) | _ -> - [prepare_hint env (sigma,lem)]) lems + [prepare_hint false env sigma (evd,lem)]) lems (* builds a hint database from a constr signature *) (* typically used with (lid, ltyp) = pf_hyps_types <some goal> *) let add_hint_lemmas eapply lems hint_db gl = - let lems = expand_constructor_hints (pf_env gl) lems in + let lems = expand_constructor_hints (pf_env gl) (project gl) lems in let hintlist' = - List.map_append (pf_apply make_resolves gl (eapply,true,false) None) lems in + List.map_append (pf_apply make_resolves gl (eapply,true,false) None true) lems in Hint_db.add_list hintlist' hint_db -let make_local_hint_db ?ts eapply lems gl = +let make_local_hint_db ts eapply lems gl = let sign = pf_hyps gl in let ts = match ts with | None -> Hint_db.transparent_state (searchtable_map "core") @@ -1115,6 +1202,15 @@ let make_local_hint_db ?ts eapply lems gl = add_hint_lemmas eapply lems (Hint_db.add_list hintlist (Hint_db.empty ts false)) gl +let make_local_hint_db = + if Flags.profile then + let key = Profile.declare_profile "make_local_hint_db" in + Profile.profile4 key make_local_hint_db + else make_local_hint_db + +let make_local_hint_db ?ts eapply lems gl = + make_local_hint_db ts eapply lems gl + (* Serait-ce possible de compiler d'abord la tactique puis de faire la substitution sans passer par bdize dont l'objectif est de préparer un terme pour l'affichage ? (HH) *) @@ -1358,15 +1454,15 @@ and my_find_search_delta db_list local_db hdc concl = in List.map (fun x -> (Some flags,x)) l) (local_db::db_list) -and tac_of_hint dbg db_list local_db concl (flags, ({pat=p; code=t})) = +and tac_of_hint dbg db_list local_db concl (flags, ({pat=p; code=t;poly=poly})) = let tactic = match t with - | Res_pf (c,cl) -> Proofview.V82.tactic (unify_resolve_gen flags (c,cl)) + | Res_pf (c,cl) -> Proofview.V82.tactic (unify_resolve_gen poly flags (c,cl)) | ERes_pf _ -> Proofview.V82.tactic (fun gl -> error "eres_pf") - | Give_exact c -> Proofview.V82.tactic (exact_check c) + | Give_exact (c, cl) -> Proofview.V82.tactic (exact poly (c, cl)) | Res_pf_THEN_trivial_fail (c,cl) -> Tacticals.New.tclTHEN - (Proofview.V82.tactic (unify_resolve_gen flags (c,cl))) + (Proofview.V82.tactic (unify_resolve_gen poly flags (c,cl))) (* With "(debug) trivial", we shouldn't end here, and with "debug auto" we don't display the details of inner trivial *) (trivial_fail_db (no_dbg ()) (not (Option.is_empty flags)) db_list local_db) @@ -1382,7 +1478,7 @@ and tac_of_hint dbg db_list local_db concl (flags, ({pat=p; code=t})) = and trivial_resolve dbg mod_delta db_list local_db cl = try let head = - try let hdconstr,_ = head_constr_bound cl in + try let hdconstr = head_constr_bound cl in Some (head_of_constr_reference hdconstr) with Bound -> None in @@ -1436,7 +1532,7 @@ let h_trivial ?(debug=Off) lems l = gen_trivial ~debug lems l let possible_resolve dbg mod_delta db_list local_db cl = try let head = - try let hdconstr,_ = head_constr_bound cl in + try let hdconstr = head_constr_bound cl in Some (head_of_constr_reference hdconstr) with Bound -> None in @@ -1482,7 +1578,7 @@ let search d n mod_delta db_list local_db = let default_search_depth = ref 5 -let delta_auto ?(debug=Off) mod_delta n lems dbnames = +let delta_auto debug mod_delta n lems dbnames = Proofview.Goal.enter begin fun gl -> let db_list = make_db_list dbnames in let d = mk_auto_dbg debug in @@ -1491,9 +1587,15 @@ let delta_auto ?(debug=Off) mod_delta n lems dbnames = (search d n mod_delta db_list hints) end -let auto ?(debug=Off) n = delta_auto ~debug false n +let delta_auto = + if Flags.profile then + let key = Profile.declare_profile "delta_auto" in + Profile.profile5 key delta_auto + else delta_auto + +let auto ?(debug=Off) n = delta_auto debug false n -let new_auto ?(debug=Off) n = delta_auto ~debug true n +let new_auto ?(debug=Off) n = delta_auto debug true n let default_auto = auto !default_search_depth [] [] diff --git a/tactics/auto.mli b/tactics/auto.mli index 2d2720880..b85f86ea4 100644 --- a/tactics/auto.mli +++ b/tactics/auto.mli @@ -21,16 +21,17 @@ open Vernacexpr open Mod_subst open Misctypes open Pp +open Decl_kinds (** Auto and related automation tactics *) type 'a auto_tactic = - | Res_pf of constr * 'a (** Hint Apply *) - | ERes_pf of constr * 'a (** Hint EApply *) - | Give_exact of constr - | Res_pf_THEN_trivial_fail of constr * 'a (** Hint Immediate *) - | Unfold_nth of evaluable_global_reference (** Hint Unfold *) - | Extern of Tacexpr.glob_tactic_expr (** Hint Extern *) + | Res_pf of 'a (* Hint Apply *) + | ERes_pf of 'a (* Hint EApply *) + | Give_exact of 'a + | Res_pf_THEN_trivial_fail of 'a (* Hint Immediate *) + | Unfold_nth of evaluable_global_reference (* Hint Unfold *) + | Extern of Tacexpr.glob_tactic_expr (* Hint Extern *) type hints_path_atom = | PathHints of global_reference list @@ -38,20 +39,20 @@ type hints_path_atom = type 'a gen_auto_tactic = { pri : int; (** A number between 0 and 4, 4 = lower priority *) + poly : polymorphic; (** Is the hint polymorpic and hence should be refreshed at each application *) pat : constr_pattern option; (** A pattern for the concl of the Goal *) name : hints_path_atom; (** A potential name to refer to the hint *) code : 'a auto_tactic; (** the tactic to apply when the concl matches pat *) } -type pri_auto_tactic = clausenv gen_auto_tactic - -type stored_data = int * clausenv gen_auto_tactic +type pri_auto_tactic = (constr * clausenv) gen_auto_tactic type search_entry (** The head may not be bound. *) -type hint_entry = global_reference option * types gen_auto_tactic +type hint_entry = global_reference option * + (constr * types * Univ.universe_context_set) gen_auto_tactic type hints_path = | PathAtom of hints_path_atom @@ -94,9 +95,16 @@ type hint_db_name = string type hint_db = Hint_db.t +type hnf = bool + +type hint_term = + | IsGlobRef of global_reference + | IsConstr of constr * Univ.universe_context_set + type hints_entry = - | HintsResolveEntry of (int option * bool * hints_path_atom * global_reference_or_constr) list - | HintsImmediateEntry of (hints_path_atom * global_reference_or_constr) list + | HintsResolveEntry of (int option * polymorphic * hnf * hints_path_atom * + hint_term) list + | HintsImmediateEntry of (hints_path_atom * polymorphic * hint_term) list | HintsCutEntry of hints_path | HintsUnfoldEntry of evaluable_global_reference list | HintsTransparencyEntry of evaluable_global_reference list * bool @@ -118,11 +126,12 @@ val remove_hints : bool -> hint_db_name list -> global_reference list -> unit val current_db_names : unit -> String.Set.t -val interp_hints : hints_expr -> hints_entry +val interp_hints : polymorphic -> hints_expr -> hints_entry val add_hints : locality_flag -> hint_db_name list -> hints_entry -> unit -val prepare_hint : env -> open_constr -> constr +val prepare_hint : bool (* Check no remaining evars *) -> env -> evar_map -> + open_constr -> hint_term val pr_searchtable : unit -> std_ppcmds val pr_applicable_hint : unit -> std_ppcmds @@ -134,7 +143,8 @@ val pr_hint_db : Hint_db.t -> std_ppcmds [c] is the term given as an exact proof to solve the goal; [ctyp] is the type of [c]. *) -val make_exact_entry : evar_map -> int option -> ?name:hints_path_atom -> constr * constr -> hint_entry +val make_exact_entry : env -> evar_map -> int option -> polymorphic -> ?name:hints_path_atom -> + (constr * types * Univ.universe_context_set) -> hint_entry (** [make_apply_entry (eapply,hnf,verbose) pri (c,cty)]. [eapply] is true if this hint will be used only with EApply; @@ -144,8 +154,8 @@ val make_exact_entry : evar_map -> int option -> ?name:hints_path_atom -> constr [cty] is the type of [c]. *) val make_apply_entry : - env -> evar_map -> bool * bool * bool -> int option -> ?name:hints_path_atom -> - constr * constr -> hint_entry + env -> evar_map -> bool * bool * bool -> int option -> polymorphic -> ?name:hints_path_atom -> + (constr * types * Univ.universe_context_set) -> hint_entry (** A constr which is Hint'ed will be: - (1) used as an Exact, if it does not start with a product @@ -155,8 +165,8 @@ val make_apply_entry : has missing arguments. *) val make_resolves : - env -> evar_map -> bool * bool * bool -> int option -> ?name:hints_path_atom -> - constr -> hint_entry list + env -> evar_map -> bool * bool * bool -> int option -> polymorphic -> ?name:hints_path_atom -> + hint_term -> hint_entry list (** [make_resolve_hyp hname htyp]. used to add an hypothesis to the local hint database; @@ -194,9 +204,9 @@ val default_search_depth : int ref val auto_unif_flags : Unification.unify_flags (** Try unification with the precompiled clause, then use registered Apply *) -val unify_resolve_nodelta : (constr * clausenv) -> tactic +val unify_resolve_nodelta : polymorphic -> (constr * clausenv) -> tactic -val unify_resolve : Unification.unify_flags -> (constr * clausenv) -> tactic +val unify_resolve : polymorphic -> Unification.unify_flags -> (constr * clausenv) -> tactic (** [ConclPattern concl pat tacast]: if the term concl matches the pattern pat, (in sense of @@ -255,7 +265,7 @@ val full_trivial : ?debug:Tacexpr.debug -> val h_trivial : ?debug:Tacexpr.debug -> open_constr list -> hint_db_name list option -> unit Proofview.tactic -val pr_autotactic : 'a auto_tactic -> Pp.std_ppcmds +val pr_autotactic : (constr * 'a) auto_tactic -> Pp.std_ppcmds (** Hook for changing the initialization of auto *) diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index ba3676145..0809c0500 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -23,6 +23,7 @@ open Locus type rew_rule = { rew_lemma: constr; rew_type: types; rew_pat: constr; + rew_ctx: Univ.universe_context_set; rew_l2r: bool; rew_tac: glob_tactic_expr option } @@ -85,18 +86,26 @@ let print_rewrite_hintdb bas = Pptactic.pr_glob_tactic (Global.env()) tac) (mt ()) h.rew_tac) (find_rewrites bas)) -type raw_rew_rule = Loc.t * constr * bool * raw_tactic_expr option +type raw_rew_rule = Loc.t * constr Univ.in_universe_context_set * bool * raw_tactic_expr option (* Applies all the rules of one base *) let one_base general_rewrite_maybe_in tac_main bas = let lrul = find_rewrites bas in + let try_rewrite dir ctx c tc = Proofview.Goal.enter (fun gl -> + let subst, ctx' = Universes.fresh_universe_context_set_instance ctx in + let c' = Vars.subst_univs_level_constr subst c in + let sigma = Proofview.Goal.sigma gl in + let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx' in + Tacticals.New.tclTHEN (Proofview.V82.tclEVARS sigma) + (general_rewrite_maybe_in dir c' tc) + ) in let lrul = List.map (fun h -> let tac = match h.rew_tac with None -> Proofview.tclUNIT () | Some t -> Tacinterp.eval_tactic t in - (h.rew_lemma,h.rew_l2r,tac)) lrul in - Tacticals.New.tclREPEAT_MAIN (Proofview.tclPROGRESS (List.fold_left (fun tac (csr,dir,tc) -> + (h.rew_ctx,h.rew_lemma,h.rew_l2r,tac)) lrul in + Tacticals.New.tclREPEAT_MAIN (Proofview.tclPROGRESS (List.fold_left (fun tac (ctx,csr,dir,tc) -> Tacticals.New.tclTHEN tac (Tacticals.New.tclREPEAT_MAIN - (Tacticals.New.tclTHENFIRST (general_rewrite_maybe_in dir csr tc) tac_main))) + (Tacticals.New.tclTHENFIRST (try_rewrite dir ctx csr tc) tac_main))) (Proofview.tclUNIT()) lrul)) (* The AutoRewrite tactic *) @@ -284,11 +293,11 @@ let add_rew_rules base lrul = let counter = ref 0 in let lrul = List.fold_left - (fun dn (loc,c,b,t) -> + (fun dn (loc,(c,ctx),b,t) -> let info = find_applied_relation false loc (Global.env ()) Evd.empty c b in let pat = if b then info.hyp_left else info.hyp_right in let rul = { rew_lemma = c; rew_type = info.hyp_ty; - rew_pat = pat; rew_l2r = b; + rew_pat = pat; rew_ctx = ctx; rew_l2r = b; rew_tac = Option.map Tacintern.glob_tactic t} in incr counter; HintDN.add pat (!counter, rul) dn) HintDN.empty lrul diff --git a/tactics/autorewrite.mli b/tactics/autorewrite.mli index 198fa36f5..046291135 100644 --- a/tactics/autorewrite.mli +++ b/tactics/autorewrite.mli @@ -11,7 +11,7 @@ open Tacexpr open Equality (** Rewriting rules before tactic interpretation *) -type raw_rew_rule = Loc.t * Term.constr * bool * Tacexpr.raw_tactic_expr option +type raw_rew_rule = Loc.t * Term.constr Univ.in_universe_context_set * bool * Tacexpr.raw_tactic_expr option (** To add rewriting rules to a base *) val add_rew_rules : string -> raw_rew_rule list -> unit @@ -27,6 +27,7 @@ val autorewrite_in : ?conds:conditions -> Names.Id.t -> unit Proofview.tactic -> type rew_rule = { rew_lemma: constr; rew_type: types; rew_pat: constr; + rew_ctx: Univ.universe_context_set; rew_l2r: bool; rew_tac: glob_tactic_expr option } diff --git a/tactics/btermdn.ml b/tactics/btermdn.ml index 9492ae1a0..df8e98604 100644 --- a/tactics/btermdn.ml +++ b/tactics/btermdn.ml @@ -48,8 +48,8 @@ let decomp = let constr_val_discr t = let c, l = decomp t in match kind_of_term c with - | Ind ind_sp -> Label(GRLabel (IndRef ind_sp),l) - | Construct cstr_sp -> Label(GRLabel (ConstructRef cstr_sp),l) + | Ind (ind_sp,u) -> Label(GRLabel (IndRef ind_sp),l) + | Construct (cstr_sp,u) -> Label(GRLabel (ConstructRef cstr_sp),l) | Var id -> Label(GRLabel (VarRef id),l) | Const _ -> Everything | _ -> Nothing @@ -67,9 +67,9 @@ let constr_pat_discr t = let constr_val_discr_st (idpred,cpred) t = let c, l = decomp t in match kind_of_term c with - | Const c -> if Cpred.mem c cpred then Everything else Label(GRLabel (ConstRef c),l) - | Ind ind_sp -> Label(GRLabel (IndRef ind_sp),l) - | Construct cstr_sp -> Label(GRLabel (ConstructRef cstr_sp),l) + | Const (c,u) -> if Cpred.mem c cpred then Everything else Label(GRLabel (ConstRef c),l) + | Ind (ind_sp,u) -> Label(GRLabel (IndRef ind_sp),l) + | Construct (cstr_sp,u) -> Label(GRLabel (ConstructRef cstr_sp),l) | Var id when not (Id.Pred.mem id idpred) -> Label(GRLabel (VarRef id),l) | Prod (n, d, c) -> Label(ProdLabel, [d; c]) | Lambda (n, d, c) -> Label(LambdaLabel, [d; c] @ l) @@ -141,6 +141,77 @@ struct let create = Dn.create +(* FIXME: MS: remove *) +(* let decomp = + let rec decrec acc c = match kind_of_term c with + | App (f,l) -> decrec (Array.fold_right (fun a l -> a::l) l acc) f + | Proj (p,c) -> decrec (c :: acc) (mkConst p) + | Cast (c1,_,_) -> decrec acc c1 + | _ -> (c,acc) + in + decrec [] + + let constr_val_discr t = + let c, l = decomp t in + match kind_of_term c with + | Ind (ind_sp,_) -> Dn.Label(Term_dn.GRLabel (IndRef ind_sp),l) + | Construct (cstr_sp,_) -> Dn.Label(Term_dn.GRLabel (ConstructRef cstr_sp),l) + | Var id -> Dn.Label(Term_dn.GRLabel (VarRef id),l) + | Const _ -> Dn.Everything + | Proj (p, c) -> Dn.Everything + | _ -> Dn.Nothing + + let constr_val_discr_st (idpred,cpred) t = + let c, l = decomp t in + match kind_of_term c with + | Const (c,_) -> if Cpred.mem c cpred then Dn.Everything else Dn.Label(Term_dn.GRLabel (ConstRef c),l) + | Ind (ind_sp,_) -> Dn.Label(Term_dn.GRLabel (IndRef ind_sp),l) + | Construct (cstr_sp,_) -> Dn.Label(Term_dn.GRLabel (ConstructRef cstr_sp),l) + | Proj (p,c) -> + if Cpred.mem p cpred then Dn.Everything else Dn.Label(Term_dn.GRLabel (ConstRef p), c::l) + | Var id when not (Id.Pred.mem id idpred) -> Dn.Label(Term_dn.GRLabel (VarRef id),l) + | Prod (n, d, c) -> Dn.Label(Term_dn.ProdLabel, [d; c]) + | Lambda (n, d, c) -> Dn.Label(Term_dn.LambdaLabel, [d; c] @ l) + | Sort _ -> Dn.Label(Term_dn.SortLabel, []) + | Evar _ -> Dn.Everything + | _ -> Dn.Nothing + + let bounded_constr_pat_discr_st st (t,depth) = + if Int.equal depth 0 then + None + else + match Term_dn.constr_pat_discr_st st t with + | None -> None + | Some (c,l) -> Some(c,List.map (fun c -> (c,depth-1)) l) + + let bounded_constr_val_discr_st st (t,depth) = + if Int.equal depth 0 then + Dn.Nothing + else + match constr_val_discr_st st t with + | Dn.Label (c,l) -> Dn.Label(c,List.map (fun c -> (c,depth-1)) l) + | Dn.Nothing -> Dn.Nothing + | Dn.Everything -> Dn.Everything + + let bounded_constr_pat_discr (t,depth) = + if Int.equal depth 0 then + None + else + match Term_dn.constr_pat_discr t with + | None -> None + | Some (c,l) -> Some(c,List.map (fun c -> (c,depth-1)) l) + + let bounded_constr_val_discr (t,depth) = + if Int.equal depth 0 then + Dn.Nothing + else + match constr_val_discr t with + | Dn.Label (c,l) -> Dn.Label(c,List.map (fun c -> (c,depth-1)) l) + | Dn.Nothing -> Dn.Nothing + | Dn.Everything -> Dn.Everything + +*) + let add = function | None -> (fun dn (c,v) -> diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index 6d7c797af..02e671a5c 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -50,7 +50,7 @@ let evars_to_goals p evm = open Auto -let e_give_exact flags c gl = +let e_give_exact flags (c,cl) gl = let t1 = (pf_type_of gl c) in tclTHEN (Clenvtac.unify ~flags t1) (exact_no_check c) gl @@ -91,15 +91,17 @@ let progress_evars t = in t <*> check end -let unify_e_resolve flags (c,clenv) gls = - let clenv' = connect_clenv gls clenv in +let unify_e_resolve poly flags (c,clenv) gls = + let clenv' = if poly then fst (Clenv.refresh_undefined_univs clenv) else clenv in + let clenv' = connect_clenv gls clenv' in let clenv' = clenv_unique_resolver ~flags clenv' gls in Clenvtac.clenv_refine true ~with_classes:false clenv' gls -let unify_resolve flags (c,clenv) gls = - let clenv' = connect_clenv gls clenv in +let unify_resolve poly flags (c,clenv) gls = + let clenv' = if poly then fst (Clenv.refresh_undefined_univs clenv) else clenv in + let clenv' = connect_clenv gls clenv' in let clenv' = clenv_unique_resolver ~flags clenv' gls in - Clenvtac.clenv_refine false ~with_classes:false clenv' gls + Clenvtac.clenv_refine false(*uhoh, was true*) ~with_classes:false clenv' gls let clenv_of_prods nprods (c, clenv) gls = if Int.equal nprods 0 then Some clenv @@ -107,6 +109,7 @@ let clenv_of_prods nprods (c, clenv) gls = let ty = pf_type_of gls c in let diff = nb_prod ty - nprods in if Pervasives.(>=) diff 0 then + (* Was Some clenv... *) Some (mk_clenv_from_n gls (Some diff) (c,ty)) else None @@ -152,14 +155,14 @@ and e_my_find_search db_list local_db hdc complete concl = (local_db::db_list) in let tac_of_hint = - fun (flags, {pri = b; pat = p; code = t; name = name}) -> + fun (flags, {pri = b; pat = p; poly = poly; code = t; name = name}) -> let tac = match t with - | Res_pf (term,cl) -> with_prods nprods (term,cl) (unify_resolve flags) - | ERes_pf (term,cl) -> with_prods nprods (term,cl) (unify_e_resolve flags) - | Give_exact (c) -> e_give_exact flags c + | Res_pf (term,cl) -> with_prods nprods (term,cl) (unify_resolve poly flags) + | ERes_pf (term,cl) -> with_prods nprods (term,cl) (unify_e_resolve poly flags) + | Give_exact c -> e_give_exact flags c | Res_pf_THEN_trivial_fail (term,cl) -> - tclTHEN (with_prods nprods (term,cl) (unify_e_resolve flags)) + tclTHEN (with_prods nprods (term,cl) (unify_e_resolve poly flags)) (if complete then tclIDTAC else e_trivial_fail_db db_list local_db) | Unfold_nth c -> tclWEAK_PROGRESS (unfold_in_concl [AllOccurrences,c]) | Extern tacast -> @@ -178,13 +181,13 @@ and e_my_find_search db_list local_db hdc complete concl = and e_trivial_resolve db_list local_db gl = try e_my_find_search db_list local_db - (fst (head_constr_bound gl)) true gl + (head_constr_bound gl) true gl with Bound | Not_found -> [] let e_possible_resolve db_list local_db gl = try e_my_find_search db_list local_db - (fst (head_constr_bound gl)) false gl + (head_constr_bound gl) false gl with Bound | Not_found -> [] let catchable = function @@ -223,8 +226,8 @@ let make_resolve_hyp env sigma st flags only_classes pri (id, _, cty) = let rec iscl env ty = let ctx, ar = decompose_prod_assum ty in match kind_of_term (fst (decompose_app ar)) with - | Const c -> is_class (ConstRef c) - | Ind i -> is_class (IndRef i) + | Const (c,_) -> is_class (ConstRef c) + | Ind (i,_) -> is_class (IndRef i) | _ -> let env' = Environ.push_rel_context ctx env in let ty' = whd_betadeltaiota env' ar in @@ -241,13 +244,16 @@ let make_resolve_hyp env sigma st flags only_classes pri (id, _, cty) = let hints = build_subclasses ~check:false env sigma (VarRef id) None in (List.map_append (fun (path,pri, c) -> make_resolves env sigma ~name:(PathHints path) - (true,false,Flags.is_verbose()) pri c) + (true,false,Flags.is_verbose()) pri false + (IsConstr (c,Univ.ContextSet.empty))) hints) else [] in (hints @ List.map_filter - (fun f -> try Some (f (c, cty)) with Failure _ | UserError _ -> None) - [make_exact_entry ~name sigma pri; make_apply_entry ~name env sigma flags pri]) + (fun f -> try Some (f (c, cty, Univ.ContextSet.empty)) + with Failure _ | UserError _ -> None) + [make_exact_entry ~name env sigma pri false; + make_apply_entry ~name env sigma flags pri false]) else [] let pf_filtered_hyps gls = @@ -266,21 +272,19 @@ let make_hints g st only_classes sign = (PathEmpty, []) sign in Hint_db.add_list hintlist (Hint_db.empty st true) -let autogoal_hints_cache - : (bool * Environ.named_context_val * hint_db) option ref - = Summary.ref None ~name:"autogoal-hints-cache" -let freeze () = !autogoal_hints_cache -let unfreeze v = autogoal_hints_cache := v - let make_autogoal_hints = - fun only_classes ?(st=full_transparent_state) g -> - let sign = pf_filtered_hyps g in - match freeze () with - | Some (onlyc, sign', hints) - when (onlyc : bool) == only_classes && - Environ.eq_named_context_val sign sign' -> hints - | _ -> let hints = make_hints g st only_classes (Environ.named_context_of_val sign) in - unfreeze (Some (only_classes, sign, hints)); hints + let cache = ref (true, Environ.empty_named_context_val, + Hint_db.empty full_transparent_state true) + in + fun only_classes ?(st=full_transparent_state) g -> + let sign = pf_filtered_hyps g in + let (onlyc, sign', cached_hints) = !cache in + if onlyc == only_classes && + (sign == sign' || Environ.eq_named_context_val sign sign') then + cached_hints + else + let hints = make_hints g st only_classes (Environ.named_context_of_val sign) in + cache := (only_classes, sign, hints); hints let lift_tactic tac (f : goal list sigma -> autoinfo -> autogoal list sigma) : 'a tac = { skft = fun sk fk {it = gl,hints; sigma=s;} -> @@ -467,7 +471,8 @@ let run_on_evars ?(only_classes=true) ?(st=full_transparent_state) p evm hints t let res = run_list_tac tac p goals (make_autogoals ~only_classes ~st hints goals evm') in match get_result res with | None -> raise Not_found - | Some (evm', fk) -> Some (evars_reset_evd ~with_conv_pbs:true evm' evm, fk) + | Some (evm', fk) -> + Some (evars_reset_evd ~with_conv_pbs:true ~with_univs:false evm' evm, fk) let eauto_tac hints = then_tac normevars_tac (or_tac (hints_tac hints) intro_tac) @@ -743,4 +748,4 @@ let autoapply c i gl = let flags = flags_of_state (Auto.Hint_db.transparent_state (Auto.searchtable_map i)) in let cty = pf_type_of gl c in let ce = mk_clenv_from gl (c,cty) in - unify_e_resolve flags (c,ce) gl + unify_e_resolve false flags (c,ce) gl diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml index f245247a9..faeb9fc25 100644 --- a/tactics/contradiction.ml +++ b/tactics/contradiction.ml @@ -34,6 +34,7 @@ let absurd c gls = exact_no_check (mkApp(mkVar idna,[|mkVar ida|])) gl))); tclIDTAC])); tclIDTAC])) { gls with Evd.sigma; } + let absurd c = Proofview.V82.tactic (absurd c) (* Contradiction *) diff --git a/tactics/eauto.ml4 b/tactics/eauto.ml4 index 0ab426cd2..328d45991 100644 --- a/tactics/eauto.ml4 +++ b/tactics/eauto.ml4 @@ -32,7 +32,7 @@ let eauto_unif_flags = { auto_unif_flags with Unification.modulo_delta = full_tr let e_give_exact ?(flags=eauto_unif_flags) c gl = let t1 = (pf_type_of gl c) and t2 = pf_concl gl in if occur_existential t1 || occur_existential t2 then - tclTHEN (Clenvtac.unify ~flags t1) (exact_check c) gl + tclTHEN (Clenvtac.unify ~flags t1) (exact_no_check c) gl else exact_check c gl let assumption id = e_give_exact (mkVar id) @@ -86,8 +86,12 @@ let rec prolog l n gl = let prol = (prolog l (n-1)) in (tclFIRST (List.map (fun t -> (tclTHEN t prol)) (one_step l gl))) gl +let out_term = function + | IsConstr (c, _) -> c + | IsGlobRef gr -> fst (Universes.fresh_global_instance (Global.env ()) gr) + let prolog_tac l n gl = - let l = List.map (prepare_hint (pf_env gl)) l in + let l = List.map (fun x -> out_term (pf_apply (prepare_hint false) gl x)) l in let n = match n with | ArgArg n -> n @@ -110,11 +114,19 @@ open Unification let priority l = List.map snd (List.filter (fun (pr,_) -> Int.equal pr 0) l) -let unify_e_resolve flags (c,clenv) gls = - let clenv' = connect_clenv gls clenv in +let unify_e_resolve poly flags (c,clenv) gls = + let clenv', subst = if poly then Clenv.refresh_undefined_univs clenv + else clenv, Univ.empty_level_subst in + let clenv' = connect_clenv gls clenv' in let _ = clenv_unique_resolver ~flags clenv' gls in - Tactics.Simple.eapply c gls - + Tactics.Simple.eapply (Vars.subst_univs_level_constr subst c) gls + +let e_exact poly flags (c,clenv) = + let clenv', subst = + if poly then Clenv.refresh_undefined_univs clenv + else clenv, Univ.empty_level_subst + in e_give_exact ~flags (Vars.subst_univs_level_constr subst c) + let rec e_trivial_fail_db db_list local_db goal = let tacl = registered_e_assumption :: @@ -141,15 +153,15 @@ and e_my_find_search db_list local_db hdc concl = List.map (fun x -> flags, x) (Hint_db.map_auto (hdc,concl) db)) (local_db::db_list) in let tac_of_hint = - fun (st, {pri=b; pat = p; code=t}) -> + fun (st, {pri = b; pat = p; code = t; poly = poly}) -> (b, let tac = match t with - | Res_pf (term,cl) -> unify_resolve st (term,cl) - | ERes_pf (term,cl) -> unify_e_resolve st (term,cl) - | Give_exact (c) -> e_give_exact c + | Res_pf (term,cl) -> unify_resolve poly st (term,cl) + | ERes_pf (term,cl) -> unify_e_resolve poly st (term,cl) + | Give_exact (c,cl) -> e_exact poly st (c,cl) | Res_pf_THEN_trivial_fail (term,cl) -> - tclTHEN (unify_e_resolve st (term,cl)) + tclTHEN (unify_e_resolve poly st (term,cl)) (e_trivial_fail_db db_list local_db) | Unfold_nth c -> reduce (Unfold [AllOccurrences,c]) onConcl | Extern tacast -> Proofview.V82.of_tactic (conclPattern concl p tacast) @@ -162,13 +174,13 @@ and e_trivial_resolve db_list local_db gl = try priority (e_my_find_search db_list local_db - (fst (head_constr_bound gl)) gl) + (head_constr_bound gl) gl) with Bound | Not_found -> [] let e_possible_resolve db_list local_db gl = try List.map snd (e_my_find_search db_list local_db - (fst (head_constr_bound gl)) gl) + (head_constr_bound gl) gl) with Bound | Not_found -> [] let find_first_goal gls = @@ -363,6 +375,9 @@ let e_search_auto debug (in_depth,p) lems db_list gl = pr_info_nop d; error "eauto: search failed" +(* let e_search_auto_key = Profile.declare_profile "e_search_auto" *) +(* let e_search_auto = Profile.profile5 e_search_auto_key e_search_auto *) + let eauto_with_bases ?(debug=Off) np lems db_list = tclTRY (e_search_auto debug np lems db_list) @@ -494,8 +509,8 @@ let unfold_head env (ids, csts) c = (match Environ.named_body id env with | Some b -> true, b | None -> false, c) - | Const cst when Cset.mem cst csts -> - true, Environ.constant_value env cst + | Const (cst,u as c) when Cset.mem cst csts -> + true, Environ.constant_value_in env c | App (f, args) -> (match aux f with | true, f' -> true, Reductionops.whd_betaiota Evd.empty (mkApp (f', args)) @@ -558,7 +573,7 @@ TACTIC EXTEND autounfoldify | [ "autounfoldify" constr(x) ] -> [ Proofview.V82.tactic ( let db = match kind_of_term x with - | Const c -> Label.to_string (con_label c) + | Const (c,_) -> Label.to_string (con_label c) | _ -> assert false in autounfold ["core";db] onConcl )] diff --git a/tactics/elim.ml b/tactics/elim.ml index 0720273bb..2a7b3bff1 100644 --- a/tactics/elim.ml +++ b/tactics/elim.ml @@ -104,12 +104,12 @@ let head_in indl t gl = if !up_to_delta then find_mrectype env sigma t else extract_mrectype t - in List.exists (fun i -> eq_ind i ity) indl + in List.exists (fun i -> eq_ind (fst i) (fst ity)) indl with Not_found -> false let decompose_these c l = Proofview.Goal.raw_enter begin fun gl -> - let indl = (*List.map inductive_of*) l in + let indl = List.map (fun x -> x, Univ.Instance.empty) l in general_decompose (fun (_,t) -> head_in indl t gl) c end diff --git a/tactics/elimschemes.ml b/tactics/elimschemes.ml index 9c020930c..617475bb7 100644 --- a/tactics/elimschemes.ml +++ b/tactics/elimschemes.ml @@ -23,13 +23,16 @@ open Ind_tables (* Induction/recursion schemes *) let optimize_non_type_induction_scheme kind dep sort ind = + let env = Global.env () in + let sigma = Evd.from_env env in if check_scheme kind ind then (* in case the inductive has a type elimination, generates only one induction scheme, the other ones share the same code with the apropriate type *) let cte, eff = find_scheme kind ind in - let c = mkConst cte in - let t = type_of_constant (Global.env()) cte in + let sigma, cte = Evd.fresh_constant_instance env sigma cte in + let c = mkConstU cte in + let t = type_of_constant_in (Global.env()) cte in let (mib,mip) = Global.lookup_inductive ind in let npars = (* if a constructor of [ind] contains a recursive call, the scheme @@ -39,13 +42,29 @@ let optimize_non_type_induction_scheme kind dep sort ind = mib.mind_nparams_rec else mib.mind_nparams in - snd (weaken_sort_scheme (new_sort_in_family sort) npars c t), eff + let sigma, sort = Evd.fresh_sort_in_family env sigma sort in + let sigma, t', c' = weaken_sort_scheme env sigma false sort npars c t in + let sigma, nf = Evarutil.nf_evars_and_universes sigma in + (nf c', Evd.evar_universe_context sigma), eff else - build_induction_scheme (Global.env()) Evd.empty ind dep sort, Declareops.no_seff + let mib,mip = Inductive.lookup_mind_specif env ind in + let ctx = if mib.mind_polymorphic then mib.mind_universes else Univ.UContext.empty in + let u = Univ.UContext.instance ctx in + let ctxset = Univ.ContextSet.of_context ctx in + let sigma, c = build_induction_scheme env (Evd.from_env ~ctx:ctxset env) (ind,u) dep sort in + (c, Evd.evar_universe_context sigma), Declareops.no_seff let build_induction_scheme_in_type dep sort ind = - build_induction_scheme (Global.env()) Evd.empty ind dep sort - + let env = Global.env () in + let ctx = + let mib,mip = Inductive.lookup_mind_specif env ind in + Inductive.inductive_context mib + in + let u = Univ.UContext.instance ctx in + let ctxset = Univ.ContextSet.of_context ctx in + let sigma, c = build_induction_scheme env (Evd.from_env ~ctx:ctxset env) (ind,u) dep sort in + c, Evd.evar_universe_context sigma + let rect_scheme_kind_from_type = declare_individual_scheme_object "_rect_nodep" (fun x -> build_induction_scheme_in_type false InType x, Declareops.no_seff) @@ -81,7 +100,11 @@ let rec_dep_scheme_kind_from_type = (* Case analysis *) let build_case_analysis_scheme_in_type dep sort ind = - build_case_analysis_scheme (Global.env()) Evd.empty ind dep sort + let env = Global.env () in + let sigma = Evd.from_env env in + let sigma, indu = Evd.fresh_inductive_instance env sigma ind in + let sigma, c = build_case_analysis_scheme env sigma indu dep sort in + c, Evd.evar_universe_context sigma let case_scheme_kind_from_type = declare_individual_scheme_object "_case_nodep" diff --git a/tactics/eqdecide.ml b/tactics/eqdecide.ml index 23c4c0b2d..7909b669b 100644 --- a/tactics/eqdecide.ml +++ b/tactics/eqdecide.ml @@ -80,8 +80,13 @@ let solveNoteqBranch side = (* Constructs the type {c1=c2}+{~c1=c2} *) +let make_eq () = +(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq ()) +let make_eq_refl () = +(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq_refl ()) + let mkDecideEqGoal eqonleft op rectype c1 c2 = - let equality = mkApp(build_coq_eq(), [|rectype; c1; c2|]) in + let equality = mkApp(make_eq(), [|rectype; c1; c2|]) in let disequality = mkApp(build_coq_not (), [|equality|]) in if eqonleft then mkApp(op, [|equality; disequality |]) else mkApp(op, [|disequality; equality |]) @@ -173,7 +178,7 @@ let decideGralEquality = match_eqdec concl >>= fun (eqonleft,_,c1,c2,typ) -> let headtyp = hd_app (pf_compute gl typ) in begin match kind_of_term headtyp with - | Ind mi -> Proofview.tclUNIT mi + | Ind (mi,_) -> Proofview.tclUNIT mi | _ -> tclZEROMSG (Pp.str"This decision procedure only works for inductive objects.") end >>= fun rectype -> (tclTHEN diff --git a/tactics/eqschemes.ml b/tactics/eqschemes.ml index 7aac37d1b..08c887b77 100644 --- a/tactics/eqschemes.ml +++ b/tactics/eqschemes.ml @@ -63,11 +63,13 @@ let hid = Id.of_string "H" let xid = Id.of_string "X" let default_id_of_sort = function InProp | InSet -> hid | InType -> xid let fresh env id = next_global_ident_away id [] +let with_context_set ctx (b, ctx') = + (b, Univ.ContextSet.union ctx ctx') let build_dependent_inductive ind (mib,mip) = let realargs,_ = List.chop mip.mind_nrealargs_ctxt mip.mind_arity_ctxt in applist - (mkInd ind, + (mkIndU ind, extended_rel_list mip.mind_nrealargs_ctxt mib.mind_params_ctxt @ extended_rel_list 0 realargs) @@ -76,12 +78,13 @@ let my_it_mkProd_or_LetIn s c = it_mkProd_or_LetIn c s let my_it_mkLambda_or_LetIn_name s c = it_mkLambda_or_LetIn_name (Global.env()) c s -let get_coq_eq () = +let get_coq_eq ctx = try let eq = Globnames.destIndRef Coqlib.glob_eq in - let _ = Global.lookup_inductive eq in (* Do not force the lazy if they are not defined *) - mkInd eq, Coqlib.build_coq_eq_refl () + let eq, ctx = with_context_set ctx + (Universes.fresh_inductive_instance (Global.env ()) eq) in + mkIndU eq, mkConstructUi (eq,1), ctx with Not_found -> error "eq not found." @@ -94,12 +97,14 @@ let get_coq_eq () = (* in which case, a symmetry lemma is definable *) (**********************************************************************) -let get_sym_eq_data env ind = +let get_sym_eq_data env (ind,u) = let (mib,mip as specif) = lookup_mind_specif env ind in if not (Int.equal (Array.length mib.mind_packets) 1) || not (Int.equal (Array.length mip.mind_nf_lc) 1) then error "Not an inductive type with a single constructor."; - let realsign,_ = List.chop mip.mind_nrealargs_ctxt mip.mind_arity_ctxt in + let subst = Inductive.make_inductive_subst mib u in + let arityctxt = Vars.subst_univs_context subst mip.mind_arity_ctxt in + let realsign,_ = List.chop mip.mind_nrealargs_ctxt arityctxt in if List.exists (fun (_,b,_) -> not (Option.is_empty b)) realsign then error "Inductive equalities with local definitions in arity not supported."; let constrsign,ccl = decompose_prod_assum mip.mind_nf_lc.(0) in @@ -110,12 +115,13 @@ let get_sym_eq_data env ind = if mip.mind_nrealargs > mib.mind_nparams then error "Constructors arguments must repeat the parameters."; let _,params2 = List.chop (mib.mind_nparams-mip.mind_nrealargs) params in + let paramsctxt = Vars.subst_univs_context subst mib.mind_params_ctxt in let paramsctxt1,_ = - List.chop (mib.mind_nparams-mip.mind_nrealargs) mib.mind_params_ctxt in + List.chop (mib.mind_nparams-mip.mind_nrealargs) paramsctxt in if not (List.equal eq_constr params2 constrargs) then error "Constructors arguments must repeat the parameters."; (* nrealargs_ctxt and nrealargs are the same here *) - (specif,mip.mind_nrealargs,realsign,mib.mind_params_ctxt,paramsctxt1) + (specif,mip.mind_nrealargs,realsign,paramsctxt,paramsctxt1) (**********************************************************************) (* Check if an inductive type [ind] has the form *) @@ -127,12 +133,14 @@ let get_sym_eq_data env ind = (* such that symmetry is a priori definable *) (**********************************************************************) -let get_non_sym_eq_data env ind = +let get_non_sym_eq_data env (ind,u) = let (mib,mip as specif) = lookup_mind_specif env ind in if not (Int.equal (Array.length mib.mind_packets) 1) || not (Int.equal (Array.length mip.mind_nf_lc) 1) then error "Not an inductive type with a single constructor."; - let realsign,_ = List.chop mip.mind_nrealargs_ctxt mip.mind_arity_ctxt in + let subst = Inductive.make_inductive_subst mib u in + let arityctxt = Vars.subst_univs_context subst mip.mind_arity_ctxt in + let realsign,_ = List.chop mip.mind_nrealargs_ctxt arityctxt in if List.exists (fun (_,b,_) -> not (Option.is_empty b)) realsign then error "Inductive equalities with local definitions in arity not supported"; let constrsign,ccl = decompose_prod_assum mip.mind_nf_lc.(0) in @@ -140,7 +148,9 @@ let get_non_sym_eq_data env ind = if not (Int.equal (rel_context_length constrsign) (rel_context_length mib.mind_params_ctxt)) then error "Constructor must have no arguments"; let _,constrargs = List.chop mib.mind_nparams constrargs in - (specif,constrargs,realsign,mip.mind_nrealargs) + let constrargs = List.map (Vars.subst_univs_constr subst) constrargs in + let paramsctxt = Vars.subst_univs_context subst mib.mind_params_ctxt in + (specif,constrargs,realsign,paramsctxt,mip.mind_nrealargs) (**********************************************************************) (* Build the symmetry lemma associated to an inductive type *) @@ -157,30 +167,35 @@ let get_non_sym_eq_data env ind = (**********************************************************************) let build_sym_scheme env ind = + let (ind,u as indu), ctx = Universes.fresh_inductive_instance env ind in let (mib,mip as specif),nrealargs,realsign,paramsctxt,paramsctxt1 = - get_sym_eq_data env ind in + get_sym_eq_data env indu in let cstr n = - mkApp (mkConstruct(ind,1),extended_rel_vect n mib.mind_params_ctxt) in + mkApp (mkConstructUi(indu,1),extended_rel_vect n mib.mind_params_ctxt) in let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in - let applied_ind = build_dependent_inductive ind specif in + let applied_ind = build_dependent_inductive indu specif in let realsign_ind = name_context env ((Name varH,None,applied_ind)::realsign) in let ci = make_case_info (Global.env()) ind RegularStyle in + let c = (my_it_mkLambda_or_LetIn mib.mind_params_ctxt (my_it_mkLambda_or_LetIn_name realsign_ind (mkCase (ci, my_it_mkLambda_or_LetIn_name (lift_rel_context (nrealargs+1) realsign_ind) - (mkApp (mkInd ind,Array.concat + (mkApp (mkIndU indu,Array.concat [extended_rel_vect (3*nrealargs+2) paramsctxt1; rel_vect 1 nrealargs; rel_vect (2*nrealargs+2) nrealargs])), mkRel 1 (* varH *), [|cstr (nrealargs+1)|])))) + in c, Evd.evar_universe_context_of ctx let sym_scheme_kind = declare_individual_scheme_object "_sym_internal" - (fun ind -> build_sym_scheme (Global.env() (* side-effect! *)) ind, Declareops.no_seff) + (fun ind -> + let c, ctx = build_sym_scheme (Global.env() (* side-effect! *)) ind in + (c, ctx), Declareops.no_seff) (**********************************************************************) (* Build the involutivity of symmetry for an inductive type *) @@ -198,51 +213,59 @@ let sym_scheme_kind = (* *) (**********************************************************************) +let const_of_scheme kind env ind ctx = + let sym_scheme, eff = (find_scheme kind ind) in + let sym, ctx = with_context_set ctx + (Universes.fresh_constant_instance (Global.env()) sym_scheme) in + mkConstU sym, ctx, eff + let build_sym_involutive_scheme env ind = + let (ind,u as indu), ctx = Universes.fresh_inductive_instance env ind in let (mib,mip as specif),nrealargs,realsign,paramsctxt,paramsctxt1 = - get_sym_eq_data env ind in - let c, eff = find_scheme sym_scheme_kind ind in - let sym = mkConst c in - let (eq,eqrefl) = get_coq_eq () in - let cstr n = mkApp (mkConstruct(ind,1),extended_rel_vect n paramsctxt) in + get_sym_eq_data env indu in + let eq,eqrefl,ctx = get_coq_eq ctx in + let sym, ctx, eff = const_of_scheme sym_scheme_kind env ind ctx in + let cstr n = mkApp (mkConstructUi (indu,1),extended_rel_vect n paramsctxt) in let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in - let applied_ind = build_dependent_inductive ind specif in + let applied_ind = build_dependent_inductive indu specif in let applied_ind_C = mkApp - (mkInd ind, Array.append + (mkIndU indu, Array.append (extended_rel_vect (nrealargs+1) mib.mind_params_ctxt) (rel_vect (nrealargs+1) nrealargs)) in let realsign_ind = name_context env ((Name varH,None,applied_ind)::realsign) in let ci = make_case_info (Global.env()) ind RegularStyle in - (my_it_mkLambda_or_LetIn paramsctxt - (my_it_mkLambda_or_LetIn_name realsign_ind - (mkCase (ci, - my_it_mkLambda_or_LetIn_name - (lift_rel_context (nrealargs+1) realsign_ind) - (mkApp (eq,[| - mkApp - (mkInd ind, Array.concat - [extended_rel_vect (3*nrealargs+2) paramsctxt1; - rel_vect (2*nrealargs+2) nrealargs; - rel_vect 1 nrealargs]); - mkApp (sym,Array.concat - [extended_rel_vect (3*nrealargs+2) paramsctxt1; - rel_vect 1 nrealargs; - rel_vect (2*nrealargs+2) nrealargs; - [|mkApp (sym,Array.concat - [extended_rel_vect (3*nrealargs+2) paramsctxt1; - rel_vect (2*nrealargs+2) nrealargs; - rel_vect 1 nrealargs; - [|mkRel 1|]])|]]); - mkRel 1|])), - mkRel 1 (* varH *), - [|mkApp(eqrefl,[|applied_ind_C;cstr (nrealargs+1)|])|])))), - eff + let c = + (my_it_mkLambda_or_LetIn paramsctxt + (my_it_mkLambda_or_LetIn_name realsign_ind + (mkCase (ci, + my_it_mkLambda_or_LetIn_name + (lift_rel_context (nrealargs+1) realsign_ind) + (mkApp (eq,[| + mkApp + (mkIndU indu, Array.concat + [extended_rel_vect (3*nrealargs+2) paramsctxt1; + rel_vect (2*nrealargs+2) nrealargs; + rel_vect 1 nrealargs]); + mkApp (sym,Array.concat + [extended_rel_vect (3*nrealargs+2) paramsctxt1; + rel_vect 1 nrealargs; + rel_vect (2*nrealargs+2) nrealargs; + [|mkApp (sym,Array.concat + [extended_rel_vect (3*nrealargs+2) paramsctxt1; + rel_vect (2*nrealargs+2) nrealargs; + rel_vect 1 nrealargs; + [|mkRel 1|]])|]]); + mkRel 1|])), + mkRel 1 (* varH *), + [|mkApp(eqrefl,[|applied_ind_C;cstr (nrealargs+1)|])|])))) + in (c, Evd.evar_universe_context_of ctx), eff let sym_involutive_scheme_kind = declare_individual_scheme_object "_sym_involutive" - (fun ind -> build_sym_involutive_scheme (Global.env() (* side-effect! *)) ind) + (fun ind -> + build_sym_involutive_scheme (Global.env() (* side-effect! *)) ind) (**********************************************************************) (* Build the left-to-right rewriting lemma for conclusion associated *) @@ -305,28 +328,27 @@ let sym_involutive_scheme_kind = (**********************************************************************) let build_l2r_rew_scheme dep env ind kind = + let (ind,u as indu), ctx = Universes.fresh_inductive_instance env ind in let (mib,mip as specif),nrealargs,realsign,paramsctxt,paramsctxt1 = - get_sym_eq_data env ind in - let c, eff = find_scheme sym_scheme_kind ind in - let sym = mkConst c in - let c, eff' = find_scheme sym_involutive_scheme_kind ind in - let sym_involutive = mkConst c in - let (eq,eqrefl) = get_coq_eq () in + get_sym_eq_data env indu in + let sym, ctx, eff = const_of_scheme sym_scheme_kind env ind ctx in + let sym_involutive, ctx, eff' = const_of_scheme sym_involutive_scheme_kind env ind ctx in + let eq,eqrefl,ctx = get_coq_eq ctx in let cstr n p = - mkApp (mkConstruct(ind,1), + mkApp (mkConstructUi(indu,1), Array.concat [extended_rel_vect n paramsctxt1; rel_vect p nrealargs]) in let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in let varHC = fresh env (Id.of_string "HC") in let varP = fresh env (Id.of_string "P") in - let applied_ind = build_dependent_inductive ind specif in + let applied_ind = build_dependent_inductive indu specif in let applied_ind_P = - mkApp (mkInd ind, Array.concat + mkApp (mkIndU indu, Array.concat [extended_rel_vect (3*nrealargs) paramsctxt1; rel_vect 0 nrealargs; rel_vect nrealargs nrealargs]) in let applied_ind_G = - mkApp (mkInd ind, Array.concat + mkApp (mkIndU indu, Array.concat [extended_rel_vect (3*nrealargs+3) paramsctxt1; rel_vect (nrealargs+3) nrealargs; rel_vect 0 nrealargs]) in @@ -345,9 +367,11 @@ let build_l2r_rew_scheme dep env ind kind = rel_vect (nrealargs+4) nrealargs; rel_vect 1 nrealargs; [|mkRel 1|]]) in - let s = mkSort (new_sort_in_family kind) in + let s, ctx' = Universes.fresh_sort_in_family (Global.env ()) kind in + let ctx = Univ.ContextSet.union ctx ctx' in + let s = mkSort s in let ci = make_case_info (Global.env()) ind RegularStyle in - let cieq = make_case_info (Global.env()) (destInd eq) RegularStyle in + let cieq = make_case_info (Global.env()) (fst (destInd eq)) RegularStyle in let applied_PC = mkApp (mkVar varP,Array.append (extended_rel_vect 1 realsign) (if dep then [|cstr (2*nrealargs+1) 1|] else [||])) in @@ -372,6 +396,7 @@ let build_l2r_rew_scheme dep env ind kind = my_it_mkLambda_or_LetIn_name realsign_ind_G applied_PG, applied_sym_C 3, [|mkVar varHC|]) in + let c = (my_it_mkLambda_or_LetIn mib.mind_params_ctxt (my_it_mkLambda_or_LetIn_name realsign (mkNamedLambda varP @@ -388,8 +413,8 @@ let build_l2r_rew_scheme dep env ind kind = Array.append (extended_rel_vect 3 mip.mind_arity_ctxt) [|mkVar varH|]), [|main_body|]) else - main_body)))))), - Declareops.union_side_effects eff' eff + main_body)))))) + in (c, Evd.evar_universe_context_of ctx), Declareops.union_side_effects eff' eff (**********************************************************************) (* Build the left-to-right rewriting lemma for hypotheses associated *) @@ -418,23 +443,24 @@ let build_l2r_rew_scheme dep env ind kind = (**********************************************************************) let build_l2r_forward_rew_scheme dep env ind kind = + let (ind,u as indu), ctx = Universes.fresh_inductive_instance env ind in let (mib,mip as specif),nrealargs,realsign,paramsctxt,paramsctxt1 = - get_sym_eq_data env ind in + get_sym_eq_data env indu in let cstr n p = - mkApp (mkConstruct(ind,1), + mkApp (mkConstructUi(indu,1), Array.concat [extended_rel_vect n paramsctxt1; rel_vect p nrealargs]) in let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in let varHC = fresh env (Id.of_string "HC") in let varP = fresh env (Id.of_string "P") in - let applied_ind = build_dependent_inductive ind specif in + let applied_ind = build_dependent_inductive indu specif in let applied_ind_P = - mkApp (mkInd ind, Array.concat + mkApp (mkIndU indu, Array.concat [extended_rel_vect (4*nrealargs+2) paramsctxt1; rel_vect 0 nrealargs; rel_vect (nrealargs+1) nrealargs]) in let applied_ind_P' = - mkApp (mkInd ind, Array.concat + mkApp (mkIndU indu, Array.concat [extended_rel_vect (3*nrealargs+1) paramsctxt1; rel_vect 0 nrealargs; rel_vect (2*nrealargs+1) nrealargs]) in @@ -443,7 +469,9 @@ let build_l2r_forward_rew_scheme dep env ind kind = name_context env ((Name varH,None,applied_ind)::realsign) in let realsign_ind_P n aP = name_context env ((Name varH,None,aP)::realsign_P n) in - let s = mkSort (new_sort_in_family kind) in + let s, ctx' = Universes.fresh_sort_in_family (Global.env ()) kind in + let ctx = Univ.ContextSet.union ctx ctx' in + let s = mkSort s in let ci = make_case_info (Global.env()) ind RegularStyle in let applied_PC = mkApp (mkVar varP,Array.append @@ -457,6 +485,7 @@ let build_l2r_forward_rew_scheme dep env ind kind = let applied_PG = mkApp (mkVar varP,Array.append (rel_vect 3 nrealargs) (if dep then [|cstr (3*nrealargs+4) 3|] else [||])) in + let c = (my_it_mkLambda_or_LetIn mib.mind_params_ctxt (my_it_mkLambda_or_LetIn_name realsign (mkNamedLambda varH applied_ind @@ -473,6 +502,7 @@ let build_l2r_forward_rew_scheme dep env ind kind = (if dep then realsign_ind_P 1 applied_ind_P' else realsign_P 2) s) (mkNamedLambda varHC applied_PC' (mkVar varHC))|]))))) + in c, Evd.evar_universe_context_of ctx (**********************************************************************) (* Build the right-to-left rewriting lemma for hypotheses associated *) @@ -504,19 +534,22 @@ let build_l2r_forward_rew_scheme dep env ind kind = (* statement but no need for symmetry of the equality. *) (**********************************************************************) -let build_r2l_forward_rew_scheme dep env ind kind = - let ((mib,mip as specif),constrargs,realsign,nrealargs) = - get_non_sym_eq_data env ind in +let build_r2l_forward_rew_scheme dep env ind kind = + let (ind,u as indu), ctx = Universes.fresh_inductive_instance env ind in + let ((mib,mip as specif),constrargs,realsign,paramsctxt,nrealargs) = + get_non_sym_eq_data env indu in let cstr n = - mkApp (mkConstruct(ind,1),extended_rel_vect n mib.mind_params_ctxt) in + mkApp (mkConstructUi(indu,1),extended_rel_vect n mib.mind_params_ctxt) in let constrargs_cstr = constrargs@[cstr 0] in let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in let varHC = fresh env (Id.of_string "HC") in let varP = fresh env (Id.of_string "P") in - let applied_ind = build_dependent_inductive ind specif in + let applied_ind = build_dependent_inductive indu specif in let realsign_ind = name_context env ((Name varH,None,applied_ind)::realsign) in - let s = mkSort (new_sort_in_family kind) in + let s, ctx' = Universes.fresh_sort_in_family (Global.env ()) kind in + let ctx = Univ.ContextSet.union ctx ctx' in + let s = mkSort s in let ci = make_case_info (Global.env()) ind RegularStyle in let applied_PC = applist (mkVar varP,if dep then constrargs_cstr else constrargs) in @@ -524,7 +557,8 @@ let build_r2l_forward_rew_scheme dep env ind kind = mkApp (mkVar varP, if dep then extended_rel_vect 0 realsign_ind else extended_rel_vect 1 realsign) in - (my_it_mkLambda_or_LetIn mib.mind_params_ctxt + let c = + (my_it_mkLambda_or_LetIn paramsctxt (my_it_mkLambda_or_LetIn_name realsign_ind (mkNamedLambda varP (my_it_mkProd_or_LetIn (lift_rel_context (nrealargs+1) @@ -541,6 +575,7 @@ let build_r2l_forward_rew_scheme dep env ind kind = lift (nrealargs+3) applied_PC, mkRel 1)|]), [|mkVar varHC|])))))) + in c, Evd.evar_universe_context_of ctx (**********************************************************************) (* This function "repairs" the non-dependent r2l forward rewriting *) @@ -558,11 +593,12 @@ let build_r2l_forward_rew_scheme dep env ind kind = (* *) (**********************************************************************) -let fix_r2l_forward_rew_scheme c = +let fix_r2l_forward_rew_scheme (c, ctx') = let t = Retyping.get_type_of (Global.env()) Evd.empty c in let ctx,_ = decompose_prod_assum t in match ctx with | hp :: p :: ind :: indargs -> + let c' = my_it_mkLambda_or_LetIn indargs (mkLambda_or_LetIn (map_rel_declaration (liftn (-1) 1) p) (mkLambda_or_LetIn (map_rel_declaration (liftn (-1) 2) hp) @@ -570,6 +606,7 @@ let fix_r2l_forward_rew_scheme c = (Reductionops.whd_beta Evd.empty (applist (c, extended_rel_list 3 indargs @ [mkRel 1;mkRel 3;mkRel 2])))))) + in c', ctx' | _ -> anomaly (Pp.str "Ill-formed non-dependent left-to-right rewriting scheme") (**********************************************************************) @@ -592,9 +629,16 @@ let fix_r2l_forward_rew_scheme c = (* (H:I q1..qm a1..an), *) (* P b1..bn C -> P a1..an H *) (**********************************************************************) - + let build_r2l_rew_scheme dep env ind k = - build_case_analysis_scheme env Evd.empty ind dep k + let sigma, indu = Evd.fresh_inductive_instance env (Evd.from_env env) ind in + let sigma', c = build_case_analysis_scheme env sigma indu dep k in + c, Evd.evar_universe_context sigma' + +let build_l2r_rew_scheme = build_l2r_rew_scheme +let build_l2r_forward_rew_scheme = build_l2r_forward_rew_scheme +let build_r2l_rew_scheme = build_r2l_rew_scheme +let build_r2l_forward_rew_scheme = build_r2l_forward_rew_scheme (**********************************************************************) (* Register the rewriting schemes *) @@ -681,17 +725,22 @@ let rew_r2l_scheme_kind = (* TODO: extend it to types with more than one index *) -let build_congr env (eq,refl) ind = +let build_congr env (eq,refl,ctx) ind = + let (ind,u as indu), ctx = with_context_set ctx + (Universes.fresh_inductive_instance env ind) in let (mib,mip) = lookup_mind_specif env ind in + let subst = Inductive.make_inductive_subst mib u in if not (Int.equal (Array.length mib.mind_packets) 1) || not (Int.equal (Array.length mip.mind_nf_lc) 1) then error "Not an inductive type with a single constructor."; if not (Int.equal mip.mind_nrealargs 1) then error "Expect an inductive type with one predicate parameter."; let i = 1 in - let realsign,_ = List.chop mip.mind_nrealargs_ctxt mip.mind_arity_ctxt in + let arityctxt = Vars.subst_univs_context subst mip.mind_arity_ctxt in + let paramsctxt = Vars.subst_univs_context subst mib.mind_params_ctxt in + let realsign,_ = List.chop mip.mind_nrealargs_ctxt arityctxt in if List.exists (fun (_,b,_) -> not (Option.is_empty b)) realsign then error "Inductive equalities with local definitions in arity not supported."; - let env_with_arity = push_rel_context mip.mind_arity_ctxt env in + let env_with_arity = push_rel_context arityctxt env in let (_,_,ty) = lookup_rel (mip.mind_nrealargs - i + 1) env_with_arity in let constrsign,ccl = decompose_prod_assum mip.mind_nf_lc.(0) in let _,constrargs = decompose_app ccl in @@ -702,14 +751,16 @@ let build_congr env (eq,refl) ind = let varH = fresh env (Id.of_string "H") in let varf = fresh env (Id.of_string "f") in let ci = make_case_info (Global.env()) ind RegularStyle in - my_it_mkLambda_or_LetIn mib.mind_params_ctxt - (mkNamedLambda varB (new_Type ()) + let uni, ctx = Universes.extend_context (Universes.new_global_univ ()) ctx in + let c = + my_it_mkLambda_or_LetIn paramsctxt + (mkNamedLambda varB (mkSort (Type uni)) (mkNamedLambda varf (mkArrow (lift 1 ty) (mkVar varB)) (my_it_mkLambda_or_LetIn_name (lift_rel_context 2 realsign) (mkNamedLambda varH (applist - (mkInd ind, - extended_rel_list (mip.mind_nrealargs+2) mib.mind_params_ctxt @ + (mkIndU indu, + extended_rel_list (mip.mind_nrealargs+2) paramsctxt @ extended_rel_list 0 realsign)) (mkCase (ci, my_it_mkLambda_or_LetIn_name @@ -717,9 +768,9 @@ let build_congr env (eq,refl) ind = (mkLambda (Anonymous, applist - (mkInd ind, + (mkIndU indu, extended_rel_list (2*mip.mind_nrealargs_ctxt+3) - mib.mind_params_ctxt + paramsctxt @ extended_rel_list 0 realsign), mkApp (eq, [|mkVar varB; @@ -729,8 +780,9 @@ let build_congr env (eq,refl) ind = [|mkApp (refl, [|mkVar varB; mkApp (mkVar varf, [|lift (mip.mind_nrealargs+3) b|])|])|])))))) + in c, Evd.evar_universe_context_of ctx let congr_scheme_kind = declare_individual_scheme_object "_congr" (fun ind -> (* May fail if equality is not defined *) - build_congr (Global.env()) (get_coq_eq ()) ind, Declareops.no_seff) + build_congr (Global.env()) (get_coq_eq Univ.ContextSet.empty) ind, Declareops.no_seff) diff --git a/tactics/eqschemes.mli b/tactics/eqschemes.mli index 72412d12d..f18991d72 100644 --- a/tactics/eqschemes.mli +++ b/tactics/eqschemes.mli @@ -22,24 +22,26 @@ val rew_l2r_forward_dep_scheme_kind : individual scheme_kind val rew_r2l_dep_scheme_kind : individual scheme_kind val rew_r2l_scheme_kind : individual scheme_kind -val build_r2l_rew_scheme : bool -> env -> inductive -> sorts_family -> constr -val build_l2r_rew_scheme : - bool -> env -> inductive -> sorts_family -> constr * Declareops.side_effects +val build_r2l_rew_scheme : bool -> env -> inductive -> sorts_family -> + constr Evd.in_evar_universe_context +val build_l2r_rew_scheme : bool -> env -> inductive -> sorts_family -> + constr Evd.in_evar_universe_context * Declareops.side_effects val build_r2l_forward_rew_scheme : - bool -> env -> inductive -> sorts_family -> constr + bool -> env -> inductive -> sorts_family -> constr Evd.in_evar_universe_context val build_l2r_forward_rew_scheme : - bool -> env -> inductive -> sorts_family -> constr + bool -> env -> inductive -> sorts_family -> constr Evd.in_evar_universe_context (** Builds a symmetry scheme for a symmetrical equality type *) -val build_sym_scheme : env -> inductive -> constr +val build_sym_scheme : env -> inductive -> constr Evd.in_evar_universe_context val sym_scheme_kind : individual scheme_kind -val build_sym_involutive_scheme : - env -> inductive -> constr * Declareops.side_effects +val build_sym_involutive_scheme : env -> inductive -> + constr Evd.in_evar_universe_context * Declareops.side_effects val sym_involutive_scheme_kind : individual scheme_kind (** Builds a congruence scheme for an equality type *) val congr_scheme_kind : individual scheme_kind -val build_congr : env -> constr * constr -> inductive -> constr +val build_congr : env -> constr * constr * Univ.universe_context_set -> inductive -> + constr Evd.in_evar_universe_context diff --git a/tactics/equality.ml b/tactics/equality.ml index b062da23e..57931f600 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -1,4 +1,4 @@ -(************************************************************************) +1(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) @@ -280,33 +280,32 @@ let jmeq_same_dom gl = function let find_elim hdcncl lft2rgt dep cls ot gl = let inccl = Option.is_empty cls in - let hdcncl_is u = eq_constr hdcncl (constr_of_reference u) in - if (hdcncl_is (Coqlib.glob_eq) || - hdcncl_is (Coqlib.glob_jmeq) && jmeq_same_dom gl ot) - && not dep - || Flags.version_less_or_equal Flags.V8_2 + if (is_global Coqlib.glob_eq hdcncl || + (is_global Coqlib.glob_jmeq hdcncl && + jmeq_same_dom gl ot)) && not dep + || Flags.version_less_or_equal Flags.V8_2 then match kind_of_term hdcncl with - | Ind ind_sp -> + | Ind (ind_sp,u) -> let pr1 = lookup_eliminator ind_sp (elimination_sort_of_clause cls gl) in begin match lft2rgt, cls with | Some true, None | Some false, Some _ -> - let c1 = destConst pr1 in + let c1 = destConstRef pr1 in let mp,dp,l = repr_con (constant_of_kn (canonical_con c1)) in let l' = Label.of_id (add_suffix (Label.to_id l) "_r") in let c1' = Global.constant_of_delta_kn (make_kn mp dp l') in begin try let _ = Global.lookup_constant c1' in - mkConst c1', Declareops.no_seff + c1', Declareops.no_seff with Not_found -> let rwr_thm = Label.to_string l' in error ("Cannot find rewrite principle "^rwr_thm^".") end - | _ -> pr1, Declareops.no_seff + | _ -> destConstRef pr1, Declareops.no_seff end | _ -> (* cannot occur since we checked that we are in presence of @@ -326,9 +325,9 @@ let find_elim hdcncl lft2rgt dep cls ot gl = | true, _, false -> rew_r2l_forward_dep_scheme_kind in match kind_of_term hdcncl with - | Ind ind -> + | Ind (ind,u) -> let c, eff = find_scheme scheme_name ind in - mkConst c , eff + c , eff | _ -> assert false let type_of_clause cls gl = match cls with @@ -342,10 +341,13 @@ let leibniz_rewrite_ebindings_clause cls lft2rgt tac c t l with_evars frzevars d let type_of_cls = type_of_clause cls gl in let dep = dep_proof_ok && dep_fun c type_of_cls in let (elim,effs) = find_elim hdcncl lft2rgt dep cls (Some t) gl in + let tac elim = + general_elim_clause with_evars frzevars tac cls c t l + (match lft2rgt with None -> false | Some b -> b) + {elimindex = None; elimbody = (elim,NoBindings)} + in Proofview.tclEFFECTS effs <*> - general_elim_clause with_evars frzevars tac cls c t l - (match lft2rgt with None -> false | Some b -> b) - {elimindex = None; elimbody = (elim,NoBindings)} + pf_constr_of_global (ConstRef elim) tac end let adjust_rewriting_direction args lft2rgt = @@ -534,26 +536,34 @@ let multi_replace clause c2 c1 unsafe try_prove_eq_opt = let get_type_of = pf_apply get_type_of gl in let t1 = get_type_of c1 and t2 = get_type_of c2 in - let is_conv = pf_apply is_conv gl in - if unsafe || (is_conv t1 t2) then + let evd = + if unsafe then Some (Proofview.Goal.sigma gl) + else + try Some (Evarconv.the_conv_x (Proofview.Goal.env gl) t1 t2 (Proofview.Goal.sigma gl)) + with Evarconv.UnableToUnify _ -> None + in + match evd with + | None -> + tclFAIL 0 (str"Terms do not have convertible types.") + | Some evd -> let e = build_coq_eq () in let sym = build_coq_eq_sym () in + Tacticals.New.pf_constr_of_global e (fun e -> let eq = applist (e, [t1;c1;c2]) in if check_setoid clause then init_setoid (); - tclTHENS (assert_as false None eq) - [onLastHypId (fun id -> - tclTHEN - (tclTRY (general_multi_rewrite false false (mkVar id,NoBindings) clause)) - (clear [id])); - tclFIRST - [assumption; - tclTHEN (Proofview.V82.tactic (apply sym)) assumption; - try_prove_eq - ] - ] - else - tclFAIL 0 (str"Terms do not have convertible types.") + Tacticals.New.pf_constr_of_global sym (fun sym -> + tclTHENS (assert_as false None eq) + [onLastHypId (fun id -> + tclTHEN + (tclTRY (general_multi_rewrite false false (mkVar id,NoBindings) clause)) + (clear [id])); + tclFIRST + [assumption; + tclTHEN (Proofview.V82.tactic (apply sym)) assumption; + try_prove_eq + ] + ])) end let replace c2 c1 = multi_replace onConcl c2 c1 false None @@ -627,8 +637,7 @@ let find_positions env sigma t1 t2 = let hd1,args1 = whd_betadeltaiota_stack env sigma t1 in let hd2,args2 = whd_betadeltaiota_stack env sigma t2 in match (kind_of_term hd1, kind_of_term hd2) with - - | Construct sp1, Construct sp2 + | Construct (sp1,_), Construct (sp2,_) when Int.equal (List.length args1) (mis_constructor_nargs_env env sp1) -> let sorts = @@ -636,7 +645,7 @@ let find_positions env sigma t1 t2 = in (* both sides are fully applied constructors, so either we descend, or we can discriminate here. *) - if is_conv env sigma hd1 hd2 then + if eq_constructor sp1 sp2 then let nrealargs = constructor_nrealargs env sp1 in let rargs1 = List.lastn nrealargs args1 in let rargs2 = List.lastn nrealargs args2 in @@ -746,7 +755,7 @@ let descend_then sigma env head dirn = try find_rectype env sigma (get_type_of env sigma head) with Not_found -> error "Cannot project on an inductive type derived from a dependency." in - let ind,_ = dest_ind_family indf in + let (ind,_),_ = dest_ind_family indf in let (mib,mip) = lookup_mind_specif env ind in let cstr = get_constructors env indf in let dirn_nlams = cstr.(dirn-1).cs_nargs in @@ -795,7 +804,7 @@ let construct_discriminator sigma env dirn c sort = errorlabstrm "Equality.construct_discriminator" (str "Cannot discriminate on inductive constructors with \ dependent types.") in - let (ind,_) = dest_ind_family indf in + let ((ind,_),_) = dest_ind_family indf in let (mib,mip) = lookup_mind_specif env ind in let (true_0,false_0,sort_0) = build_coq_True(),build_coq_False(),Prop Null in let deparsign = make_arity_signature env true indf in @@ -847,22 +856,23 @@ let gen_absurdity id = *) let ind_scheme_of_eq lbeq = - let (mib,mip) = Global.lookup_inductive (destInd lbeq.eq) in + let (mib,mip) = Global.lookup_inductive (destIndRef lbeq.eq) in let kind = inductive_sort_family mip in (* use ind rather than case by compatibility *) let kind = if kind == InProp then Elimschemes.ind_scheme_kind_from_prop else Elimschemes.ind_scheme_kind_from_type in - let c, eff = find_scheme kind (destInd lbeq.eq) in - mkConst c, eff + let c, eff = find_scheme kind (destIndRef lbeq.eq) in + ConstRef c, eff -let discrimination_pf e (t,t1,t2) discriminator lbeq = +let discrimination_pf env sigma e (t,t1,t2) discriminator lbeq = let i = build_coq_I () in let absurd_term = build_coq_False () in let eq_elim, eff = ind_scheme_of_eq lbeq in - (applist (eq_elim, [t;t1;mkNamedLambda e t discriminator;i;t2]), absurd_term), - eff + let sigma, eq_elim = Evd.fresh_global env sigma eq_elim in + sigma, (applist (eq_elim, [t;t1;mkNamedLambda e t discriminator;i;t2]), absurd_term), + eff let eq_baseid = Id.of_string "e" @@ -880,11 +890,12 @@ let discr_positions env sigma (lbeq,eqn,(t,t1,t2)) eq_clause cpath dirn sort = let e_env = push_named (e,None,t) env in let discriminator = build_discriminator sigma e_env dirn (mkVar e) sort cpath in - let (pf, absurd_term), eff = - discrimination_pf e (t,t1,t2) discriminator lbeq in + let sigma,(pf, absurd_term), eff = + discrimination_pf env sigma e (t,t1,t2) discriminator lbeq in let pf_ty = mkArrow eqn absurd_term in let absurd_clause = apply_on_clause (pf,pf_ty) eq_clause in let pf = clenv_value_cast_meta absurd_clause in + Proofview.V82.tclEVARS sigma <*> Proofview.tclEFFECTS eff <*> tclTHENS (cut_intro absurd_term) [onLastHypId gen_absurdity; (Proofview.V82.tactic (refine pf))] @@ -911,7 +922,7 @@ let onEquality with_evars tac (c,lbindc) = let eq_clause = pf_apply make_clenv_binding gl (c,t') lbindc in let eq_clause' = clenv_pose_dependent_evars with_evars eq_clause in let eqn = clenv_type eq_clause' in - let (eq,eq_args) = find_this_eq_data_decompose gl eqn in + let (eq,u,eq_args) = find_this_eq_data_decompose gl eqn in tclTHEN (Proofview.V82.tclEVARS eq_clause'.evd) (tac (eq,eqn,eq_args) eq_clause') @@ -964,7 +975,7 @@ let discrHyp id = discrClause false (onHyp id) constructor depending on the sort *) (* J.F.: correction du bug #1167 en accord avec Hugo. *) -let find_sigma_data s = build_sigma_type () +let find_sigma_data env s = build_sigma_type () (* [make_tuple env sigma (rterm,rty) lind] assumes [lind] is the lesser index bound in [rty] @@ -978,16 +989,18 @@ let find_sigma_data s = build_sigma_type () let make_tuple env sigma (rterm,rty) lind = assert (dependent (mkRel lind) rty); - let {intro = exist_term; typ = sig_term} = - find_sigma_data (get_sort_of env sigma rty) in + let sigdata = find_sigma_data env (get_sort_of env sigma rty) in let a = type_of env sigma (mkRel lind) in let (na,_,_) = lookup_rel lind env in (* We move [lind] to [1] and lift other rels > [lind] by 1 *) let rty = lift (1-lind) (liftn lind (lind+1) rty) in (* Now [lind] is [mkRel 1] and we abstract on (na:a) *) let p = mkLambda (na, a, rty) in - (applist(exist_term,[a;p;(mkRel lind);rterm]), - applist(sig_term,[a;p])) + let sigma, exist_term = Evd.fresh_global env sigma sigdata.intro in + let sigma, sig_term = Evd.fresh_global env sigma sigdata.typ in + sigma, + (applist(exist_term,[a;p;(mkRel lind);rterm]), + applist(sig_term,[a;p])) (* check that the free-references of the type of [c] are contained in the free-references of the normal-form of that type. Strictly @@ -1052,7 +1065,7 @@ let minimal_free_rels_rec env sigma = *) let sig_clausal_form env sigma sort_of_ty siglen ty dflt = - let { intro = exist_term } = find_sigma_data sort_of_ty in + let sigdata = find_sigma_data env sort_of_ty in let evdref = ref (Evd.create_goal_evar_defs sigma) in let rec sigrec_clausal_form siglen p_i = if Int.equal siglen 0 then @@ -1078,13 +1091,14 @@ let sig_clausal_form env sigma sort_of_ty siglen ty dflt = | Some w -> let w_type = type_of env sigma w in if Evarconv.e_cumul env evdref w_type a then + let exist_term = Evarutil.evd_comb1 (Evd.fresh_global env) evdref sigdata.intro in applist(exist_term,[w_type;p_i_minus_1;w;tuple_tail]) else error "Cannot solve a unification problem." | None -> anomaly (Pp.str "Not enough components to build the dependent tuple") in let scf = sigrec_clausal_form siglen ty in - Evarutil.nf_evar !evdref scf + !evdref, Evarutil.nf_evar !evdref scf (* The problem is to build a destructor (a generalization of the predecessor) which, when applied to a term made of constructors @@ -1148,13 +1162,13 @@ let make_iterated_tuple env sigma dflt (z,zty) = let (zty,rels) = minimal_free_rels_rec env sigma (z,zty) in let sort_of_zty = get_sort_of env sigma zty in let sorted_rels = Int.Set.elements rels in - let (tuple,tuplety) = - List.fold_left (make_tuple env sigma) (z,zty) sorted_rels + let sigma, (tuple,tuplety) = + List.fold_left (fun (sigma, t) -> make_tuple env sigma t) (sigma, (z,zty)) sorted_rels in assert (closed0 tuplety); let n = List.length sorted_rels in - let dfltval = sig_clausal_form env sigma sort_of_zty n tuplety dflt in - (tuple,tuplety,dfltval) + let sigma, dfltval = sig_clausal_form env sigma sort_of_zty n tuplety dflt in + sigma, (tuple,tuplety,dfltval) let rec build_injrec sigma env dflt c = function | [] -> make_iterated_tuple env sigma dflt (c,type_of env sigma c) @@ -1162,15 +1176,14 @@ let rec build_injrec sigma env dflt c = function try let (cnum_nlams,cnum_env,kont) = descend_then sigma env c cnum in let newc = mkRel(cnum_nlams-argnum) in - let (subval,tuplety,dfltval) = build_injrec sigma cnum_env dflt newc l in - (kont subval (dfltval,tuplety), - tuplety,dfltval) + let sigma, (subval,tuplety,dfltval) = build_injrec sigma cnum_env dflt newc l in + sigma, (kont subval (dfltval,tuplety), tuplety,dfltval) with UserError _ -> failwith "caught" let build_injector sigma env dflt c cpath = - let (injcode,resty,_) = build_injrec sigma env dflt c cpath in - (injcode,resty) + let sigma, (injcode,resty,_) = build_injrec sigma env dflt c cpath in + sigma, (injcode,resty) (* let try_delta_expand env sigma t = @@ -1199,28 +1212,32 @@ let simplify_args env sigma t = let inject_at_positions env sigma l2r (eq,_,(t,t1,t2)) eq_clause posns tac = let e = next_ident_away eq_baseid (ids_of_context env) in let e_env = push_named (e, None,t) env in + let evdref = ref sigma in let filter (cpath, t1', t2') = try (* arbitrarily take t1' as the injector default value *) - let (injbody,resty) = build_injector sigma e_env t1' (mkVar e) cpath in + let sigma, (injbody,resty) = build_injector !evdref e_env t1' (mkVar e) cpath in let injfun = mkNamedLambda e t injbody in - let pf = applist(eq.congr,[t;resty;injfun;t1;t2]) in - let pf_typ = get_type_of env sigma pf in + let congr = Evarutil.evd_comb1 (Evd.fresh_global env) evdref eq.congr in + let pf = applist(congr,[t;resty;injfun;t1;t2]) in + let sigma, pf_typ = Typing.e_type_of env sigma pf in let inj_clause = apply_on_clause (pf,pf_typ) eq_clause in let pf = clenv_value_cast_meta inj_clause in let ty = simplify_args env sigma (clenv_type inj_clause) in - Some (pf, ty) + evdref := sigma; + Some (pf, ty) with Failure _ -> None in let injectors = List.map_filter filter posns in if List.is_empty injectors then Proofview.tclZERO (Errors.UserError ("Equality.inj" , str "Failed to decompose the equality.")) else - Proofview.tclBIND + Proofview.tclTHEN (Proofview.V82.tclEVARS !evdref) + (Proofview.tclBIND (Proofview.Monad.List.map (fun (pf,ty) -> tclTHENS (cut ty) [Proofview.tclUNIT (); Proofview.V82.tactic (refine pf)]) (if l2r then List.rev injectors else injectors)) - (fun _ -> tac (List.length injectors)) + (fun _ -> tac (List.length injectors))) exception Not_dep_pair @@ -1232,30 +1249,32 @@ let eqdep_dec = qualid_of_string "Coq.Logic.Eqdep_dec" let inject_if_homogenous_dependent_pair env sigma (eq,_,(t,t1,t2)) = Proofview.Goal.raw_enter begin fun gl -> (* fetch the informations of the pair *) - let ceq = constr_of_global Coqlib.glob_eq in + let ceq = Universes.constr_of_global Coqlib.glob_eq in let sigTconstr () = (Coqlib.build_sigma_type()).Coqlib.typ in let eqTypeDest = fst (destApp t) in let _,ar1 = destApp t1 and _,ar2 = destApp t2 in let ind = destInd ar1.(0) in - (* check whether the equality deals with dep pairs or not *) - (* if yes, check if the user has declared the dec principle *) - (* and compare the fst arguments of the dep pair *) + (* check whether the equality deals with dep pairs or not *) + (* if yes, check if the user has declared the dec principle *) + (* and compare the fst arguments of the dep pair *) let new_eq_args = [|type_of env sigma ar1.(3);ar1.(3);ar2.(3)|] in - if (eq_constr eqTypeDest (sigTconstr())) && - (Ind_tables.check_scheme (!eq_dec_scheme_kind_name()) ind) && + if (Globnames.is_global (sigTconstr()) eqTypeDest) && + (Ind_tables.check_scheme (!eq_dec_scheme_kind_name()) (fst ind)) && (is_conv env sigma ar1.(2) ar2.(2)) then begin Library.require_library [Loc.ghost,eqdep_dec] (Some false); let inj2 = Coqlib.coq_constant "inj_pair2_eq_dec is missing" ["Logic";"Eqdep_dec"] "inj_pair2_eq_dec" in - let c, eff = find_scheme (!eq_dec_scheme_kind_name()) ind in + let scheme, eff = find_scheme (!eq_dec_scheme_kind_name()) (Univ.out_punivs ind) in (* cut with the good equality and prove the requested goal *) tclTHENS (tclTHEN (Proofview.tclEFFECTS eff) (cut (mkApp (ceq,new_eq_args)))) - [tclIDTAC; tclTHEN (Proofview.V82.tactic (apply ( - mkApp(inj2,[|ar1.(0);mkConst c;ar1.(1);ar1.(2);ar1.(3);ar2.(3)|]) + [tclIDTAC; + pf_constr_of_global (ConstRef scheme) (fun c -> + tclTHEN (Proofview.V82.tactic (apply ( + mkApp(inj2,[|ar1.(0);c;ar1.(1);ar1.(2);ar1.(3);ar2.(3)|]) ))) (Auto.trivial [] []) - ] + )] (* not a dep eq or no decidable type found *) end else raise Not_dep_pair @@ -1341,29 +1360,31 @@ let swap_equality_args = function | HeterogenousEq (t1,e1,t2,e2) -> [t2;e2;t1;e1] let swap_equands eqn = - let (lbeq,eq_args) = find_eq_data eqn in - applist(lbeq.eq,swap_equality_args eq_args) + let (lbeq,u,eq_args) = find_eq_data eqn in + let eq = Universes.constr_of_global_univ (lbeq.eq,u) in + applist(eq,swap_equality_args eq_args) let swapEquandsInConcl = Proofview.Goal.raw_enter begin fun gl -> - let (lbeq,eq_args) = find_eq_data (pf_nf_concl gl) in - let sym_equal = lbeq.sym in + let (lbeq,u,eq_args) = find_eq_data (pf_nf_concl gl) in let args = swap_equality_args eq_args @ [Evarutil.mk_new_meta ()] in - Proofview.V82.tactic (fun gl -> refine (applist (sym_equal, args)) gl) + pf_constr_of_global lbeq.sym (fun sym_equal -> + Proofview.V82.tactic (refine (applist (sym_equal, args)))) end (* Refine from [|- P e2] to [|- P e1] and [|- e1=e2:>t] (body is P (Rel 1)) *) -let bareRevSubstInConcl lbeq body (t,e1,e2) = +let bareRevSubstInConcl (lbeq,u) body (t,e1,e2) = Proofview.Goal.raw_enter begin fun gl -> (* find substitution scheme *) - let eq_elim, effs = find_elim lbeq.eq (Some false) false None None gl in + let eq = Universes.constr_of_global_univ (lbeq.eq,u) in + let eq_elim, effs = find_elim eq (Some false) false None None gl in (* build substitution predicate *) let p = lambda_create (Proofview.Goal.env gl) (t,body) in (* apply substitution scheme *) let args = [t; e1; p; Evarutil.mk_new_meta (); e2; Evarutil.mk_new_meta ()] in - let tac gl = refine (applist (eq_elim, args)) gl in - Proofview.V82.tactic tac + pf_constr_of_global (ConstRef eq_elim) (fun c -> + Proofview.V82.tactic (refine (applist (c, args)))) end (* [subst_tuple_term dep_pair B] @@ -1402,17 +1423,15 @@ let decomp_tuple_term env c t = let rec decomprec inner_code ex exty = let iterated_decomp = try - let {proj1=p1; proj2=p2},(a,p,car,cdr) = find_sigma_data_decompose ex in - let car_code = applist (p1,[a;p;inner_code]) - and cdr_code = applist (p2,[a;p;inner_code]) in + let ({proj1=p1; proj2=p2}),(i,a,p,car,cdr) = find_sigma_data_decompose ex in + let car_code = applist (mkConstU (destConstRef p1,i),[a;p;inner_code]) + and cdr_code = applist (mkConstU (destConstRef p2,i),[a;p;inner_code]) in let cdrtyp = beta_applist (p,[car]) in List.map (fun l -> ((car,a),car_code)::l) (decomprec cdr_code cdr cdrtyp) with ConstrMatching.PatternMatchingFailure -> [] - in - [((ex,exty),inner_code)]::iterated_decomp - in - decomprec (mkRel 1) c t + in [((ex,exty),inner_code)]::iterated_decomp + in decomprec (mkRel 1) c t let subst_tuple_term env sigma dep_pair1 dep_pair2 b = let typ = get_type_of env sigma dep_pair1 in @@ -1435,7 +1454,7 @@ let subst_tuple_term env sigma dep_pair1 dep_pair2 b = let expected_goal = beta_applist (abst_B,List.map fst e2_list) in (* Simulate now the normalisation treatment made by Logic.mk_refgoals *) let expected_goal = nf_betaiota sigma expected_goal in - pred_body,expected_goal + pred_body,expected_goal (* Like "replace" but decompose dependent equalities *) @@ -1443,12 +1462,12 @@ exception NothingToRewrite let cutSubstInConcl_RL eqn = Proofview.Goal.raw_enter begin fun gl -> - let (lbeq,(t,e1,e2 as eq)) = find_eq_data_decompose gl eqn in + let (lbeq,u,(t,e1,e2 as eq)) = find_eq_data_decompose gl eqn in let concl = pf_nf_concl gl in let body,expected_goal = pf_apply subst_tuple_term gl e2 e1 concl in if not (dependent (mkRel 1) body) then raise NothingToRewrite; tclTHENFIRST - (bareRevSubstInConcl lbeq body eq) + (bareRevSubstInConcl (lbeq,u) body eq) (Proofview.V82.tactic (fun gl -> convert_concl expected_goal DEFAULTcast gl)) end @@ -1465,12 +1484,12 @@ let cutSubstInConcl l2r =if l2r then cutSubstInConcl_LR else cutSubstInConcl_RL let cutSubstInHyp_LR eqn id = Proofview.Goal.enter begin fun gl -> - let (lbeq,(t,e1,e2 as eq)) = find_eq_data_decompose gl eqn in + let (lbeq,u,(t,e1,e2 as eq)) = find_eq_data_decompose gl eqn in let idtyp = pf_get_hyp_typ id gl in let body,expected_goal = pf_apply subst_tuple_term gl e1 e2 idtyp in if not (dependent (mkRel 1) body) then raise NothingToRewrite; let refine = Proofview.V82.tactic (fun gl -> Tacmach.refine_no_check (mkVar id) gl) in - let subst = Proofview.V82.of_tactic (tclTHENFIRST (bareRevSubstInConcl lbeq body eq) refine) in + let subst = Proofview.V82.of_tactic (tclTHENFIRST (bareRevSubstInConcl (lbeq,u) body eq) refine) in Proofview.V82.tactic (fun gl -> cut_replacing id expected_goal subst gl) end @@ -1555,8 +1574,8 @@ let unfold_body x = let restrict_to_eq_and_identity eq = (* compatibility *) - if not (eq_constr eq (constr_of_global glob_eq)) && - not (eq_constr eq (constr_of_global glob_identity)) + if not (is_global glob_eq eq) && + not (is_global glob_identity eq) then raise ConstrMatching.PatternMatchingFailure exception FoundHyp of (Id.t * constr * bool) @@ -1565,7 +1584,7 @@ exception FoundHyp of (Id.t * constr * bool) let is_eq_x gl x (id,_,c) = try let c = pf_nf_evar gl c in - let (_,lhs,rhs) = snd (find_eq_data_decompose gl c) in + let (_,lhs,rhs) = pi3 (find_eq_data_decompose gl c) in if (eq_constr x lhs) && not (occur_term x rhs) then raise (FoundHyp (id,rhs,true)); if (eq_constr x rhs) && not (occur_term x lhs) then raise (FoundHyp (id,lhs,false)) with ConstrMatching.PatternMatchingFailure -> @@ -1664,8 +1683,9 @@ let subst_all ?(flags=default_subst_tactic_flags ()) () = let find_eq_data_decompose = find_eq_data_decompose gl in let test (_,c) = try - let lbeq,(_,x,y) = find_eq_data_decompose c in - if flags.only_leibniz then restrict_to_eq_and_identity lbeq.eq; + let lbeq,u,(_,x,y) = find_eq_data_decompose c in + let eq = Universes.constr_of_global_univ (lbeq.eq,u) in + if flags.only_leibniz then restrict_to_eq_and_identity eq; (* J.F.: added to prevent failure on goal containing x=x as an hyp *) if eq_constr x y then failwith "caught"; match kind_of_term x with Var x -> x | _ -> @@ -1684,19 +1704,19 @@ let subst_all ?(flags=default_subst_tactic_flags ()) () = let cond_eq_term_left c t gl = try - let (_,x,_) = snd (find_eq_data_decompose gl t) in + let (_,x,_) = pi3 (find_eq_data_decompose gl t) in if pf_conv_x gl c x then true else failwith "not convertible" with ConstrMatching.PatternMatchingFailure -> failwith "not an equality" let cond_eq_term_right c t gl = try - let (_,_,x) = snd (find_eq_data_decompose gl t) in + let (_,_,x) = pi3 (find_eq_data_decompose gl t) in if pf_conv_x gl c x then false else failwith "not convertible" with ConstrMatching.PatternMatchingFailure -> failwith "not an equality" let cond_eq_term c t gl = try - let (_,x,y) = snd (find_eq_data_decompose gl t) in + let (_,x,y) = pi3 (find_eq_data_decompose gl t) in if pf_conv_x gl c x then true else if pf_conv_x gl c y then false else failwith "not convertible" diff --git a/tactics/equality.mli b/tactics/equality.mli index b59b4bbe0..82e30b940 100644 --- a/tactics/equality.mli +++ b/tactics/equality.mli @@ -88,7 +88,7 @@ val dEq : evars_flag -> constr with_bindings induction_arg option -> unit Proofv val dEqThen : evars_flag -> (constr -> int -> unit Proofview.tactic) -> constr with_bindings induction_arg option -> unit Proofview.tactic val make_iterated_tuple : - env -> evar_map -> constr -> (constr * types) -> constr * constr * constr + env -> evar_map -> constr -> (constr * types) -> evar_map * (constr * constr * constr) (* The family cutRewriteIn expect an equality statement *) val cutRewriteInHyp : bool -> types -> Id.t -> unit Proofview.tactic diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4 index f8790796d..bda217566 100644 --- a/tactics/extratactics.ml4 +++ b/tactics/extratactics.ml4 @@ -252,7 +252,14 @@ TACTIC EXTEND rewrite_star let add_rewrite_hint bases ort t lcsr = let env = Global.env() and sigma = Evd.empty in - let f c = Constrexpr_ops.constr_loc c, Constrintern.interp_constr sigma env c, ort, t in + let poly = Flags.is_universe_polymorphism () in + let f ce = + let c, ctx = Constrintern.interp_constr sigma env ce in + let ctx = + if poly then ctx + else (Global.add_constraints (snd ctx); Univ.ContextSet.empty) + in + Constrexpr_ops.constr_loc ce, (c, ctx), ort, t in let eqs = List.map f lcsr in let add_hints base = add_rew_rules base eqs in List.iter add_hints bases @@ -281,8 +288,8 @@ open Coqlib let project_hint pri l2r r = let gr = Smartlocate.global_with_alias r in let env = Global.env() in - let c = Globnames.constr_of_global gr in - let t = Retyping.get_type_of env Evd.empty c in + let c,ctx = Universes.fresh_global_instance env gr in + let t = Retyping.get_type_of env (Evd.from_env ~ctx env) c in let t = Tacred.reduce_to_quantified_ref env Evd.empty (Lazy.force coq_iff_ref) t in let sign,ccl = decompose_prod_assum t in @@ -294,7 +301,11 @@ let project_hint pri l2r r = let c = Reductionops.whd_beta Evd.empty (mkApp (c,Termops.extended_rel_vect 0 sign)) in let c = it_mkLambda_or_LetIn (mkApp (p,[|mkArrow a (lift 1 b);mkArrow b (lift 1 a);c|])) sign in - (pri,true,Auto.PathAny, Globnames.IsConstr c) + let id = + Nameops.add_suffix (Nametab.basename_of_global gr) ("_proj_" ^ (if l2r then "l2r" else "r2l")) + in + let c = Declare.declare_definition ~internal:Declare.KernelSilent id (c,ctx) in + (pri,false,true,Auto.PathAny, Auto.IsGlobRef (Globnames.ConstRef c)) let add_hints_iff l2r lc n bl = Auto.add_hints true bl @@ -473,7 +484,7 @@ let inTransitivity : bool * constr -> obj = (* Main entry points *) let add_transitivity_lemma left lem = - let lem' = Constrintern.interp_constr Evd.empty (Global.env ()) lem in + let lem',ctx (*FIXME*) = Constrintern.interp_constr Evd.empty (Global.env ()) lem in add_anonymous_leaf (inTransitivity (left,lem')) (* Vernacular syntax *) @@ -513,8 +524,8 @@ END VERNAC COMMAND EXTEND RetroknowledgeRegister CLASSIFIED AS SIDEFF | [ "Register" constr(c) "as" retroknowledge_field(f) "by" constr(b)] -> - [ let tc = Constrintern.interp_constr Evd.empty (Global.env ()) c in - let tb = Constrintern.interp_constr Evd.empty (Global.env ()) b in + [ let tc,ctx = Constrintern.interp_constr Evd.empty (Global.env ()) c in + let tb,ctx(*FIXME*) = Constrintern.interp_constr Evd.empty (Global.env ()) b in Global.register f tc tb ] END @@ -607,9 +618,11 @@ let hResolve id c occ t gl = let loc = match Loc.get_loc e with None -> Loc.ghost | Some loc -> loc in resolve_hole (subst_hole_with_term (fst (Loc.unloc loc)) c_raw t_hole) in - let t_constr = resolve_hole (subst_var_with_hole occ id t_raw) in + let t_constr,ctx = resolve_hole (subst_var_with_hole occ id t_raw) in + let sigma = Evd.merge_context_set Evd.univ_rigid sigma ctx in let t_constr_type = Retyping.get_type_of env sigma t_constr in - change_in_concl None (mkLetIn (Anonymous,t_constr,t_constr_type,pf_concl gl)) gl + tclTHEN (Refiner.tclEVARS sigma) + (change_in_concl None (mkLetIn (Anonymous,t_constr,t_constr_type,pf_concl gl))) gl let hResolve_auto id c t gl = let rec resolve_auto n = @@ -749,6 +762,11 @@ TACTIC EXTEND constr_eq if eq_constr x y then Proofview.tclUNIT () else Tacticals.New.tclFAIL 0 (str "Not equal") ] END +TACTIC EXTEND constr_eq_nounivs +| [ "constr_eq_nounivs" constr(x) constr(y) ] -> [ + if eq_constr_nounivs x y then Proofview.tclUNIT () else Tacticals.New.tclFAIL 0 (str "Not equal") ] +END + TACTIC EXTEND is_evar | [ "is_evar" constr(x) ] -> [ match kind_of_term x with @@ -772,6 +790,7 @@ let rec has_evar x = has_evar t1 || has_evar t2 || has_evar_array ts | Fix ((_, tr)) | CoFix ((_, tr)) -> has_evar_prec tr + | Proj (p, c) -> has_evar c and has_evar_array x = Array.exists has_evar x and has_evar_prec (_, ts1, ts2) = diff --git a/tactics/g_rewrite.ml4 b/tactics/g_rewrite.ml4 index 954892e81..d00626d32 100644 --- a/tactics/g_rewrite.ml4 +++ b/tactics/g_rewrite.ml4 @@ -105,6 +105,12 @@ END let db_strat db = StratUnary ("topdown", StratHints (false, db)) let cl_rewrite_clause_db db = cl_rewrite_clause_strat (strategy_of_ast (db_strat db)) +let cl_rewrite_clause_db = + if Flags.profile then + let key = Profile.declare_profile "cl_rewrite_clause_db" in + Profile.profile3 key cl_rewrite_clause_db + else cl_rewrite_clause_db + TACTIC EXTEND rewrite_strat | [ "rewrite_strat" rewstrategy(s) "in" hyp(id) ] -> [ Proofview.V82.tactic (cl_rewrite_clause_strat s (Some id)) ] | [ "rewrite_strat" rewstrategy(s) ] -> [ Proofview.V82.tactic (cl_rewrite_clause_strat s None) ] @@ -140,21 +146,21 @@ TACTIC EXTEND setoid_rewrite [ Proofview.V82.tactic (cl_rewrite_clause c o (occurrences_of occ) (Some id))] END -let cl_rewrite_clause_newtac_tac c o occ cl = - cl_rewrite_clause_newtac' c o occ cl - -TACTIC EXTEND GenRew -| [ "rew" orient(o) glob_constr_with_bindings(c) "in" hyp(id) "at" occurrences(occ) ] -> - [ cl_rewrite_clause_newtac_tac c o (occurrences_of occ) (Some id) ] -| [ "rew" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) "in" hyp(id) ] -> - [ cl_rewrite_clause_newtac_tac c o (occurrences_of occ) (Some id) ] -| [ "rew" orient(o) glob_constr_with_bindings(c) "in" hyp(id) ] -> - [ cl_rewrite_clause_newtac_tac c o AllOccurrences (Some id) ] -| [ "rew" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) ] -> - [ cl_rewrite_clause_newtac_tac c o (occurrences_of occ) None ] -| [ "rew" orient(o) glob_constr_with_bindings(c) ] -> - [ cl_rewrite_clause_newtac_tac c o AllOccurrences None ] -END +(* let cl_rewrite_clause_newtac_tac c o occ cl = *) +(* cl_rewrite_clause_newtac' c o occ cl *) + +(* TACTIC EXTEND GenRew *) +(* | [ "rew" orient(o) glob_constr_with_bindings(c) "in" hyp(id) "at" occurrences(occ) ] -> *) +(* [ cl_rewrite_clause_newtac_tac c o (occurrences_of occ) (Some id) ] *) +(* | [ "rew" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) "in" hyp(id) ] -> *) +(* [ cl_rewrite_clause_newtac_tac c o (occurrences_of occ) (Some id) ] *) +(* | [ "rew" orient(o) glob_constr_with_bindings(c) "in" hyp(id) ] -> *) +(* [ cl_rewrite_clause_newtac_tac c o AllOccurrences (Some id) ] *) +(* | [ "rew" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) ] -> *) +(* [ cl_rewrite_clause_newtac_tac c o (occurrences_of occ) None ] *) +(* | [ "rew" orient(o) glob_constr_with_bindings(c) ] -> *) +(* [ cl_rewrite_clause_newtac_tac c o AllOccurrences None ] *) +(* END *) VERNAC COMMAND EXTEND AddRelation CLASSIFIED AS SIDEFF | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) diff --git a/tactics/hipattern.ml4 b/tactics/hipattern.ml4 index 89aaee485..130e66720 100644 --- a/tactics/hipattern.ml4 +++ b/tactics/hipattern.ml4 @@ -47,7 +47,7 @@ let match_with_non_recursive_type t = | App _ -> let (hdapp,args) = decompose_app t in (match kind_of_term hdapp with - | Ind ind -> + | Ind (ind,u) -> if not (Global.lookup_mind (fst ind)).mind_finite then Some (hdapp,args) else @@ -90,9 +90,9 @@ let match_with_one_constructor style onlybinary allow_rec t = let (hdapp,args) = decompose_app t in let res = match kind_of_term hdapp with | Ind ind -> - let (mib,mip) = Global.lookup_inductive ind in + let (mib,mip) = Global.lookup_inductive (fst ind) in if Int.equal (Array.length mip.mind_consnames) 1 - && (allow_rec || not (mis_is_recursive (ind,mib,mip))) + && (allow_rec || not (mis_is_recursive (fst ind,mib,mip))) && (Int.equal mip.mind_nrealargs 0) then if is_strict_conjunction style (* strict conjunction *) then @@ -137,8 +137,8 @@ let match_with_tuple t = let t = match_with_one_constructor None false true t in Option.map (fun (hd,l) -> let ind = destInd hd in - let (mib,mip) = Global.lookup_inductive ind in - let isrec = mis_is_recursive (ind,mib,mip) in + let (mib,mip) = Global.lookup_pinductive ind in + let isrec = mis_is_recursive (fst ind,mib,mip) in (hd,l,isrec)) t let is_tuple t = @@ -158,7 +158,7 @@ let test_strict_disjunction n lc = let match_with_disjunction ?(strict=false) ?(onlybinary=false) t = let (hdapp,args) = decompose_app t in let res = match kind_of_term hdapp with - | Ind ind -> + | Ind (ind,u) -> let car = mis_constr_nargs ind in let (mib,mip) = Global.lookup_inductive ind in if Array.for_all (fun ar -> Int.equal ar 1) car @@ -193,7 +193,7 @@ let match_with_empty_type t = let (hdapp,args) = decompose_app t in match (kind_of_term hdapp) with | Ind ind -> - let (mib,mip) = Global.lookup_inductive ind in + let (mib,mip) = Global.lookup_pinductive ind in let nconstr = Array.length mip.mind_consnames in if Int.equal nconstr 0 then Some hdapp else None | _ -> None @@ -207,7 +207,7 @@ let match_with_unit_or_eq_type t = let (hdapp,args) = decompose_app t in match (kind_of_term hdapp) with | Ind ind -> - let (mib,mip) = Global.lookup_inductive ind in + let (mib,mip) = Global.lookup_pinductive ind in let constr_types = mip.mind_nf_lc in let nconstr = Array.length mip.mind_consnames in let zero_args c = Int.equal (nb_prod c) mib.mind_nparams in @@ -249,7 +249,7 @@ let match_with_equation t = if not (isApp t) then raise NoEquationFound; let (hdapp,args) = destApp t in match kind_of_term hdapp with - | Ind ind -> + | Ind (ind,u) -> if eq_gr (IndRef ind) glob_eq then Some (build_coq_eq_data()),hdapp, PolymorphicLeibnizEq(args.(0),args.(1),args.(2)) @@ -282,7 +282,7 @@ let is_inductive_equality ind = let match_with_equality_type t = let (hdapp,args) = decompose_app t in match (kind_of_term hdapp) with - | Ind ind when is_inductive_equality ind -> Some (hdapp,args) + | Ind (ind,_) when is_inductive_equality ind -> Some (hdapp,args) | _ -> None let is_equality_type t = op2bool (match_with_equality_type t) @@ -322,7 +322,7 @@ let match_with_nodep_ind t = let (hdapp,args) = decompose_app t in match (kind_of_term hdapp) with | Ind ind -> - let (mib,mip) = Global.lookup_inductive ind in + let (mib,mip) = Global.lookup_pinductive ind in if Array.length (mib.mind_packets)>1 then None else let nodep_constr = has_nodep_prod_after mib.mind_nparams in if Array.for_all nodep_constr mip.mind_nf_lc then @@ -340,7 +340,7 @@ let match_with_sigma_type t= let (hdapp,args) = decompose_app t in match (kind_of_term hdapp) with | Ind ind -> - let (mib,mip) = Global.lookup_inductive ind in + let (mib,mip) = Global.lookup_pinductive ind in if Int.equal (Array.length (mib.mind_packets)) 1 && (Int.equal mip.mind_nrealargs 0) && (Int.equal (Array.length mip.mind_consnames)1) && @@ -378,7 +378,7 @@ let match_eq eqn eq_pat = match Id.Map.bindings (matches pat eqn) with | [(m1,t);(m2,x);(m3,y)] -> assert (Id.equal m1 meta1 && Id.equal m2 meta2 && Id.equal m3 meta3); - PolymorphicLeibnizEq (t,x,y) + PolymorphicLeibnizEq (t,x,y) | [(m1,t);(m2,x);(m3,t');(m4,x')] -> assert (Id.equal m1 meta1 && Id.equal m2 meta2 && Id.equal m3 meta3 && Id.equal m4 meta4); HeterogenousEq (t,x,t',x') @@ -387,13 +387,21 @@ let match_eq eqn eq_pat = let no_check () = true let check_jmeq_loaded () = Library.library_is_loaded Coqlib.jmeq_module +let build_coq_jmeq_data_in env = + build_coq_jmeq_data (), Univ.ContextSet.empty + +let build_coq_identity_data_in env = + build_coq_identity_data (), Univ.ContextSet.empty + let equalities = [coq_eq_pattern, no_check, build_coq_eq_data; coq_jmeq_pattern, check_jmeq_loaded, build_coq_jmeq_data; coq_identity_pattern, no_check, build_coq_identity_data] let find_eq_data eqn = (* fails with PatternMatchingFailure *) - first_match (match_eq eqn) equalities + let d,k = first_match (match_eq eqn) equalities in + let hd,u = destInd (fst (destApp eqn)) in + d,u,k let extract_eq_args gl = function | MonomorphicLeibnizEq (e1,e2) -> @@ -404,11 +412,11 @@ let extract_eq_args gl = function else raise PatternMatchingFailure let find_eq_data_decompose gl eqn = - let (lbeq,eq_args) = find_eq_data eqn in - (lbeq,extract_eq_args gl eq_args) + let (lbeq,u,eq_args) = find_eq_data eqn in + (lbeq,u,extract_eq_args gl eq_args) let find_this_eq_data_decompose gl eqn = - let (lbeq,eq_args) = + let (lbeq,u,eq_args) = try (*first_match (match_eq eqn) inversible_equalities*) find_eq_data eqn with PatternMatchingFailure -> @@ -417,7 +425,7 @@ let find_this_eq_data_decompose gl eqn = try extract_eq_args gl eq_args with PatternMatchingFailure -> error "Don't know what to do with JMeq on arguments not of same type." in - (lbeq,eq_args) + (lbeq,u,eq_args) let match_eq_nf gls eqn eq_pat = match Id.Map.bindings (pf_matches gls (Lazy.force eq_pat) eqn) with @@ -439,18 +447,16 @@ let coq_ex_pattern_gen ex = lazy PATTERN [ %ex ?X1 ?X2 ?X3 ?X4 ] let coq_existT_pattern = coq_ex_pattern_gen coq_existT_ref let coq_exist_pattern = coq_ex_pattern_gen coq_exist_ref -let match_sigma ex ex_pat = - match Id.Map.bindings (matches (Lazy.force ex_pat) ex) with - | [(m1,a);(m2,p);(m3,car);(m4,cdr)] -> - assert (Id.equal m1 meta1 && Id.equal m2 meta2 && Id.equal m3 meta3 && Id.equal m4 meta4); - (a,p,car,cdr) - | _ -> - anomaly ~label:"match_sigma" (Pp.str "a successful sigma pattern should match 4 terms") - +let match_sigma ex = + match kind_of_term ex with + | App (f, [| a; p; car; cdr |]) when is_global (Lazy.force coq_exist_ref) f -> + build_sigma (), (snd (destConstruct f), a, p, car, cdr) + | App (f, [| a; p; car; cdr |]) when is_global (Lazy.force coq_existT_ref) f -> + build_sigma_type (), (snd (destConstruct f), a, p, car, cdr) + | _ -> raise PatternMatchingFailure + let find_sigma_data_decompose ex = (* fails with PatternMatchingFailure *) - first_match (match_sigma ex) - [coq_existT_pattern, no_check, build_sigma_type; - coq_exist_pattern, no_check, build_sigma] + match_sigma ex (* Pattern "(sig ?1 ?2)" *) let coq_sig_pattern = lazy PATTERN [ %coq_sig_ref ?X1 ?X2 ] @@ -495,7 +501,7 @@ let match_eqdec t = false,op_or,matches (Lazy.force coq_eqdec_rev_pattern) t in match Id.Map.bindings subst with | [(_,typ);(_,c1);(_,c2)] -> - eqonleft, Globnames.constr_of_global (Lazy.force op), c1, c2, typ + eqonleft, Universes.constr_of_global (Lazy.force op), c1, c2, typ | _ -> anomaly (Pp.str "Unexpected pattern") (* Patterns "~ ?" and "? -> False" *) diff --git a/tactics/hipattern.mli b/tactics/hipattern.mli index fc87fc9ed..3637be41d 100644 --- a/tactics/hipattern.mli +++ b/tactics/hipattern.mli @@ -121,19 +121,19 @@ val match_with_equation: (** Match terms [eq A t u], [identity A t u] or [JMeq A t A u] Returns associated lemmas and [A,t,u] or fails PatternMatchingFailure *) val find_eq_data_decompose : 'a Proofview.Goal.t -> constr -> - coq_eq_data * (types * constr * constr) + coq_eq_data * Univ.universe_instance * (types * constr * constr) (** Idem but fails with an error message instead of PatternMatchingFailure *) val find_this_eq_data_decompose : 'a Proofview.Goal.t -> constr -> - coq_eq_data * (types * constr * constr) + coq_eq_data * Univ.universe_instance * (types * constr * constr) (** A variant that returns more informative structure on the equality found *) -val find_eq_data : constr -> coq_eq_data * equation_kind +val find_eq_data : constr -> coq_eq_data * Univ.universe_instance * equation_kind (** Match a term of the form [(existT A P t p)] Returns associated lemmas and [A,P,t,p] *) val find_sigma_data_decompose : constr -> - coq_sigma_data * (constr * constr * constr * constr) + coq_sigma_data * (Univ.universe_instance * constr * constr * constr * constr) (** Match a term of the form [{x:A|P}], returns [A] and [P] *) val match_sigma : constr -> constr * constr diff --git a/tactics/inv.ml b/tactics/inv.ml index 0c0bcc06a..0ff6b69a5 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -67,7 +67,7 @@ type inversion_status = Dep of constr option | NoDep let compute_eqn env sigma n i ai = (mkRel (n-i),get_type_of env sigma (mkRel (n-i))) -let make_inv_predicate env sigma indf realargs id status concl = +let make_inv_predicate env evd indf realargs id status concl = let nrealargs = List.length realargs in let (hyps,concl) = match status with @@ -86,11 +86,12 @@ let make_inv_predicate env sigma indf realargs id status concl = match dflt_concl with | Some concl -> concl (*assumed it's some [x1..xn,H:I(x1..xn)]C*) | None -> - let sort = get_sort_family_of env sigma concl in - let p = make_arity env true indf (new_sort_in_family sort) in - fst (Unification.abstract_list_all env - (Evd.create_evar_defs sigma) - p concl (realargs@[mkVar id])) in + let sort = get_sort_family_of env !evd concl in + let sort = Evarutil.evd_comb1 (Evd.fresh_sort_in_family env) evd sort in + let p = make_arity env true indf sort in + let evd',(p,ptyp) = Unification.abstract_list_all env + !evd p concl (realargs@[mkVar id]) + in evd := evd'; p in let hyps,bodypred = decompose_lam_n_assum (nrealargs+1) pred in (* We lift to make room for the equations *) (hyps,lift nrealargs bodypred) @@ -102,21 +103,25 @@ let make_inv_predicate env sigma indf realargs id status concl = (* Now, we can recurse down this list, for each ai,(mkRel k) whether to push <Ai>(mkRel k)=ai (when Ai is closed). In any case, we carry along the rest of pairs *) + let eqdata = Coqlib.build_coq_eq_data () in let rec build_concl eqns args n = function | [] -> it_mkProd concl eqns, Array.rev_of_list args | ai :: restlist -> let ai = lift nhyps ai in - let (xi, ti) = compute_eqn env' sigma nhyps n ai in + let (xi, ti) = compute_eqn env' !evd nhyps n ai in let (lhs,eqnty,rhs) = if closed0 ti then (xi,ti,ai) else - make_iterated_tuple env' sigma ai (xi,ti) + let sigma, res = make_iterated_tuple env' !evd ai (xi,ti) in + evd := sigma; res in - let eq_term = Coqlib.build_coq_eq () in - let eqn = applist (eq_term ,[eqnty;lhs;rhs]) in + let eq_term = eqdata.Coqlib.eq in + let eq = Evarutil.evd_comb1 (Evd.fresh_global env) evd eq_term in + let eqn = applist (eq,[eqnty;lhs;rhs]) in let eqns = (Anonymous, lift n eqn) :: eqns in - let refl_term = Coqlib.build_coq_eq_refl () in + let refl_term = eqdata.Coqlib.refl in + let refl_term = Evarutil.evd_comb1 (Evd.fresh_global env) evd refl_term in let refl = mkApp (refl_term, [|eqnty; rhs|]) in let args = refl :: args in build_concl eqns args (succ n) restlist @@ -455,8 +460,10 @@ let raw_inversion inv_kind id status names = Errors.errorlabstrm "" msg in let IndType (indf,realargs) = find_rectype env sigma t in + let evdref = ref sigma in let (elim_predicate, args) = - make_inv_predicate env sigma indf realargs id status concl in + make_inv_predicate env evdref indf realargs id status concl in + let sigma = !evdref in let (cut_concl,case_tac) = if status != NoDep && (dependent c concl) then Reduction.beta_appvect elim_predicate (Array.of_list (realargs@[c])), @@ -470,12 +477,13 @@ let raw_inversion inv_kind id status names = Proofview.Refine.refine (fun h -> h, prf) in let neqns = List.length realargs in - tclTHENS + tclTHEN (Proofview.V82.tclEVARS sigma) + (tclTHENS (assert_tac Anonymous cut_concl) [case_tac names (introCaseAssumsThen (rewrite_equations_tac inv_kind id neqns)) (Some elim_predicate) ind (c, t); - onLastHypId (fun id -> tclTHEN (refined id) reflexivity)] + onLastHypId (fun id -> tclTHEN (refined id) reflexivity)]) end (* Error messages of the inversion tactics *) @@ -486,7 +494,7 @@ let wrap_inv_error id = function (strbrk "Inversion would require case analysis on sort " ++ pr_sort k ++ strbrk " which is not allowed for inductive definition " ++ - pr_inductive (Global.env()) i ++ str "."))) + pr_inductive (Global.env()) (fst i) ++ str "."))) | e -> Proofview.tclZERO e (* The most general inversion tactic *) diff --git a/tactics/leminv.ml b/tactics/leminv.ml index 5e5de2589..23a7c9e53 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -194,7 +194,7 @@ let inversion_scheme env sigma t sort dep_option inv_op = errorlabstrm "lemma_inversion" (str"Computed inversion goal was not closed in initial signature."); *) - let pf = Proof.start Evd.empty [invEnv,invGoal] in + let pf = Proof.start Evd.empty [invEnv,(invGoal,get_universe_context_set sigma)] in let pf = fst (Proof.run_tactic env ( tclTHEN intro (onLastHypId inv_op)) pf) @@ -232,6 +232,9 @@ let add_inversion_lemma name env sigma t sort dep inv_op = const_entry_body = Future.from_val (invProof,Declareops.no_seff); const_entry_secctx = None; const_entry_type = None; + const_entry_proj = None; + const_entry_polymorphic = true; + const_entry_universes = Univ.UContext.empty (*FIXME *); const_entry_opaque = false; const_entry_inline_code = false; const_entry_feedback = None; @@ -244,8 +247,9 @@ let add_inversion_lemma name env sigma t sort dep inv_op = let add_inversion_lemma_exn na com comsort bool tac = let env = Global.env () and sigma = Evd.empty in - let c = Constrintern.interp_type sigma env com in - let sort = Pretyping.interp_sort comsort in + let c,ctx = Constrintern.interp_type sigma env com in + let sigma = Evd.merge_context_set Evd.univ_rigid sigma ctx in + let sigma, sort = Pretyping.interp_sort sigma comsort in try add_inversion_lemma na env sigma c sort bool tac with @@ -260,7 +264,7 @@ let lemInv id c gls = try let clause = mk_clenv_type_of gls c in let clause = clenv_constrain_last_binding (mkVar id) clause in - Clenvtac.res_pf clause ~flags:Unification.elim_flags gls + Clenvtac.res_pf clause ~flags:(Unification.elim_flags ()) gls with | NoSuchBinding -> errorlabstrm "" diff --git a/tactics/nbtermdn.ml b/tactics/nbtermdn.ml new file mode 100644 index 000000000..b07aff99b --- /dev/null +++ b/tactics/nbtermdn.ml @@ -0,0 +1,131 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Util +open Names +open Term +open Pattern +open Globnames + +(* Named, bounded-depth, term-discrimination nets. + Implementation: + Term-patterns are stored in discrimination-nets, which are + themselves stored in a hash-table, indexed by the first label. + They are also stored by name in a table on-the-side, so that we can + override them if needed. *) + +(* The former comments are from Chet. + See the module dn.ml for further explanations. + Eduardo (5/8/97) *) +module Make = + functor (Y:Map.OrderedType) -> +struct + module X = struct + type t = constr_pattern*int + let compare = Pervasives.compare + end + + module Term_dn = Termdn.Make(Y) + open Term_dn + module Z = struct + type t = Term_dn.term_label + let compare x y = + let make_name n = + match n with + | GRLabel(ConstRef con) -> + GRLabel(ConstRef(constant_of_kn(canonical_con con))) + | GRLabel(IndRef (kn,i)) -> + GRLabel(IndRef(mind_of_kn(canonical_mind kn),i)) + | GRLabel(ConstructRef ((kn,i),j ))-> + GRLabel(ConstructRef((mind_of_kn(canonical_mind kn),i),j)) + | k -> k + in + Pervasives.compare (make_name x) (make_name y) + end + + module Dn = Dn.Make(X)(Z)(Y) + module Bounded_net = Btermdn.Make(Y) + + +type 'na t = { + mutable table : ('na,constr_pattern * Y.t) Gmap.t; + mutable patterns : (Term_dn.term_label option,Bounded_net.t) Gmap.t } + + +type 'na frozen_t = + ('na,constr_pattern * Y.t) Gmap.t + * (Term_dn.term_label option, Bounded_net.t) Gmap.t + +let create () = + { table = Gmap.empty; + patterns = Gmap.empty } + +let get_dn dnm hkey = + try Gmap.find hkey dnm with Not_found -> Bounded_net.create () + +let add dn (na,(pat,valu)) = + let hkey = Option.map fst (Term_dn.constr_pat_discr pat) in + dn.table <- Gmap.add na (pat,valu) dn.table; + let dnm = dn.patterns in + dn.patterns <- Gmap.add hkey (Bounded_net.add None (get_dn dnm hkey) (pat,valu)) dnm + +let rmv dn na = + let (pat,valu) = Gmap.find na dn.table in + let hkey = Option.map fst (Term_dn.constr_pat_discr pat) in + dn.table <- Gmap.remove na dn.table; + let dnm = dn.patterns in + dn.patterns <- Gmap.add hkey (Bounded_net.rmv None (get_dn dnm hkey) (pat,valu)) dnm + +let in_dn dn na = Gmap.mem na dn.table + +let remap ndn na (pat,valu) = + rmv ndn na; + add ndn (na,(pat,valu)) + +let decomp = + let rec decrec acc c = match kind_of_term c with + | App (f,l) -> decrec (Array.fold_right (fun a l -> a::l) l acc) f + | Cast (c1,_,_) -> decrec acc c1 + | _ -> (c,acc) + in + decrec [] + + let constr_val_discr t = + let c, l = decomp t in + match kind_of_term c with + | Ind (ind_sp,_) -> Dn.Label(Term_dn.GRLabel (IndRef ind_sp),l) + | Construct (cstr_sp,_) -> Dn.Label(Term_dn.GRLabel (ConstructRef cstr_sp),l) + | Var id -> Dn.Label(Term_dn.GRLabel (VarRef id),l) + | Const _ -> Dn.Everything + | _ -> Dn.Nothing + +let lookup dn valu = + let hkey = + match (constr_val_discr valu) with + | Dn.Label(l,_) -> Some l + | _ -> None + in + try Bounded_net.lookup None (Gmap.find hkey dn.patterns) valu with Not_found -> [] + +let app f dn = Gmap.iter f dn.table + +let dnet_depth = Btermdn.dnet_depth + +let freeze dn = (dn.table, dn.patterns) + +let unfreeze (fnm,fdnm) dn = + dn.table <- fnm; + dn.patterns <- fdnm + +let empty dn = + dn.table <- Gmap.empty; + dn.patterns <- Gmap.empty + +let to2lists dn = + (Gmap.to_list dn.table, Gmap.to_list dn.patterns) +end diff --git a/tactics/rewrite.ml b/tactics/rewrite.ml index ae73d7a41..83cb15f47 100644 --- a/tactics/rewrite.ml +++ b/tactics/rewrite.ml @@ -8,6 +8,8 @@ (*i camlp4deps: "grammar/grammar.cma" i*) +open Names +open Pp open Errors open Util open Nameops @@ -32,91 +34,86 @@ open Decl_kinds open Elimschemes open Goal open Environ -open Pp -open Names open Tacinterp open Termops +open Genarg +open Extraargs +open Pcoq.Constr open Entries open Libnames +open Evarutil (** Typeclass-based generalized rewriting. *) (** Constants used by the tactic. *) let classes_dirpath = - DirPath.make (List.map Id.of_string ["Classes";"Coq"]) + Names.DirPath.make (List.map Id.of_string ["Classes";"Coq"]) let init_setoid () = if is_dirpath_prefix_of classes_dirpath (Lib.cwd ()) then () else Coqlib.check_required_library ["Coq";"Setoids";"Setoid"] -let get_class str = - let qualid = Qualid (Loc.ghost, qualid_of_string str) in - lazy (class_info (Nametab.global qualid)) - -let proper_class = get_class "Coq.Classes.Morphisms.Proper" -let proper_proxy_class = get_class "Coq.Classes.Morphisms.ProperProxy" - -let proper_proj = lazy (mkConst (Option.get (pi3 (List.hd (Lazy.force proper_class).cl_projs)))) - let make_dir l = DirPath.make (List.rev_map Id.of_string l) let try_find_global_reference dir s = let sp = Libnames.make_path (make_dir ("Coq"::dir)) (Id.of_string s) in Nametab.global_of_path sp -let try_find_reference dir s = - constr_of_global (try_find_global_reference dir s) +let find_reference dir s = + let gr = lazy (try_find_global_reference dir s) in + fun () -> Lazy.force gr -let gen_constant dir s = Coqlib.gen_constant "rewrite" dir s -let coq_eq = lazy(gen_constant ["Init"; "Logic"] "eq") -let coq_f_equal = lazy (gen_constant ["Init"; "Logic"] "f_equal") -let coq_all = lazy (gen_constant ["Init"; "Logic"] "all") -let coq_forall = lazy (gen_constant ["Classes"; "Morphisms"] "forall_def") -let impl = lazy (gen_constant ["Program"; "Basics"] "impl") -let arrow = lazy (gen_constant ["Program"; "Basics"] "arrow") +type evars = evar_map * Evar.Set.t (* goal evars, constraint evars *) -let reflexive_type = lazy (try_find_reference ["Classes"; "RelationClasses"] "Reflexive") -let reflexive_proof = lazy (try_find_reference ["Classes"; "RelationClasses"] "reflexivity") +let find_global dir s = + let gr = lazy (try_find_global_reference dir s) in + fun (evd,cstrs) -> + let evd, c = Evarutil.new_global evd (Lazy.force gr) in + (evd, cstrs), c -let symmetric_type = lazy (try_find_reference ["Classes"; "RelationClasses"] "Symmetric") -let symmetric_proof = lazy (try_find_reference ["Classes"; "RelationClasses"] "symmetry") +(** Utility for dealing with polymorphic applications *) -let transitive_type = lazy (try_find_reference ["Classes"; "RelationClasses"] "Transitive") -let transitive_proof = lazy (try_find_reference ["Classes"; "RelationClasses"] "transitivity") +let app_poly evars f args = + let evars, fc = f evars in + evars, mkApp (fc, args) -let coq_inverse = lazy (gen_constant ["Program"; "Basics"] "flip") +let e_app_poly evars f args = + let evars', c = app_poly !evars f args in + evars := evars'; + c -let inverse car rel = mkApp (Lazy.force coq_inverse, [| car ; car; mkProp; rel |]) +(** Global constants. *) -let forall_relation = lazy (gen_constant ["Classes"; "Morphisms"] "forall_relation") -let pointwise_relation = lazy (gen_constant ["Classes"; "Morphisms"] "pointwise_relation") -let respectful = lazy (gen_constant ["Classes"; "Morphisms"] "respectful") -let default_relation = lazy (gen_constant ["Classes"; "SetoidTactics"] "DefaultRelation") -let subrelation = lazy (gen_constant ["Classes"; "RelationClasses"] "subrelation") -let do_subrelation = lazy (gen_constant ["Classes"; "Morphisms"] "do_subrelation") -let apply_subrelation = lazy (gen_constant ["Classes"; "Morphisms"] "apply_subrelation") -let coq_relation = lazy (gen_constant ["Relations";"Relation_Definitions"] "relation") -let mk_relation a = mkApp (Lazy.force coq_relation, [| a |]) -let rewrite_relation_class = lazy (gen_constant ["Classes"; "RelationClasses"] "RewriteRelation") +let gen_reference dir s = Coqlib.gen_reference "rewrite" dir s +let coq_eq_ref = find_reference ["Init"; "Logic"] "eq" +let coq_eq = find_global ["Init"; "Logic"] "eq" +let coq_f_equal = find_global ["Init"; "Logic"] "f_equal" +let coq_all = find_global ["Init"; "Logic"] "all" +let impl = find_global ["Program"; "Basics"] "impl" +let arrow = find_global ["Program"; "Basics"] "arrow" +let coq_inverse = find_global ["Program"; "Basics"] "flip" -let proper_type = lazy (constr_of_global (Lazy.force proper_class).cl_impl) -let proper_proxy_type = lazy (constr_of_global (Lazy.force proper_proxy_class).cl_impl) +(* let coq_inverse = lazy (gen_constant ["Program"; "Basics"] "flip") *) -(** Utility functions *) +(* let inverse car rel = mkApp (Lazy.force coq_inverse, [| car ; car; mkProp; rel |]) *) -let split_head = function - hd :: tl -> hd, tl - | [] -> assert(false) +(* let forall_relation = lazy (gen_constant ["Classes"; "Morphisms"] "forall_relation") *) +(* let pointwise_relation = lazy (gen_constant ["Classes"; "Morphisms"] "pointwise_relation") *) +(* let respectful = lazy (gen_constant ["Classes"; "Morphisms"] "respectful") *) +(* let default_relation = lazy (gen_constant ["Classes"; "SetoidTactics"] "DefaultRelation") *) +(* let subrelation = lazy (gen_constant ["Classes"; "RelationClasses"] "subrelation") *) +(* let do_subrelation = lazy (gen_constant ["Classes"; "Morphisms"] "do_subrelation") *) +(* let apply_subrelation = lazy (gen_constant ["Classes"; "Morphisms"] "apply_subrelation") *) +(* let coq_relation = lazy (gen_constant ["Relations";"Relation_Definitions"] "relation") *) +(* let mk_relation a = mkApp (Lazy.force coq_relation, [| a |]) *) -let evd_convertible env evd x y = - try ignore(Evarconv.the_conv_x env x y evd); true - with e when Errors.noncritical e -> false +(* let proper_type = lazy (Universes.constr_of_global (Lazy.force proper_class).cl_impl) *) +(* let proper_proxy_type = lazy (Universes.constr_of_global (Lazy.force proper_proxy_class).cl_impl) *) -let convertible env evd x y = - Reductionops.is_conv env evd x y -(** Bookkeeping which evars are constraints so that we can + +(** Bookkeeping which evars are constraints so that we can remove them at the end of the tactic. *) let goalevars evars = fst evars @@ -127,10 +124,17 @@ let new_cstr_evar (evd,cstrs) env t = (evd', Evar.Set.add (fst (destEvar t)) cstrs), t (** Building or looking up instances. *) +let e_new_cstr_evar evars env t = + let evd', t = new_cstr_evar !evars env t in evars := evd'; t + +let new_goal_evar (evd,cstrs) env t = + let evd', t = Evarutil.new_evar evd env t in + (evd', cstrs), t + +let e_new_goal_evar evars env t = + let evd', t = new_goal_evar !evars env t in evars := evd'; t -let proper_proof env evars carrier relation x = - let goal = mkApp (Lazy.force proper_proxy_type, [| carrier ; relation; x |]) - in new_cstr_evar evars env goal +(** Building or looking up instances. *) let extends_undefined evars evars' = let f ev evi found = found || not (Evd.mem evars ev) @@ -138,95 +142,328 @@ let extends_undefined evars evars' = let find_class_proof proof_type proof_method env evars carrier relation = try - let goal = mkApp (Lazy.force proof_type, [| carrier ; relation |]) in - let evars', c = Typeclasses.resolve_one_typeclass env evars goal in - if extends_undefined evars evars' then raise Not_found - else mkApp (Lazy.force proof_method, [| carrier; relation; c |]) + let evars, goal = app_poly evars proof_type [| carrier ; relation |] in + let evars', c = Typeclasses.resolve_one_typeclass env (goalevars evars) goal in + if extends_undefined (goalevars evars) evars' then raise Not_found + else app_poly (evars',cstrevars evars) proof_method [| carrier; relation; c |] with e when Logic.catchable_exception e -> raise Not_found + +(** Utility functions *) -let get_reflexive_proof env = find_class_proof reflexive_type reflexive_proof env -let get_symmetric_proof env = find_class_proof symmetric_type symmetric_proof env -let get_transitive_proof env = find_class_proof transitive_type transitive_proof env - -(** Build an infered signature from constraints on the arguments and expected output - relation *) - -let build_signature evars env m (cstrs : (types * types option) option list) - (finalcstr : (types * types option) option) = - let mk_relty evars newenv ty obj = - match obj with +module GlobalBindings (M : sig + val relation_classes : string list + val morphisms : string list + val relation : string list * string +end) = struct + open M + let relation : evars -> evars * constr = find_global (fst relation) (snd relation) + + let reflexive_type = find_global relation_classes "Reflexive" + let reflexive_proof = find_global relation_classes "reflexivity" + + let symmetric_type = find_global relation_classes "Symmetric" + let symmetric_proof = find_global relation_classes "symmetry" + + let transitive_type = find_global relation_classes "Transitive" + let transitive_proof = find_global relation_classes "transitivity" + + let forall_relation = find_global morphisms "forall_relation" + let pointwise_relation = find_global morphisms "pointwise_relation" + + let forall_relation_ref = find_reference morphisms "forall_relation" + let pointwise_relation_ref = find_reference morphisms "pointwise_relation" + + let respectful = find_global morphisms "respectful" + let respectful_ref = find_reference morphisms "respectful" + + let default_relation = find_global ["Classes"; "SetoidTactics"] "DefaultRelation" + + let coq_forall = find_global morphisms "forall_def" + + let subrelation = find_global relation_classes "subrelation" + let do_subrelation = find_global morphisms "do_subrelation" + let apply_subrelation = find_global morphisms "apply_subrelation" + + let rewrite_relation_class = find_global relation_classes "RewriteRelation" + + let proper_class = lazy (class_info (try_find_global_reference morphisms "Proper")) + let proper_proxy_class = lazy (class_info (try_find_global_reference morphisms "ProperProxy")) + + let proper_proj = lazy (mkConst (Option.get (pi3 (List.hd (Lazy.force proper_class).cl_projs)))) + + let proper_type = + let l = lazy (Lazy.force proper_class).cl_impl in + fun (evd,cstrs) -> + let evd, c = Evarutil.new_global evd (Lazy.force l) in + (evd, cstrs), c + + let proper_proxy_type = + let l = lazy (Lazy.force proper_proxy_class).cl_impl in + fun (evd,cstrs) -> + let evd, c = Evarutil.new_global evd (Lazy.force l) in + (evd, cstrs), c + + let proper_proof env evars carrier relation x = + let evars, goal = app_poly evars proper_proxy_type [| carrier ; relation; x |] in + new_cstr_evar evars env goal + + let get_reflexive_proof env = find_class_proof reflexive_type reflexive_proof env + let get_symmetric_proof env = find_class_proof symmetric_type symmetric_proof env + let get_transitive_proof env = find_class_proof transitive_type transitive_proof env + + let mk_relation evd a = + app_poly evd relation [| a |] + + (** Build an infered signature from constraints on the arguments and expected output + relation *) + + let build_signature evars env m (cstrs : (types * types option) option list) + (finalcstr : (types * types option) option) = + let mk_relty evars newenv ty obj = + match obj with | None | Some (_, None) -> - let relty = mk_relation ty in - if closed0 ty then - let env' = Environ.reset_with_named_context (Environ.named_context_val env) env in - new_cstr_evar evars env' relty - else new_cstr_evar evars newenv relty + let evars, relty = mk_relation evars ty in + if closed0 ty then + let env' = Environ.reset_with_named_context (Environ.named_context_val env) env in + new_cstr_evar evars env' relty + else new_cstr_evar evars newenv relty | Some (x, Some rel) -> evars, rel - in - let rec aux env evars ty l = - let t = Reductionops.whd_betadeltaiota env (fst evars) ty in - match kind_of_term t, l with - | Prod (na, ty, b), obj :: cstrs -> + in + let rec aux env evars ty l = + let t = Reductionops.whd_betadeltaiota env (goalevars evars) ty in + match kind_of_term t, l with + | Prod (na, ty, b), obj :: cstrs -> if noccurn 1 b (* non-dependent product *) then - let ty = Reductionops.nf_betaiota (fst evars) ty in + let ty = Reductionops.nf_betaiota (goalevars evars) ty in let (evars, b', arg, cstrs) = aux env evars (subst1 mkProp b) cstrs in let evars, relty = mk_relty evars env ty obj in - let newarg = mkApp (Lazy.force respectful, [| ty ; b' ; relty ; arg |]) in + let evars, newarg = app_poly evars respectful [| ty ; b' ; relty ; arg |] in evars, mkProd(na, ty, b), newarg, (ty, Some relty) :: cstrs else - let (evars, b, arg, cstrs) = aux (Environ.push_rel (na, None, ty) env) evars b cstrs in - let ty = Reductionops.nf_betaiota (fst evars) ty in + let (evars, b, arg, cstrs) = + aux (Environ.push_rel (na, None, ty) env) evars b cstrs + in + let ty = Reductionops.nf_betaiota (goalevars evars) ty in let pred = mkLambda (na, ty, b) in let liftarg = mkLambda (na, ty, arg) in - let arg' = mkApp (Lazy.force forall_relation, [| ty ; pred ; liftarg |]) in + let evars, arg' = app_poly evars forall_relation [| ty ; pred ; liftarg |] in if Option.is_empty obj then evars, mkProd(na, ty, b), arg', (ty, None) :: cstrs else error "build_signature: no constraint can apply on a dependent argument" - | _, obj :: _ -> anomaly ~label:"build_signature" (Pp.str "not enough products") - | _, [] -> + | _, obj :: _ -> anomaly ~label:"build_signature" (Pp.str "not enough products") + | _, [] -> (match finalcstr with | None | Some (_, None) -> - let t = Reductionops.nf_betaiota (fst evars) ty in - let evars, rel = mk_relty evars env t None in - evars, t, rel, [t, Some rel] + let t = Reductionops.nf_betaiota (fst evars) ty in + let evars, rel = mk_relty evars env t None in + evars, t, rel, [t, Some rel] | Some (t, Some rel) -> evars, t, rel, [t, Some rel]) - in aux env evars m cstrs + in aux env evars m cstrs -type hypinfo = { - cl : clausenv; - ext : Evar.Set.t; (* New evars in this clausenv *) - prf : constr; - car : constr; - rel : constr; - c1 : constr; - c2 : constr; - c : (Tacinterp.interp_sign * Tacexpr.glob_constr_and_expr with_bindings) option; - abs : bool; -} + (** Folding/unfolding of the tactic constants. *) + + let unfold_impl t = + match kind_of_term t with + | App (arrow, [| a; b |])(* when eq_constr arrow (Lazy.force impl) *) -> + mkProd (Anonymous, a, lift 1 b) + | _ -> assert false + + let unfold_all t = + match kind_of_term t with + | App (id, [| a; b |]) (* when eq_constr id (Lazy.force coq_all) *) -> + (match kind_of_term b with + | Lambda (n, ty, b) -> mkProd (n, ty, b) + | _ -> assert false) + | _ -> assert false + + let unfold_forall t = + match kind_of_term t with + | App (id, [| a; b |]) (* when eq_constr id (Lazy.force coq_all) *) -> + (match kind_of_term b with + | Lambda (n, ty, b) -> mkProd (n, ty, b) + | _ -> assert false) + | _ -> assert false + + let arrow_morphism evd ta tb a b = + let ap = is_Prop ta and bp = is_Prop tb in + if ap && bp then app_poly evd impl [| a; b |], unfold_impl + else if ap then (* Domain in Prop, CoDomain in Type *) + (evd, mkProd (Anonymous, a, b)), (fun x -> x) + else if bp then (* Dummy forall *) + (app_poly evd coq_all [| a; mkLambda (Anonymous, a, b) |]), unfold_forall + else (* None in Prop, use arrow *) + (app_poly evd arrow [| a; b |]), unfold_impl + + let rec decomp_pointwise n c = + if Int.equal n 0 then c + else + match kind_of_term c with + | App (f, [| a; b; relb |]) when Globnames.is_global (pointwise_relation_ref ()) f -> + decomp_pointwise (pred n) relb + | App (f, [| a; b; arelb |]) when Globnames.is_global (forall_relation_ref ()) f -> + decomp_pointwise (pred n) (Reductionops.beta_applist (arelb, [mkRel 1])) + | _ -> invalid_arg "decomp_pointwise" + + let rec apply_pointwise rel = function + | arg :: args -> + (match kind_of_term rel with + | App (f, [| a; b; relb |]) when Globnames.is_global (pointwise_relation_ref ()) f -> + apply_pointwise relb args + | App (f, [| a; b; arelb |]) when Globnames.is_global (forall_relation_ref ()) f -> + apply_pointwise (Reductionops.beta_applist (arelb, [arg])) args + | _ -> invalid_arg "apply_pointwise") + | [] -> rel + + let pointwise_or_dep_relation evd n t car rel = + if noccurn 1 car && noccurn 1 rel then + app_poly evd pointwise_relation [| t; lift (-1) car; lift (-1) rel |] + else + app_poly evd forall_relation + [| t; mkLambda (n, t, car); mkLambda (n, t, rel) |] + + let lift_cstr env evars (args : constr list) c ty cstr = + let start evars env car = + match cstr with + | None | Some (_, None) -> + let evars, rel = mk_relation evars car in + new_cstr_evar evars env rel + | Some (ty, Some rel) -> evars, rel + in + let rec aux evars env prod n = + if Int.equal n 0 then start evars env prod + else + match kind_of_term (Reduction.whd_betadeltaiota env prod) with + | Prod (na, ty, b) -> + if noccurn 1 b then + let b' = lift (-1) b in + let evars, rb = aux evars env b' (pred n) in + app_poly evars pointwise_relation [| ty; b'; rb |] + else + let evars, rb = aux evars (Environ.push_rel (na, None, ty) env) b (pred n) in + app_poly evars forall_relation + [| ty; mkLambda (na, ty, b); mkLambda (na, ty, rb) |] + | _ -> raise Not_found + in + let rec find env c ty = function + | [] -> None + | arg :: args -> + try let evars, found = aux evars env ty (succ (List.length args)) in + Some (evars, found, c, ty, arg :: args) + with Not_found -> + find env (mkApp (c, [| arg |])) (prod_applist ty [arg]) args + in find env c ty args + + let unlift_cstr env sigma = function + | None -> None + | Some codom -> Some (decomp_pointwise 1 codom) + +end + +(* let my_type_of env evars c = Typing.e_type_of env evars c *) +(* let mytypeofkey = Profile.declare_profile "my_type_of";; *) +(* let my_type_of = Profile.profile3 mytypeofkey my_type_of *) + + +let type_app_poly env evd f args = + let evars, c = app_poly evd f args in + let evd', t = Typing.e_type_of env (goalevars evars) c in + (evd', cstrevars evars), c + +module PropGlobal = struct + module Consts = + struct + let relation_classes = ["Classes"; "RelationClasses"] + let morphisms = ["Classes"; "Morphisms"] + let relation = ["Relations";"Relation_Definitions"], "relation" + end + + module G = GlobalBindings(Consts) + + include G + include Consts + let inverse env evd car rel = + type_app_poly env evd coq_inverse [| car ; car; mkProp; rel |] + (* app_poly evd coq_inverse [| car ; car; mkProp; rel |] *) + +end + +module TypeGlobal = struct + module Consts = + struct + let relation_classes = ["Classes"; "CRelationClasses"] + let morphisms = ["Classes"; "CMorphisms"] + let relation = relation_classes, "crelation" + end + + module G = GlobalBindings(Consts) + include G + + + let inverse env (evd,cstrs) car rel = + let evd, (sort,_) = Evarutil.new_type_evar Evd.univ_flexible evd env in + app_poly (evd,cstrs) coq_inverse [| car ; car; sort; rel |] + +end + +let sort_of_rel env evm rel = + Reductionops.sort_of_arity env evm (Retyping.get_type_of env evm rel) (** Looking up declared rewrite relations (instances of [RewriteRelation]) *) let is_applied_rewrite_relation env sigma rels t = match kind_of_term t with | App (c, args) when Array.length args >= 2 -> let head = if isApp c then fst (destApp c) else c in - if eq_constr (Lazy.force coq_eq) head then None + if Globnames.is_global (coq_eq_ref ()) head then None else (try let params, args = Array.chop (Array.length args - 2) args in let env' = Environ.push_rel_context rels env in - let evd, evar = Evarutil.new_evar sigma env' (new_Type ()) in - let inst = mkApp (Lazy.force rewrite_relation_class, [| evar; mkApp (c, params) |]) in - let _ = Typeclasses.resolve_one_typeclass env' evd inst in + let evars, (evar, _) = Evarutil.new_type_evar Evd.univ_flexible sigma env' in + let evars, inst = + app_poly (evars,Evar.Set.empty) + TypeGlobal.rewrite_relation_class [| evar; mkApp (c, params) |] in + let _ = Typeclasses.resolve_one_typeclass env' (goalevars evars) inst in Some (it_mkProd_or_LetIn t rels) with e when Errors.noncritical e -> None) | _ -> None -let rec decompose_app_rel env evd t = +(* let _ = *) +(* Hook.set Equality.is_applied_rewrite_relation is_applied_rewrite_relation *) + +let split_head = function + hd :: tl -> hd, tl + | [] -> assert(false) + +let evd_convertible env evd x y = + try ignore(Evarconv.the_conv_x env x y evd); true + with e when Errors.noncritical e -> false + +let convertible env evd x y = + Reductionops.is_conv env evd x y + +type hypinfo = { + cl : clausenv; + prf : constr; + car : constr; + rel : constr; + sort : bool; (* true = Prop; false = Type *) + l2r : bool; + c1 : constr; + c2 : constr; + c : (Tacinterp.interp_sign * Tacexpr.glob_constr_and_expr with_bindings) option; + abs : (constr * types) option; + flags : Unification.unify_flags; +} + +let get_symmetric_proof b = + if b then PropGlobal.get_symmetric_proof else TypeGlobal.get_symmetric_proof + +let rec decompose_app_rel env evd t = match kind_of_term t with - | App (f, args) -> - if Array.length args > 1 then + | App (f, args) -> + if Array.length args > 1 then let fargs, args = Array.chop (Array.length args - 2) args in mkApp (f, fargs), args - else + else let (f', args) = decompose_app_rel env evd args.(0) in let ty = Typing.type_of env evd args.(0) in let f'' = mkLambda (Name (Id.of_string "x"), ty, @@ -235,37 +472,46 @@ let rec decompose_app_rel env evd t = in (f'', args) | _ -> error "The term provided is not an applied relation." -let decompose_applied_relation env sigma orig (c,l) = - let ctype = Typing.type_of env sigma c in +let decompose_applied_relation env origsigma sigma flags orig (c,l) left2right = + let c' = c in + let ctype = Typing.type_of env sigma c' in let find_rel ty = - let eqclause = Clenv.make_clenv_binding_env_apply env sigma None (c, ty) l in + let eqclause = Clenv.make_clenv_binding_env_apply env sigma None (c',ty) l in let (equiv, args) = decompose_app_rel env eqclause.evd (Clenv.clenv_type eqclause) in - let c1 = args.(0) and c2 = args.(1) in + let c1 = args.(0) and c2 = args.(1) in let ty1, ty2 = Typing.type_of env eqclause.evd c1, Typing.type_of env eqclause.evd c2 in if not (evd_convertible env eqclause.evd ty1 ty2) then None else + let sort = sort_of_rel env eqclause.evd equiv in let value = Clenv.clenv_value eqclause in - let ext = Evarutil.evars_of_term value in - Some { cl=eqclause; ext=ext; prf=value; - car=ty1; rel = equiv; c1=c1; c2=c2; c=orig; abs=false; } + let eqclause = { eqclause with evd = Evd.diff eqclause.evd origsigma } in + Some { cl=eqclause; prf=value; + car=ty1; rel = equiv; sort = Sorts.is_prop sort; + l2r=left2right; c1=c1; c2=c2; c=orig; abs=None; + flags = flags } in match find_rel ctype with | Some c -> c | None -> - let ctx,t' = Reductionops.splay_prod_assum env sigma ctype in (* Search for underlying eq *) - match find_rel (it_mkProd_or_LetIn t' ctx) with + let ctx,t' = Reductionops.splay_prod env sigma ctype in (* Search for underlying eq *) + match find_rel (it_mkProd_or_LetIn t' (List.map (fun (n,t) -> n, None, t) ctx)) with | Some c -> c | None -> error "The term does not end with an applied homogeneous relation." -let decompose_applied_relation_expr env sigma (is, (c,l)) = - let sigma, cbl = Tacinterp.interp_open_constr_with_bindings is env sigma (c,l) in - decompose_applied_relation env sigma (Some (is, (c,l))) cbl +let decompose_applied_relation_expr env sigma flags (is, (c,l)) left2right = + let sigma', cbl = Tacinterp.interp_open_constr_with_bindings is env sigma (c,l) in + decompose_applied_relation env sigma sigma' flags (Some (is, (c,l))) cbl left2right + +let rewrite_db = "rewrite" -(** Hint database named "rewrite", now created directly in Auto *) +let conv_transparent_state = (Id.Pred.empty, Cpred.full) -let rewrite_db = Auto.rewrite_db +let _ = + Auto.add_auto_init + (fun () -> + Auto.create_hint_db false rewrite_db conv_transparent_state true) let rewrite_transparent_state () = Auto.Hint_db.transparent_state (Auto.searchtable_map rewrite_db) @@ -288,10 +534,10 @@ let rewrite_unif_flags = { } let rewrite2_unif_flags = - { Unification.modulo_conv_on_closed_terms = Some cst_full_transparent_state; + { Unification.modulo_conv_on_closed_terms = Some conv_transparent_state; Unification.use_metas_eagerly_in_conv_on_closed_terms = true; Unification.modulo_delta = empty_transparent_state; - Unification.modulo_delta_types = cst_full_transparent_state; + Unification.modulo_delta_types = conv_transparent_state; Unification.modulo_delta_in_merge = None; Unification.check_applied_meta_types = true; Unification.resolve_evars = false; @@ -304,7 +550,7 @@ let rewrite2_unif_flags = Unification.allow_K_in_toplevel_higher_order_unification = true } -let general_rewrite_unif_flags () = +let general_rewrite_unif_flags () = let ts = rewrite_transparent_state () in { Unification.modulo_conv_on_closed_terms = Some ts; Unification.use_metas_eagerly_in_conv_on_closed_terms = true; @@ -322,13 +568,14 @@ let general_rewrite_unif_flags () = Unification.allow_K_in_toplevel_higher_order_unification = true } let refresh_hypinfo env sigma hypinfo = - let {c=c} = hypinfo in + if Option.is_empty hypinfo.abs then + let {l2r=l2r; c=c;cl=cl;flags=flags} = hypinfo in match c with | Some c -> (* Refresh the clausenv to not get the same meta twice in the goal. *) - decompose_applied_relation_expr env sigma c + decompose_applied_relation_expr env sigma flags c l2r; | _ -> hypinfo - + else hypinfo let solve_remaining_by by env prf = match by with @@ -336,10 +583,10 @@ let solve_remaining_by by env prf = | Some tac -> let indep = clenv_independent env in let tac = eval_tactic tac in - let evd' = + let evd' = List.fold_right (fun mv evd -> let ty = Clenv.clenv_nf_meta env (meta_type evd mv) in - let c,_ = Pfedit.build_by_tactic env.env ty (Tacticals.New.tclCOMPLETE tac) in + let c,_,_ = Pfedit.build_by_tactic env.env (ty,Univ.ContextSet.empty) (Tacticals.New.tclCOMPLETE tac) in meta_assign mv (c, (Conv,TypeNotProcessed)) evd) indep env.evd in { env with evd = evd' }, prf @@ -352,35 +599,32 @@ let extend_evd sigma ext sigma' = let shrink_evd sigma ext = Evar.Set.fold (fun i acc -> Evd.remove acc i) ext sigma -let no_constraints cstrs = +let no_constraints cstrs = fun ev _ -> not (Evar.Set.mem ev cstrs) -let eq_env x y = x == y +let poly_inverse sort = + if sort then PropGlobal.inverse else TypeGlobal.inverse -let unify_eqn l2r flags env (sigma, cstrs) hypinfo by t = +let unify_eqn env (sigma, cstrs) hypinfo by t = if isEvar t then None else try - let hypinfo = - if hypinfo.abs || eq_env hypinfo.cl.env env then hypinfo - else refresh_hypinfo env sigma hypinfo - in - let {cl=cl; ext=ext; prf=prf; car=car; rel=rel; c1=c1; c2=c2; abs=abs} = - hypinfo in + let {cl=cl; prf=prf; car=car; rel=rel; l2r=l2r; c1=c1; c2=c2; c=c; abs=abs} = + !hypinfo in let left = if l2r then c1 else c2 in - let evd' = Evd.evars_reset_evd ~with_conv_pbs:true sigma cl.evd in - let evd'' = extend_evd evd' ext cl.evd in - let cl = { cl with evd = evd'' } in - let hypinfo, evd', prf, c1, c2, car, rel = - if abs then + let evd' = Evd.merge sigma cl.evd in + let cl = { cl with evd = evd' } in + let evd', prf, c1, c2, car, rel = + match abs with + | Some (absprf, absprfty) -> let env' = clenv_unify ~flags:rewrite_unif_flags CONV left t cl in - hypinfo, env'.evd, prf, c1, c2, car, rel - else - let env' = clenv_unify ~flags CONV left t cl in + env'.evd, prf, c1, c2, car, rel + | None -> + let env' = clenv_unify ~flags:!hypinfo.flags CONV left t cl in let env' = Clenvtac.clenv_pose_dependent_evars true env' in let evd' = Typeclasses.resolve_typeclasses ~filter:(no_constraints cstrs) ~fail:true env'.env env'.evd in let env' = { env' with evd = evd' } in - let env', prf = solve_remaining_by by env' (Clenv.clenv_value env') in + let env', prf = solve_remaining_by by env' (Clenv.clenv_value env') in let nf c = Evarutil.nf_evar env'.evd (Clenv.clenv_nf_meta env' c) in let c1 = nf c1 and c2 = nf c2 and car = nf car and rel = nf rel @@ -388,131 +632,41 @@ let unify_eqn l2r flags env (sigma, cstrs) hypinfo by t = let ty1 = Typing.type_of env'.env env'.evd c1 and ty2 = Typing.type_of env'.env env'.evd c2 in - if convertible env env'.evd ty1 ty2 then + if convertible env env'.evd ty1 ty2 then (if occur_meta_or_existential prf then - let hypinfo = refresh_hypinfo env env'.evd hypinfo in - (hypinfo, env'.evd, prf, c1, c2, car, rel) + (hypinfo := refresh_hypinfo env env'.evd !hypinfo; + env'.evd, prf, c1, c2, car, rel) else (** Evars have been solved, we can go back to the initial evd, but keep the potential refinement of existing evars. *) - let evd' = shrink_evd env'.evd ext in - (hypinfo, evd', prf, c1, c2, car, rel)) + env'.evd, prf, c1, c2, car, rel) else raise Reduction.NotConvertible in - let res = - if l2r then (prf, (car, rel, c1, c2)) + let evars = evd', Evar.Set.empty in + let evd, res = + if l2r then evars, (prf, (car, rel, c1, c2)) else - try (mkApp (get_symmetric_proof env evd' car rel, - [| c1 ; c2 ; prf |]), - (car, rel, c2, c1)) + try + let evars, symprf = get_symmetric_proof !hypinfo.sort env evars car rel in + evars, (mkApp (symprf, [| c1 ; c2 ; prf |]), + (car, rel, c2, c1)) with Not_found -> - (prf, (car, inverse car rel, c2, c1)) - in Some (hypinfo, evd', res) + let evars, rel' = poly_inverse !hypinfo.sort env evars car rel in + evars, (prf, (car, rel', c2, c1)) + in Some (evd, res) with e when Class_tactics.catchable e -> None -let unfold_impl t = - match kind_of_term t with - | App (arrow, [| a; b |])(* when eq_constr arrow (Lazy.force impl) *) -> - mkProd (Anonymous, a, lift 1 b) - | _ -> assert false - -let unfold_all t = - match kind_of_term t with - | App (id, [| a; b |]) (* when eq_constr id (Lazy.force coq_all) *) -> - (match kind_of_term b with - | Lambda (n, ty, b) -> mkProd (n, ty, b) - | _ -> assert false) - | _ -> assert false - -let unfold_forall t = - match kind_of_term t with - | App (id, [| a; b |]) (* when eq_constr id (Lazy.force coq_all) *) -> - (match kind_of_term b with - | Lambda (n, ty, b) -> mkProd (n, ty, b) - | _ -> assert false) - | _ -> assert false - -let arrow_morphism ta tb a b = - let ap = is_Prop ta and bp = is_Prop tb in - if ap && bp then mkApp (Lazy.force impl, [| a; b |]), unfold_impl - else if ap then (* Domain in Prop, CoDomain in Type *) - mkProd (Anonymous, a, b), (fun x -> x) - else if bp then (* Dummy forall *) - mkApp (Lazy.force coq_all, [| a; mkLambda (Anonymous, a, b) |]), unfold_forall - else (* None in Prop, use arrow *) - mkApp (Lazy.force arrow, [| a; b |]), unfold_impl - -let rec decomp_pointwise n c = - if Int.equal n 0 then c - else - match kind_of_term c with - | App (f, [| a; b; relb |]) when eq_constr f (Lazy.force pointwise_relation) -> - decomp_pointwise (pred n) relb - | App (f, [| a; b; arelb |]) when eq_constr f (Lazy.force forall_relation) -> - decomp_pointwise (pred n) (Reductionops.beta_applist (arelb, [mkRel 1])) - | _ -> invalid_arg "decomp_pointwise" - -let rec apply_pointwise rel = function - | arg :: args -> - (match kind_of_term rel with - | App (f, [| a; b; relb |]) when eq_constr f (Lazy.force pointwise_relation) -> - apply_pointwise relb args - | App (f, [| a; b; arelb |]) when eq_constr f (Lazy.force forall_relation) -> - apply_pointwise (Reductionops.beta_applist (arelb, [arg])) args - | _ -> invalid_arg "apply_pointwise") - | [] -> rel - -let pointwise_or_dep_relation n t car rel = - if noccurn 1 car && noccurn 1 rel then - mkApp (Lazy.force pointwise_relation, [| t; lift (-1) car; lift (-1) rel |]) - else - mkApp (Lazy.force forall_relation, - [| t; mkLambda (n, t, car); mkLambda (n, t, rel) |]) - -let lift_cstr env evars (args : constr list) c ty cstr = - let start evars env car = - match cstr with - | None | Some (_, None) -> - new_cstr_evar evars env (mk_relation car) - | Some (ty, Some rel) -> evars, rel - in - let rec aux evars env prod n = - if Int.equal n 0 then start evars env prod - else - match kind_of_term (Reduction.whd_betadeltaiota env prod) with - | Prod (na, ty, b) -> - if noccurn 1 b then - let b' = lift (-1) b in - let evars, rb = aux evars env b' (pred n) in - evars, mkApp (Lazy.force pointwise_relation, [| ty; b'; rb |]) - else - let evars, rb = aux evars (Environ.push_rel (na, None, ty) env) b (pred n) in - evars, mkApp (Lazy.force forall_relation, - [| ty; mkLambda (na, ty, b); mkLambda (na, ty, rb) |]) - | _ -> raise Not_found - in - let rec find env c ty = function - | [] -> None - | arg :: args -> - try let evars, found = aux evars env ty (succ (List.length args)) in - Some (evars, found, c, ty, arg :: args) - with Not_found -> - find env (mkApp (c, [| arg |])) (prod_applist ty [arg]) args - in find env c ty args - -let unlift_cstr env sigma = function - | None -> None - | Some codom -> Some (decomp_pointwise 1 codom) - type rewrite_flags = { under_lambdas : bool; on_morphisms : bool } let default_flags = { under_lambdas = true; on_morphisms = true; } -type evars = evar_map * Evar.Set.t (* goal evars, constraint evars *) - -type rewrite_proof = +type rewrite_proof = | RewPrf of constr * constr | RewCast of cast_kind +let map_rewprf f p = match p with + | RewPrf (x, y) -> RewPrf (f x, f y) + | RewCast _ -> p + let get_opt_rew_rel = function RewPrf (rel, prf) -> Some rel | _ -> None type rewrite_result_info = { @@ -523,34 +677,41 @@ type rewrite_result_info = { rew_evars : evars; } -type 'a rewrite_result = -| Fail -| Same -| Info of 'a +type rewrite_result = rewrite_result_info option -type 'a pure_strategy = 'a -> Environ.env -> Id.t list -> constr -> types -> - constr option -> evars -> 'a * rewrite_result_info rewrite_result +type strategy = Environ.env -> Id.t list -> constr -> types -> + (bool (* prop *) * constr option) -> evars -> rewrite_result option -type strategy = unit pure_strategy +let make_eq () = +(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq ()) +let make_eq_refl () = +(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq_refl ()) + +let get_rew_rel r = match r.rew_prf with + | RewPrf (rel, prf) -> rel + | RewCast c -> mkApp (make_eq (),[| r.rew_car; r.rew_from; r.rew_to |]) let get_rew_prf r = match r.rew_prf with - | RewPrf (rel, prf) -> rel, prf + | RewPrf (rel, prf) -> rel, prf | RewCast c -> - let rel = mkApp (Coqlib.build_coq_eq (), [| r.rew_car |]) in - rel, mkCast (mkApp (Coqlib.build_coq_eq_refl (), [| r.rew_car; r.rew_from |]), + let rel = mkApp (make_eq (), [| r.rew_car |]) in + rel, mkCast (mkApp (make_eq_refl (), [| r.rew_car; r.rew_from |]), c, mkApp (rel, [| r.rew_from; r.rew_to |])) -let resolve_subrelation env avoid car rel prf rel' res = +let poly_subrelation sort = + if sort then PropGlobal.subrelation else TypeGlobal.subrelation + +let resolve_subrelation env avoid car rel sort prf rel' res = if eq_constr rel rel' then res else - let app = mkApp (Lazy.force subrelation, [|car; rel; rel'|]) in - let evars, subrel = new_cstr_evar res.rew_evars env app in + let evars, app = app_poly res.rew_evars (poly_subrelation sort) [|car; rel; rel'|] in + let evars, subrel = new_cstr_evar evars env app in let appsub = mkApp (subrel, [| res.rew_from ; res.rew_to ; prf |]) in { res with rew_prf = RewPrf (rel', appsub); rew_evars = evars } -let resolve_morphism env avoid oldt m ?(fnewt=fun x -> x) args args' cstr evars = +let resolve_morphism env avoid oldt m ?(fnewt=fun x -> x) args args' (b,cstr) evars = let evars, morph_instance, proj, sigargs, m', args, args' = let first = match (Array.findi (fun _ b -> not (Option.is_empty b)) args') with | Some i -> i @@ -559,21 +720,23 @@ let resolve_morphism env avoid oldt m ?(fnewt=fun x -> x) args args' cstr evars let morphargs', morphobjs' = Array.chop first args' in let appm = mkApp(m, morphargs) in let appmtype = Typing.type_of env (goalevars evars) appm in - let cstrs = List.map - (Option.map (fun r -> r.rew_car, get_opt_rew_rel r.rew_prf)) - (Array.to_list morphobjs') + let cstrs = List.map + (Option.map (fun r -> r.rew_car, get_opt_rew_rel r.rew_prf)) + (Array.to_list morphobjs') in (* Desired signature *) - let evars, appmtype', signature, sigargs = - build_signature evars env appmtype cstrs cstr + let evars, appmtype', signature, sigargs = + if b then PropGlobal.build_signature evars env appmtype cstrs cstr + else TypeGlobal.build_signature evars env appmtype cstrs cstr in (* Actual signature found *) let cl_args = [| appmtype' ; signature ; appm |] in - let app = mkApp (Lazy.force proper_type, cl_args) in + let evars, app = app_poly evars (if b then PropGlobal.proper_type else TypeGlobal.proper_type) + cl_args in let env' = Environ.push_named - (Id.of_string "do_subrelation", - Some (Lazy.force do_subrelation), - Lazy.force apply_subrelation) + (Id.of_string "do_subrelation", + Some (snd (app_poly evars PropGlobal.do_subrelation [||])), + snd (app_poly evars PropGlobal.apply_subrelation [||])) env in let evars, morph = new_cstr_evar evars env' app in @@ -589,13 +752,15 @@ let resolve_morphism env avoid oldt m ?(fnewt=fun x -> x) args args' cstr evars and relation = substl subst relation in (match y with | None -> - let evars, proof = proper_proof env evars carrier relation x in + let evars, proof = + (if b then PropGlobal.proper_proof else TypeGlobal.proper_proof) + env evars carrier relation x in [ proof ; x ; x ] @ acc, subst, evars, sigargs, x :: typeargs' | Some r -> - [ snd (get_rew_prf r); r.rew_to; x ] @ acc, subst, evars, + [ snd (get_rew_prf r); r.rew_to; x ] @ acc, subst, evars, sigargs, r.rew_to :: typeargs') | None -> - if not (Option.is_empty y) then + if not (Option.is_empty y) then error "Cannot rewrite the argument of a dependent function"; x :: acc, x :: subst, evars, sigargs, x :: typeargs') ([], [], evars, sigargs, []) args args' @@ -607,66 +772,68 @@ let resolve_morphism env avoid oldt m ?(fnewt=fun x -> x) args args' cstr evars | _ -> assert(false) let apply_constraint env avoid car rel prf cstr res = - match cstr with + match snd cstr with | None -> res - | Some r -> resolve_subrelation env avoid car rel prf r res + | Some r -> resolve_subrelation env avoid car rel (fst cstr) prf r res + +let eq_env x y = x == y -let apply_rule l2r flags by loccs : (hypinfo * int) pure_strategy = +let apply_rule hypinfo by loccs : strategy = let (nowhere_except_in,occs) = convert_occs loccs in let is_occ occ = - if nowhere_except_in - then Int.List.mem occ occs - else not (Int.List.mem occ occs) - in - fun (hypinfo, occ) env avoid t ty cstr evars -> - let unif = unify_eqn l2r flags env evars hypinfo by t in - match unif with - | None -> ((hypinfo, occ), Fail) - | Some (hypinfo, evd', (prf, (car, rel, c1, c2))) -> - let occ = succ occ in - let res = - if not (is_occ occ) then Fail - else if eq_constr t c2 then Same - else - let res = { rew_car = ty; rew_from = c1; - rew_to = c2; rew_prf = RewPrf (rel, prf); - rew_evars = evd', cstrevars evars } - in Info (apply_constraint env avoid car rel prf cstr res) - in - ((hypinfo, occ), res) - -let apply_lemma l2r flags c by loccs : strategy = - fun () env avoid t ty cstr evars -> - let hypinfo = - decompose_applied_relation env (goalevars evars) None c + if nowhere_except_in then List.mem occ occs else not (List.mem occ occs) in + let occ = ref 0 in + fun env avoid t ty cstr evars -> + if not (eq_env !hypinfo.cl.env env) then + hypinfo := refresh_hypinfo env (goalevars evars) !hypinfo; + let unif = unify_eqn env evars hypinfo by t in + if not (Option.is_empty unif) then incr occ; + match unif with + | Some (evars', (prf, (car, rel, c1, c2))) when is_occ !occ -> + begin + if eq_constr t c2 then Some None + else + let res = { rew_car = ty; rew_from = c1; + rew_to = c2; rew_prf = RewPrf (rel, prf); + rew_evars = evars' } + in Some (Some (apply_constraint env avoid car rel prf cstr res)) + end + | _ -> None + +let apply_lemma flags (evm,c) left2right by loccs : strategy = + fun env avoid t ty cstr evars -> + let hypinfo = + let evars' = Evd.merge (goalevars evars) evm in + ref (decompose_applied_relation env (goalevars evars) evars' + flags None c left2right) in - let _, res = apply_rule l2r flags by loccs (hypinfo, 0) env avoid t ty cstr evars in - (), res + apply_rule hypinfo by loccs env avoid t ty cstr evars let make_leibniz_proof c ty r = - let prf = + let evars = ref r.rew_evars in + let prf = match r.rew_prf with - | RewPrf (rel, prf) -> - let rel = mkApp (Lazy.force coq_eq, [| ty |]) in + | RewPrf (rel, prf) -> + let rel = e_app_poly evars coq_eq [| ty |] in let prf = - mkApp (Lazy.force coq_f_equal, + e_app_poly evars coq_f_equal [| r.rew_car; ty; mkLambda (Anonymous, r.rew_car, c); - r.rew_from; r.rew_to; prf |]) + r.rew_from; r.rew_to; prf |] in RewPrf (rel, prf) | RewCast k -> r.rew_prf in - { r with rew_car = ty; + { rew_car = ty; rew_evars = !evars; rew_from = subst1 r.rew_from c; rew_to = subst1 r.rew_to c; rew_prf = prf } let reset_env env = let env' = Global.env_of_context (Environ.named_context_val env) in Environ.push_rel_context (Environ.rel_context env) env' - + let fold_match ?(force=false) env sigma c = let (ci, p, c, brs) = destCase c in let cty = Retyping.get_type_of env sigma c in - let dep, pred, exists, (sk, eff) = + let dep, pred, exists, (sk,eff) = let env', ctx, body = let ctx, pred = decompose_lam_assum p in let env' = Environ.push_rel_context ctx env in @@ -678,7 +845,7 @@ let fold_match ?(force=false) env sigma c = let pred = if dep then p else it_mkProd_or_LetIn (subst1 mkProp body) (List.tl ctx) in - let sk = + let sk = if sortp == InProp then if sortc == InProp then if dep then case_dep_scheme_kind_from_prop @@ -691,7 +858,7 @@ let fold_match ?(force=false) env sigma c = if dep then case_dep_scheme_kind_from_type else case_scheme_kind_from_type) - in + in let exists = Ind_tables.check_scheme sk ci.ci_ind in if exists || force then dep, pred, exists, Ind_tables.find_scheme sk ci.ci_ind @@ -702,108 +869,121 @@ let fold_match ?(force=false) env sigma c = let pars, args = List.chop ci.ci_npar args in let meths = List.map (fun br -> br) (Array.to_list brs) in applist (mkConst sk, pars @ [pred] @ meths @ args @ [c]) - in + in sk, (if exists then env else reset_env env), app, eff let unfold_match env sigma sk app = match kind_of_term app with - | App (f', args) when eq_constr f' (mkConst sk) -> - let v = Environ.constant_value (Global.env ()) sk in + | App (f', args) when eq_constant (fst (destConst f')) sk -> + let v = Environ.constant_value_in (Global.env ()) (sk,Univ.Instance.empty)(*FIXME*) in Reductionops.whd_beta sigma (mkApp (v, args)) | _ -> app let is_rew_cast = function RewCast _ -> true | _ -> false -let coerce env avoid cstr res = +let coerce env avoid cstr res = let rel, prf = get_rew_prf res in apply_constraint env avoid res.rew_car rel prf cstr res -let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = - let rec aux state env avoid t ty cstr evars = +let subterm all flags (s : strategy) : strategy = + let rec aux env avoid t ty (prop, cstr) evars = let cstr' = Option.map (fun c -> (ty, Some c)) cstr in match kind_of_term t with | App (m, args) -> - let rewrite_args state success = - let state, args', evars', progress = + let rewrite_args success = + let args', evars', progress = Array.fold_left - (fun (state, acc, evars, progress) arg -> - if not (Option.is_empty progress) && not all then (state, None :: acc, evars, progress) + (fun (acc, evars, progress) arg -> + if not (Option.is_empty progress) && not all then (None :: acc, evars, progress) else - let state, res = s state env avoid arg (Typing.type_of env (goalevars evars) arg) None evars in + let argty = Typing.type_of env (goalevars evars) arg in + let res = s env avoid arg argty (prop,None) evars in match res with - | Same -> (state, None :: acc, evars, if Option.is_empty progress then Some false else progress) - | Info r -> (state, Some r :: acc, r.rew_evars, Some true) - | Fail -> (state, None :: acc, evars, progress)) - (state, [], evars, success) args + | Some None -> (None :: acc, evars, + if Option.is_empty progress then Some false else progress) + | Some (Some r) -> + (Some r :: acc, r.rew_evars, Some true) + | None -> (None :: acc, evars, progress)) + ([], evars, success) args in - state, match progress with - | None -> Fail - | Some false -> Same + match progress with + | None -> None + | Some false -> Some None | Some true -> let args' = Array.of_list (List.rev args') in if Array.exists - (function - | None -> false + (function + | None -> false | Some r -> not (is_rew_cast r.rew_prf)) args' then - let evars', prf, car, rel, c1, c2 = resolve_morphism env avoid t m args args' cstr' evars' in + let evars', prf, car, rel, c1, c2 = + resolve_morphism env avoid t m args args' (prop, cstr') evars' + in let res = { rew_car = ty; rew_from = c1; rew_to = c2; rew_prf = RewPrf (rel, prf); - rew_evars = evars' } - in Info res - else + rew_evars = evars' } + in Some (Some res) + else let args' = Array.map2 (fun aorig anew -> match anew with None -> aorig - | Some r -> r.rew_to) args args' + | Some r -> r.rew_to) args args' in let res = { rew_car = ty; rew_from = t; rew_to = mkApp (m, args'); rew_prf = RewCast DEFAULTcast; rew_evars = evars' } - in Info res + in Some (Some res) in if flags.on_morphisms then let mty = Typing.type_of env (goalevars evars) m in - let evars, cstr', m, mty, argsl, args = + let evars, cstr', m, mty, argsl, args = let argsl = Array.to_list args in - match lift_cstr env evars argsl m mty None with - | Some (evars, cstr', m, mty, args) -> + let lift = if prop then PropGlobal.lift_cstr else TypeGlobal.lift_cstr in + match lift env evars argsl m mty None with + | Some (evars, cstr', m, mty, args) -> evars, Some cstr', m, mty, args, Array.of_list args | None -> evars, None, m, mty, argsl, args in - let state, m' = s state env avoid m mty cstr' evars in + let m' = s env avoid m mty (prop, cstr') evars in match m' with - | Fail -> rewrite_args state None (* Standard path, try rewrite on arguments *) - | Same -> rewrite_args state (Some false) - | Info r -> + | None -> rewrite_args None (* Standard path, try rewrite on arguments *) + | Some None -> rewrite_args (Some false) + | Some (Some r) -> (* We rewrote the function and get a proof of pointwise rel for the arguments. We just apply it. *) let prf = match r.rew_prf with | RewPrf (rel, prf) -> - RewPrf (apply_pointwise rel argsl, mkApp (prf, args)) + let app = if prop then PropGlobal.apply_pointwise + else TypeGlobal.apply_pointwise + in + RewPrf (app rel argsl, mkApp (prf, args)) | x -> x in let res = { rew_car = prod_appvect r.rew_car args; rew_from = mkApp(r.rew_from, args); rew_to = mkApp(r.rew_to, args); - rew_prf = prf; - rew_evars = r.rew_evars } - in - state, match prf with + rew_prf = prf; rew_evars = r.rew_evars } + in + match prf with | RewPrf (rel, prf) -> - Info (apply_constraint env avoid res.rew_car rel prf cstr res) - | RewCast _ -> Info res - else rewrite_args state None - + Some (Some (apply_constraint env avoid res.rew_car + rel prf (prop,cstr) res)) + | _ -> Some (Some res) + else rewrite_args None + | Prod (n, x, b) when noccurn 1 b -> let b = subst1 mkProp b in - let tx = Typing.type_of env (goalevars evars) x and tb = Typing.type_of env (goalevars evars) b in - let mor, unfold = arrow_morphism tx tb x b in - let state, res = aux state env avoid mor ty cstr evars in - state, (match res with - | Info r -> Info { r with rew_to = unfold r.rew_to } - | Fail | Same -> res) + let tx = Typing.type_of env (goalevars evars) x + and tb = Typing.type_of env (goalevars evars) b in + let arr = if prop then PropGlobal.arrow_morphism + else TypeGlobal.arrow_morphism + in + let (evars', mor), unfold = arr evars tx tb x b in + let res = aux env avoid mor ty (prop,cstr) evars' in + (match res with + | Some (Some r) -> Some (Some { r with rew_to = unfold r.rew_to }) + | _ -> res) (* if x' = None && flags.under_lambdas then *) (* let lam = mkLambda (n, x, b) in *) @@ -821,80 +1001,116 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = | Prod (n, dom, codom) -> let lam = mkLambda (n, dom, codom) in - let app, unfold = + let (evars', app), unfold = if eq_constr ty mkProp then - mkApp (Lazy.force coq_all, [| dom; lam |]), unfold_all - else mkApp (Lazy.force coq_forall, [| dom; lam |]), unfold_forall + (app_poly evars coq_all [| dom; lam |]), TypeGlobal.unfold_all + else + let forall = if prop then PropGlobal.coq_forall else TypeGlobal.coq_forall in + (app_poly evars forall [| dom; lam |]), TypeGlobal.unfold_forall in - let state, res = aux state env avoid app ty cstr evars in - state, (match res with - | Info r -> Info { r with rew_to = unfold r.rew_to } - | Fail | Same -> res) + let res = aux env avoid app ty (prop,cstr) evars' in + (match res with + | Some (Some r) -> Some (Some { r with rew_to = unfold r.rew_to }) + | _ -> res) + +(* TODO: real rewriting under binders: introduce x x' (H : R x x') and rewrite with + H at any occurrence of x. Ask for (R ==> R') for the lambda. Formalize this. + B. Barras' idea is to have a context of relations, of length 1, with Σ for gluing + dependent relations and using projections to get them out. + *) + (* | Lambda (n, t, b) when flags.under_lambdas -> *) + (* let n' = name_app (fun id -> Tactics.fresh_id_in_env avoid id env) n in *) + (* let n'' = name_app (fun id -> Tactics.fresh_id_in_env avoid id env) n' in *) + (* let n''' = name_app (fun id -> Tactics.fresh_id_in_env avoid id env) n'' in *) + (* let rel = new_cstr_evar cstr env (mkApp (Lazy.force coq_relation, [|t|])) in *) + (* let env' = Environ.push_rel_context [(n'',None,lift 2 rel);(n'',None,lift 1 t);(n', None, t)] env in *) + (* let b' = s env' avoid b (Typing.type_of env' (goalevars evars) (lift 2 b)) (unlift_cstr env (goalevars evars) cstr) evars in *) + (* (match b' with *) + (* | Some (Some r) -> *) + (* let prf = match r.rew_prf with *) + (* | RewPrf (rel, prf) -> *) + (* let rel = pointwise_or_dep_relation n' t r.rew_car rel in *) + (* let prf = mkLambda (n', t, prf) in *) + (* RewPrf (rel, prf) *) + (* | x -> x *) + (* in *) + (* Some (Some { r with *) + (* rew_prf = prf; *) + (* rew_car = mkProd (n, t, r.rew_car); *) + (* rew_from = mkLambda(n, t, r.rew_from); *) + (* rew_to = mkLambda (n, t, r.rew_to) }) *) + (* | _ -> b') *) | Lambda (n, t, b) when flags.under_lambdas -> - let n' = name_app (fun id -> Tactics.fresh_id_in_env avoid id env) n in - let env' = Environ.push_rel (n', None, t) env in - let state, b' = s state env' avoid b (Typing.type_of env' (goalevars evars) b) (unlift_cstr env (goalevars evars) cstr) evars in - state, (match b' with - | Info r -> - let prf = match r.rew_prf with - | RewPrf (rel, prf) -> - let rel = pointwise_or_dep_relation n' t r.rew_car rel in - let prf = mkLambda (n', t, prf) in - RewPrf (rel, prf) - | x -> x + let n' = name_app (fun id -> Tactics.fresh_id_in_env avoid id env) n in + let env' = Environ.push_rel (n', None, t) env in + let bty = Typing.type_of env' (goalevars evars) b in + let unlift = if prop then PropGlobal.unlift_cstr else TypeGlobal.unlift_cstr in + let b' = s env' avoid b bty (prop, unlift env evars cstr) evars in + (match b' with + | Some (Some r) -> + let r = match r.rew_prf with + | RewPrf (rel, prf) -> + let point = if prop then PropGlobal.pointwise_or_dep_relation else + TypeGlobal.pointwise_or_dep_relation in - Info { r with - rew_prf = prf; - rew_car = mkProd (n, t, r.rew_car); - rew_from = mkLambda(n, t, r.rew_from); - rew_to = mkLambda (n, t, r.rew_to) } - | Fail | Same -> b') - + let evars, rel = point r.rew_evars n' t r.rew_car rel in + let prf = mkLambda (n', t, prf) in + { r with rew_prf = RewPrf (rel, prf); rew_evars = evars } + | x -> r + in + Some (Some { r with + rew_car = mkProd (n, t, r.rew_car); + rew_from = mkLambda(n, t, r.rew_from); + rew_to = mkLambda (n, t, r.rew_to) }) + | _ -> b') + | Case (ci, p, c, brs) -> - let cty = Typing.type_of env (goalevars evars) c in - let cstr' = Some (mkApp (Lazy.force coq_eq, [| cty |])) in - let state, c' = s state env avoid c cty cstr' evars in - let state, res = - match c' with - | Info r -> - let res = make_leibniz_proof (mkCase (ci, lift 1 p, mkRel 1, Array.map (lift 1) brs)) ty r in - state, Info (coerce env avoid cstr res) - | Same | Fail -> - if Array.for_all (Int.equal 0) ci.ci_cstr_ndecls then - let cstr = Some (mkApp (Lazy.force coq_eq, [| ty |])) in - let state, found, brs' = Array.fold_left - (fun (state, found, acc) br -> - if not (Option.is_empty found) then (state, found, fun x -> lift 1 br :: acc x) - else - let state, res = s state env avoid br ty cstr evars in - match res with - | Info r -> (state, Some r, fun x -> mkRel 1 :: acc x) - | Fail | Same -> (state, None, fun x -> lift 1 br :: acc x)) - (state, None, fun x -> []) brs - in - state, match found with - | Some r -> - let ctxc = mkCase (ci, lift 1 p, lift 1 c, Array.of_list (List.rev (brs' c'))) in - Info (make_leibniz_proof ctxc ty r) - | None -> c' - else - match try Some (fold_match env (goalevars evars) t) with Not_found -> None with - | None -> state, c' - | Some (cst, _, t',_) -> (* eff XXX *) - let state, res = aux state env avoid t' ty cstr evars in - state, match res with - | Info prf -> - Info { prf with - rew_from = t; rew_to = unfold_match env (goalevars evars) cst prf.rew_to } - | x' -> c' - in - state, (match res with - | Info r -> - let rel, prf = get_rew_prf r in - Info (apply_constraint env avoid r.rew_car rel prf cstr r) - | x -> x) - | _ -> state, Fail + let cty = Typing.type_of env (goalevars evars) c in + let evars', eqty = app_poly evars coq_eq [| cty |] in + let cstr' = Some eqty in + let c' = s env avoid c cty (prop, cstr') evars' in + let res = + match c' with + | Some (Some r) -> + let case = mkCase (ci, lift 1 p, mkRel 1, Array.map (lift 1) brs) in + let res = make_leibniz_proof case ty r in + Some (Some (coerce env avoid (prop,cstr) res)) + | x -> + if Array.for_all (Int.equal 0) ci.ci_cstr_ndecls then + let evars', eqty = app_poly evars coq_eq [| ty |] in + let cstr = Some eqty in + let found, brs' = Array.fold_left + (fun (found, acc) br -> + if not (Option.is_empty found) then (found, fun x -> lift 1 br :: acc x) + else + match s env avoid br ty (prop,cstr) evars with + | Some (Some r) -> (Some r, fun x -> mkRel 1 :: acc x) + | _ -> (None, fun x -> lift 1 br :: acc x)) + (None, fun x -> []) brs + in + match found with + | Some r -> + let ctxc = mkCase (ci, lift 1 p, lift 1 c, Array.of_list (List.rev (brs' x))) in + Some (Some (make_leibniz_proof ctxc ty r)) + | None -> x + else + match try Some (fold_match env (goalevars evars) t) with Not_found -> None with + | None -> x + | Some (cst, _, t', eff (*FIXME*)) -> + match aux env avoid t' ty (prop,cstr) evars with + | Some (Some prf) -> + Some (Some { prf with + rew_from = t; + rew_to = unfold_match env (goalevars evars) cst prf.rew_to }) + | x' -> x + in + (match res with + | Some (Some r) -> + let rel, prf = get_rew_prf r in + Some (Some (apply_constraint env avoid r.rew_car rel prf (prop,cstr) r)) + | x -> x) + | _ -> None in aux let all_subterms = subterm true default_flags @@ -903,25 +1119,35 @@ let one_subterm = subterm false default_flags (** Requires transitivity of the rewrite step, if not a reduction. Not tail-recursive. *) -let transitivity state env avoid (res : rewrite_result_info) (next : 'a pure_strategy) : 'a * rewrite_result_info rewrite_result = - let state, res' = next state env avoid res.rew_to res.rew_car (get_opt_rew_rel res.rew_prf) res.rew_evars in - state, match res' with - | Fail -> Fail - | Same -> Info res - | Info res' -> +let transitivity env avoid prop (res : rewrite_result_info) (next : strategy) : + rewrite_result option = + let nextres = + next env avoid res.rew_to res.rew_car + (prop, get_opt_rew_rel res.rew_prf) res.rew_evars + in + match nextres with + | None -> None + | Some None -> Some (Some res) + | Some (Some res') -> match res.rew_prf with - | RewCast c -> Info { res' with rew_from = res.rew_from } + | RewCast c -> Some (Some { res' with rew_from = res.rew_from }) | RewPrf (rew_rel, rew_prf) -> match res'.rew_prf with - | RewCast _ -> Info { res with rew_to = res'.rew_to } + | RewCast _ -> Some (Some ({ res with rew_to = res'.rew_to })) | RewPrf (res'_rel, res'_prf) -> - let prfty = mkApp (Lazy.force transitive_type, [| res.rew_car; rew_rel |]) in - let evars, prf = new_cstr_evar res'.rew_evars env prfty in - let prf = mkApp (prf, [|res.rew_from; res'.rew_from; res'.rew_to; - rew_prf; res'_prf |]) - in Info { res' with rew_from = res.rew_from; - rew_evars = evars; rew_prf = RewPrf (res'_rel, prf) } - + let trans = + if prop then PropGlobal.transitive_type + else TypeGlobal.transitive_type + in + let evars, prfty = + app_poly res'.rew_evars trans [| res.rew_car; rew_rel |] + in + let evars, prf = new_cstr_evar evars env prfty in + let prf = mkApp (prf, [|res.rew_from; res'.rew_from; res'.rew_to; + rew_prf; res'_prf |]) + in Some (Some { res' with rew_from = res.rew_from; + rew_evars = evars; rew_prf = RewPrf (res'_rel, prf) }) + (** Rewriting strategies. Inspired by ELAN's rewriting strategies: @@ -931,103 +1157,129 @@ let transitivity state env avoid (res : rewrite_result_info) (next : 'a pure_str module Strategies = struct - let fail : 'a pure_strategy = - fun s env avoid t ty cstr evars -> (s, Fail) + let fail : strategy = + fun env avoid t ty cstr evars -> None - let id : 'a pure_strategy = - fun s env avoid t ty cstr evars -> (s, Same) + let id : strategy = + fun env avoid t ty cstr evars -> Some None - let refl : 'a pure_strategy = - fun s env avoid t ty cstr evars -> + let refl : strategy = + fun env avoid t ty (prop,cstr) evars -> let evars, rel = match cstr with - | None -> new_cstr_evar evars env (mk_relation ty) + | None -> + let mkr = if prop then PropGlobal.mk_relation else TypeGlobal.mk_relation in + let evars, rty = mkr evars ty in + new_cstr_evar evars env rty | Some r -> evars, r in let evars, proof = - let mty = mkApp (Lazy.force proper_proxy_type, [| ty ; rel; t |]) in + let proxy = + if prop then PropGlobal.proper_proxy_type + else TypeGlobal.proper_proxy_type + in + let evars, mty = app_poly evars proxy [| ty ; rel; t |] in new_cstr_evar evars env mty in - s, Info { rew_car = ty; rew_from = t; rew_to = t; - rew_prf = RewPrf (rel, proof); rew_evars = evars } - - let progress (s : 'a pure_strategy) : 'a pure_strategy = - fun state env avoid t ty cstr evars -> - let state, res = s state env avoid t ty cstr evars in - state, match res with - | Fail -> Fail - | Same -> Fail - | Info _ -> res - - let seq (fst : 'a pure_strategy) (snd : 'a pure_strategy) : 'a pure_strategy = - fun state env avoid t ty cstr evars -> - let state, res = fst state env avoid t ty cstr evars in - match res with - | Fail -> state, Fail - | Same -> snd state env avoid t ty cstr evars - | Info res -> transitivity state env avoid res snd - - let choice fst snd : 'a pure_strategy = - fun state env avoid t ty cstr evars -> - let state, res = fst state env avoid t ty cstr evars in - match res with - | Fail -> snd state env avoid t ty cstr evars - | Same | Info _ -> state, res - - let try_ str : 'a pure_strategy = choice str id - - let fix (f : 'a pure_strategy -> 'a pure_strategy) : 'a pure_strategy = - let rec aux state env avoid t ty cstr evars = - f aux state env avoid t ty cstr evars - in aux - - let any (s : 'a pure_strategy) : 'a pure_strategy = + Some (Some { rew_car = ty; rew_from = t; rew_to = t; + rew_prf = RewPrf (rel, proof); rew_evars = evars }) + + let progress (s : strategy) : strategy = + fun env avoid t ty cstr evars -> + match s env avoid t ty cstr evars with + | None -> None + | Some None -> None + | r -> r + + let seq first snd : strategy = + fun env avoid t ty cstr evars -> + match first env avoid t ty cstr evars with + | None -> None + | Some None -> snd env avoid t ty cstr evars + | Some (Some res) -> transitivity env avoid (fst cstr) res snd + + let choice fst snd : strategy = + fun env avoid t ty cstr evars -> + match fst env avoid t ty cstr evars with + | None -> snd env avoid t ty cstr evars + | res -> res + + let try_ str : strategy = choice str id + + let fix (f : strategy -> strategy) : strategy = + let rec aux env = f (fun env -> aux env) env in aux + + let any (s : strategy) : strategy = fix (fun any -> try_ (seq s any)) - let repeat (s : 'a pure_strategy) : 'a pure_strategy = + let repeat (s : strategy) : strategy = seq s (any s) - let bu (s : 'a pure_strategy) : 'a pure_strategy = + let bu (s : strategy) : strategy = fix (fun s' -> seq (choice (progress (all_subterms s')) s) (try_ s')) - let td (s : 'a pure_strategy) : 'a pure_strategy = + let td (s : strategy) : strategy = fix (fun s' -> seq (choice s (progress (all_subterms s'))) (try_ s')) - let innermost (s : 'a pure_strategy) : 'a pure_strategy = + let innermost (s : strategy) : strategy = fix (fun ins -> choice (one_subterm ins) s) - let outermost (s : 'a pure_strategy) : 'a pure_strategy = + let outermost (s : strategy) : strategy = fix (fun out -> choice s (one_subterm out)) - let lemmas flags cs : 'a pure_strategy = + let lemmas flags cs : strategy = List.fold_left (fun tac (l,l2r,by) -> - choice tac (apply_lemma l2r flags l by AllOccurrences)) + choice tac (apply_lemma flags l l2r by AllOccurrences)) fail cs - let old_hints (db : string) : 'a pure_strategy = + let inj_open hint = + (Evd.from_env ~ctx:hint.Autorewrite.rew_ctx (Global.env()), + (hint.Autorewrite.rew_lemma, NoBindings)) + + let old_hints (db : string) : strategy = let rules = Autorewrite.find_rewrites db in lemmas rewrite_unif_flags - (List.map (fun hint -> ((hint.Autorewrite.rew_lemma, NoBindings), hint.Autorewrite.rew_l2r, hint.Autorewrite.rew_tac)) rules) + (List.map (fun hint -> (inj_open hint, hint.Autorewrite.rew_l2r, + hint.Autorewrite.rew_tac)) rules) - let hints (db : string) : 'a pure_strategy = - fun state env avoid t ty cstr evars -> + let hints (db : string) : strategy = + fun env avoid t ty cstr evars -> let rules = Autorewrite.find_matches db t in - let lemma hint = ((hint.Autorewrite.rew_lemma, NoBindings), hint.Autorewrite.rew_l2r, + let lemma hint = (inj_open hint, hint.Autorewrite.rew_l2r, hint.Autorewrite.rew_tac) in let lems = List.map lemma rules in - lemmas rewrite_unif_flags lems state env avoid t ty cstr evars + lemmas rewrite_unif_flags lems env avoid t ty cstr evars - let reduce (r : Redexpr.red_expr) : 'a pure_strategy = - fun state env avoid t ty cstr evars -> - let rfn, ckind = Redexpr.reduction_of_red_expr env r in + let reduce (r : Redexpr.red_expr) : strategy = + fun env avoid t ty cstr evars -> + let rfn, ckind = Redexpr.reduction_of_red_expr env r in let t' = rfn env (goalevars evars) t in if eq_constr t' t then - state, Same + Some None else - state, Info { rew_car = ty; rew_from = t; rew_to = t'; - rew_prf = RewCast ckind; rew_evars = evars } + Some (Some { rew_car = ty; rew_from = t; rew_to = t'; + rew_prf = RewCast ckind; rew_evars = evars }) + + let fold c : strategy = + fun env avoid t ty cstr evars -> +(* let sigma, (c,_) = Tacinterp.interp_open_constr_with_bindings is env (goalevars evars) c in *) + let sigma, c = Constrintern.interp_open_constr (goalevars evars) env c in + let unfolded = + try Tacred.try_red_product env sigma c + with e when Errors.noncritical e -> + error "fold: the term is not unfoldable !" + in + try + let sigma = Unification.w_unify env sigma CONV ~flags:(Unification.elim_flags ()) + unfolded t in + let c' = Evarutil.nf_evar sigma c in + Some (Some { rew_car = ty; rew_from = t; rew_to = c'; + rew_prf = RewCast DEFAULTcast; + rew_evars = (sigma, snd evars) }) + with e when Errors.noncritical e -> None - let fold_glob c : 'a pure_strategy = - fun state env avoid t ty cstr evars -> + + let fold_glob c : strategy = + fun env avoid t ty cstr evars -> (* let sigma, (c,_) = Tacinterp.interp_open_constr_with_bindings is env (goalevars evars) c in *) let sigma, c = Pretyping.understand_tcc (goalevars evars) env c in let unfolded = @@ -1036,120 +1288,133 @@ module Strategies = error "fold: the term is not unfoldable !" in try - let sigma = Unification.w_unify env sigma CONV ~flags:Unification.elim_flags unfolded t in + let sigma = Unification.w_unify env sigma CONV ~flags:(Unification.elim_flags ()) unfolded t in let c' = Evarutil.nf_evar sigma c in - state, Info { rew_car = ty; rew_from = t; rew_to = c'; + Some (Some { rew_car = ty; rew_from = t; rew_to = c'; rew_prf = RewCast DEFAULTcast; - rew_evars = sigma, cstrevars evars } - with e when Errors.noncritical e -> state, Fail - + rew_evars = (sigma, snd evars) }) + with e when Errors.noncritical e -> None + end (** The strategy for a single rewrite, dealing with occurences. *) -let rewrite_with l2r flags c occs : strategy = - fun () env avoid t ty cstr evars -> +let rewrite_strat flags occs hyp = + let app = apply_rule hyp None occs in + let rec aux () = + Strategies.choice app (subterm true flags (fun env -> aux () env)) + in aux () + +let get_hypinfo_ids {c = opt} = + match opt with + | None -> [] + | Some (is, gc) -> + let avoid = Option.default [] (TacStore.get is.extra f_avoid_ids) in + Id.Map.fold (fun id _ accu -> id :: accu) is.lfun avoid + +let rewrite_with flags c left2right loccs : strategy = + fun env avoid t ty cstr evars -> let gevars = goalevars evars in - let hypinfo = decompose_applied_relation_expr env gevars c in - let (is, _) = c in - let avoid = match TacStore.get is.extra f_avoid_ids with - | None -> avoid - | Some l -> l @ avoid - in - let avoid = Id.Map.fold (fun id _ accu -> id :: accu) is.lfun avoid in - let app = apply_rule l2r flags None occs in - let strat = Strategies.fix (fun aux -> Strategies.choice app (subterm true default_flags aux)) in - let _, res = strat (hypinfo, 0) env avoid t ty cstr (gevars, cstrevars evars) in - ((), res) - -let apply_strategy (s : strategy) env avoid concl cstr evars = - let _, res = - s () env avoid concl (Typing.type_of env (goalevars evars) concl) - (Option.map snd cstr) evars + let hypinfo = ref (decompose_applied_relation_expr env gevars flags c left2right) in + let avoid = get_hypinfo_ids !hypinfo @ avoid in + rewrite_strat default_flags loccs hypinfo env avoid t ty cstr (gevars, cstrevars evars) + +let apply_strategy (s : strategy) env avoid concl (prop, cstr) evars = + let res = + s env avoid concl (Typing.type_of env (goalevars evars) concl) + (prop, Some cstr) evars in match res with - | Fail -> Fail - | Same -> Same - | Info res -> - Info (res.rew_prf, res.rew_evars, res.rew_car, res.rew_from, res.rew_to) + | None -> None + | Some None -> Some None + | Some (Some res) -> + Some (Some (res.rew_prf, res.rew_evars, res.rew_car, res.rew_from, res.rew_to)) -let solve_constraints env evars = +let solve_constraints env (evars,cstrs) = Typeclasses.resolve_typeclasses env ~split:false ~fail:true evars let nf_zeta = Reductionops.clos_norm_flags (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA]) -exception RewriteFailure of std_ppcmds +exception RewriteFailure of Pp.std_ppcmds -type result = (evar_map * constr option * types) rewrite_result +type result = (evar_map * constr option * types) option option let cl_rewrite_clause_aux ?(abs=None) strat env avoid sigma concl is_hyp : result = - let cstr = - let sort = mkProp in - let impl = Lazy.force impl in + let evars = (sigma, Evar.Set.empty) in + let evars, cstr = + let sort = Typing.sort_of env (goalevars evars) concl in + let prop, (evars, arrow) = + if is_prop_sort sort then true, app_poly evars impl [||] + else false, app_poly evars arrow [||] + in match is_hyp with - | None -> (sort, inverse sort impl) - | Some _ -> (sort, impl) + | None -> + let evars, t = poly_inverse prop env evars (mkSort sort) arrow in + evars, (prop, t) + | Some _ -> evars, (prop, arrow) in - let evars = (sigma, Evar.Set.empty) in - let eq = apply_strategy strat env avoid concl (Some cstr) evars in + let eq = apply_strategy strat env avoid concl cstr evars in match eq with - | Fail -> Fail - | Same -> Same - | Info (p, (evars, cstrs), car, oldt, newt) -> - let evars' = solve_constraints env evars in + | Some (Some (p, (evars, cstrs), car, oldt, newt)) -> + let evars' = solve_constraints env (evars, cstrs) in + let p = map_rewprf (fun p -> nf_zeta env evars' (Evarutil.nf_evar evars' p)) p in let newt = Evarutil.nf_evar evars' newt in + let abs = Option.map (fun (x, y) -> + Evarutil.nf_evar evars' x, Evarutil.nf_evar evars' y) abs in let evars = (* Keep only original evars (potentially instantiated) and goal evars, the rest has been defined and substituted already. *) - Evd.fold (fun ev evi acc -> - if Evar.Set.mem ev cstrs then Evd.remove acc ev - else acc) evars' evars' + Evar.Set.fold (fun ev acc -> Evd.remove acc ev) cstrs evars' in - match p with - | RewCast c -> Info (evars, None, newt) - | RewPrf (_, p) -> - let p = nf_zeta env evars' (Evarutil.nf_evar evars' p) in - let term = match abs with - | None -> p - | Some (t, ty) -> - let t = Evarutil.nf_evar evars' t in - let ty = Evarutil.nf_evar evars' ty in - mkApp (mkLambda (Name (Id.of_string "lemma"), ty, p), [| t |]) - in - let proof = match is_hyp with - | None -> term - | Some id -> mkApp (term, [| mkVar id |]) - in - Info (evars, Some proof, newt) - -(** ppedrot: this is a workaround. The current implementation of rewrite leaks - evar maps. We know that we should not produce effects in here, so we reput - them after computing... *) -let tclEFFECT (tac : tactic) : tactic = fun gl -> - let eff = Evd.eval_side_effects gl.sigma in - let gls = tac gl in - let sigma = Evd.emit_side_effects eff (Evd.drop_side_effects gls.sigma) in - { gls with sigma; } - -let cl_rewrite_clause_tac ?abs strat clause gl = - let evartac evd = Refiner.tclEVARS evd in + let res = + match is_hyp with + | Some id -> + (match p with + | RewPrf (rel, p) -> + let term = + match abs with + | None -> p + | Some (t, ty) -> + mkApp (mkLambda (Name (Id.of_string "lemma"), ty, p), [| t |]) + in + Some (evars, Some (mkApp (term, [| mkVar id |])), newt) + | RewCast c -> + Some (evars, None, newt)) + + | None -> + (match p with + | RewPrf (rel, p) -> + (match abs with + | None -> Some (evars, Some p, newt) + | Some (t, ty) -> + let proof = mkApp (mkLambda (Name (Id.of_string "lemma"), ty, p), [| t |]) in + Some (evars, Some proof, newt)) + | RewCast c -> Some (evars, None, newt)) + in Some res + | Some None -> Some None + | None -> None + +let rewrite_refine (evd,c) = + Tacmach.refine c + +let cl_rewrite_clause_tac ?abs strat meta clause gl = + let evartac evd = Refiner.tclEVARS (Evd.clear_metas evd) in let treat res = match res with - | Fail -> tclFAIL 0 (str "Nothing to rewrite") - | Same -> - tclFAIL 0 (str"No progress made") - | Info (undef, p, newt) -> - let tac = + | None -> tclFAIL 0 (str "Nothing to rewrite") + | Some None -> tclIDTAC + | Some (Some (undef, p, newt)) -> + let tac = match clause, p with | Some id, Some p -> cut_replacing id newt (Tacmach.refine p) - | Some id, None -> + | Some id, None -> change_in_hyp None newt (id, InHypTypeOnly) | None, Some p -> let name = next_name_away_with_default "H" Anonymous (pf_ids_of_hyps gl) in tclTHENLAST - (Tacmach.internal_cut_no_check false name newt) + (Tacmach.internal_cut false name newt) (tclTHEN (Tactics.revert [name]) (Tacmach.refine p)) | None, None -> change_in_concl None newt in tclTHEN (evartac undef) tac @@ -1162,7 +1427,7 @@ let cl_rewrite_clause_tac ?abs strat clause gl = | None -> pf_concl gl, None in let sigma = project gl in - let concl = Evarutil.nf_evar sigma concl in + let concl = Evarutil.nf_evar sigma concl in let res = cl_rewrite_clause_aux ?abs strat (pf_env gl) [] sigma concl is_hyp in treat res with @@ -1170,35 +1435,35 @@ let cl_rewrite_clause_tac ?abs strat clause gl = Refiner.tclFAIL 0 (str"Unable to satisfy the rewriting constraints." ++ fnl () ++ Himsg.explain_typeclass_error env e) - in tclEFFECT tac gl + in tac gl let bind_gl_info f = - bind concl (fun c -> bind env (fun v -> bind defs (fun ev -> f c v ev))) + bind concl (fun c -> bind env (fun v -> bind defs (fun ev -> f c v ev))) let new_refine c : Goal.subgoals Goal.sensitive = let refable = Goal.Refinable.make - (fun handle -> Goal.Refinable.constr_of_open_constr handle true c) + (fun handle -> Goal.Refinable.constr_of_open_constr handle true c) in Goal.bind refable Goal.refine -let assert_replacing id newt tac = - let sens = bind_gl_info +let assert_replacing id newt tac = + let sens = bind_gl_info (fun concl env sigma -> - let nc' = + let nc' = Environ.fold_named_context (fun _ (n, b, t as decl) nc' -> if Id.equal n id then (n, b, newt) :: nc' else decl :: nc') env ~init:[] in - let reft = Refinable.make - (fun h -> + let reft = Refinable.make + (fun h -> Goal.bind (Refinable.mkEvar h (Environ.reset_with_named_context (val_of_named_context nc') env) concl) - (fun ev -> + (fun ev -> Goal.bind (Refinable.mkEvar h env newt) (fun ev' -> - let inst = + let inst = fold_named_context (fun _ (n, b, t) inst -> if Id.equal n id then ev' :: inst @@ -1206,34 +1471,32 @@ let assert_replacing id newt tac = env ~init:[] in let (e, args) = destEvar ev in - Goal.return - (mkEvar (e, Array.of_list inst))))) + Goal.return (mkEvar (e, Array.of_list inst))))) in Goal.bind reft Goal.refine) - in Tacticals.New.tclTHEN (Proofview.tclSENSITIVE sens) + in Proofview.tclTHEN (Proofview.tclSENSITIVE sens) (Proofview.tclFOCUS 2 2 tac) -let newfail n s = +let newfail n s = Proofview.tclZERO (Refiner.FailError (n, lazy s)) let cl_rewrite_clause_newtac ?abs strat clause = - let treat (res, is_hyp) = + let treat (res, is_hyp) = match res with - | Fail -> newfail 0 (str "Nothing to rewrite") - | Same -> - newfail 0 (str"No progress made") - | Info res -> + | None -> newfail 0 (str "Nothing to rewrite") + | Some None -> Proofview.tclUNIT () + | Some (Some res) -> match is_hyp, res with | Some id, (undef, Some p, newt) -> assert_replacing id newt (Proofview.tclSENSITIVE (new_refine (undef, p))) - | Some id, (undef, None, newt) -> + | Some id, (undef, None, newt) -> Proofview.tclSENSITIVE (Goal.convert_hyp false (id, None, newt)) | None, (undef, Some p, newt) -> let refable = Goal.Refinable.make - (fun handle -> + (fun handle -> Goal.bind env (fun env -> Goal.bind (Refinable.mkEvar handle env newt) (fun ev -> - Goal.Refinable.constr_of_open_constr handle true + Goal.Refinable.constr_of_open_constr handle true (undef, mkApp (p, [| ev |]))))) in Proofview.tclSENSITIVE (Goal.bind refable Goal.refine) @@ -1248,9 +1511,9 @@ let cl_rewrite_clause_newtac ?abs strat clause = | Some id -> Environ.named_type id env, Some id | None -> concl, None in - try - let res = - cl_rewrite_clause_aux ?abs strat env [] sigma ty is_hyp + try + let res = + cl_rewrite_clause_aux ?abs strat env [] sigma ty is_hyp in return (res, is_hyp) with | TypeClassError (env, (UnsatisfiableConstraints _ as e)) -> @@ -1262,52 +1525,73 @@ let newtactic_init_setoid () = try init_setoid (); Proofview.tclUNIT () with e when Errors.noncritical e -> Proofview.tclZERO e -let tactic_init_setoid () = +let tactic_init_setoid () = init_setoid (); tclIDTAC - + let cl_rewrite_clause_new_strat ?abs strat clause = - Tacticals.New.tclTHEN (newtactic_init_setoid ()) + Proofview.tclTHEN (newtactic_init_setoid ()) (try cl_rewrite_clause_newtac ?abs strat clause with RewriteFailure s -> newfail 0 (str"setoid rewrite failed: " ++ s)) -let cl_rewrite_clause_newtac' l left2right occs clause = - Proofview.tclFOCUS 1 1 - (cl_rewrite_clause_new_strat (rewrite_with left2right rewrite_unif_flags l occs) clause) +(* let cl_rewrite_clause_newtac' l left2right occs clause = *) +(* Proof_global.run_tactic *) +(* (Proofview.tclFOCUS 1 1 *) +(* (cl_rewrite_clause_new_strat (rewrite_with rewrite_unif_flags l left2right occs) clause)) *) let cl_rewrite_clause_strat strat clause = tclTHEN (tactic_init_setoid ()) - (fun gl -> + (fun gl -> + let meta = Evarutil.new_meta() in (* let gl = { gl with sigma = Typeclasses.mark_unresolvables gl.sigma } in *) - try cl_rewrite_clause_tac strat clause gl + try cl_rewrite_clause_tac strat (mkMeta meta) clause gl with RewriteFailure e -> tclFAIL 0 (str"setoid rewrite failed: " ++ e) gl - | Refiner.FailError (n, pp) -> + | Refiner.FailError (n, pp) -> tclFAIL n (str"setoid rewrite failed: " ++ Lazy.force pp) gl) let cl_rewrite_clause l left2right occs clause gl = - cl_rewrite_clause_strat (rewrite_with left2right (general_rewrite_unif_flags ()) l occs) clause gl + cl_rewrite_clause_strat (rewrite_with (general_rewrite_unif_flags ()) l left2right occs) clause gl + +let occurrences_of = function + | n::_ as nl when n < 0 -> (false,List.map abs nl) + | nl -> + if List.exists (fun n -> n < 0) nl then + error "Illegal negative occurrence number."; + (true,nl) + +open Extraargs + +let apply_constr_expr c l2r occs = fun env avoid t ty cstr evars -> + let evd, c = Constrintern.interp_open_constr (goalevars evars) env c in + apply_lemma (general_rewrite_unif_flags ()) (Evd.empty, (c, NoBindings)) + l2r None occs env avoid t ty cstr (evd, cstrevars evars) -let apply_glob_constr c l2r occs = fun () env avoid t ty cstr evars -> +let apply_glob_constr c l2r occs = fun env avoid t ty cstr evars -> let evd, c = (Pretyping.understand_tcc (goalevars evars) env c) in - apply_lemma l2r (general_rewrite_unif_flags ()) (c, NoBindings) - None occs () env avoid t ty cstr (evd, cstrevars evars) + apply_lemma (general_rewrite_unif_flags ()) (Evd.empty, (c, NoBindings)) + l2r None occs env avoid t ty cstr (evd, cstrevars evars) -let interp_glob_constr_list env sigma cl = - let understand sigma (c, _) = - let sigma, c = Pretyping.understand_tcc sigma env c in - (sigma, ((c, NoBindings), true, None)) - in - List.fold_map understand sigma cl +let interp_constr_list env sigma = + List.map (fun c -> + let evd, c = Constrintern.interp_open_constr sigma env c in + (evd, (c, NoBindings)), true, None) + +let interp_glob_constr_list env sigma = + List.map (fun c -> + let evd, c = Pretyping.understand_tcc sigma env c in + (evd, (c, NoBindings)), true, None) -type ('constr,'redexpr) strategy_ast = +(* Syntax for rewriting with strategies *) + +type ('constr,'redexpr) strategy_ast = | StratId | StratFail | StratRefl | StratUnary of string * ('constr,'redexpr) strategy_ast | StratBinary of string * ('constr,'redexpr) strategy_ast * ('constr,'redexpr) strategy_ast | StratConstr of 'constr * bool | StratTerms of 'constr list | StratHints of bool * string - | StratEval of 'redexpr + | StratEval of 'redexpr | StratFold of 'constr let rec map_strategy (f : 'a -> 'a2) (g : 'b -> 'b2) : ('a,'b) strategy_ast -> ('a2,'b2) strategy_ast = function @@ -1324,7 +1608,7 @@ let rec strategy_of_ast = function | StratId -> Strategies.id | StratFail -> Strategies.fail | StratRefl -> Strategies.refl - | StratUnary (f, s) -> + | StratUnary (f, s) -> let s' = strategy_of_ast s in let f' = match f with | "subterms" -> all_subterms @@ -1349,28 +1633,31 @@ let rec strategy_of_ast = function in f' s' t' | StratConstr (c, b) -> apply_glob_constr (fst c) b AllOccurrences | StratHints (old, id) -> if old then Strategies.old_hints id else Strategies.hints id - | StratTerms l -> - (fun () env avoid t ty cstr (evars, cstrs) -> - let evars, cl = interp_glob_constr_list env evars l in - Strategies.lemmas rewrite_unif_flags cl () env avoid t ty cstr (evars, cstrs)) - | StratEval r -> - (fun () env avoid t ty cstr evars -> + | StratTerms l -> + (fun env avoid t ty cstr evars -> + let l' = interp_glob_constr_list env (goalevars evars) (List.map fst l) in + Strategies.lemmas rewrite_unif_flags l' env avoid t ty cstr evars) + | StratEval r -> + (fun env avoid t ty cstr evars -> let (sigma,r_interp) = Tacinterp.interp_redexp env (goalevars evars) r in - Strategies.reduce r_interp () env avoid t ty cstr (sigma,cstrevars evars)) + Strategies.reduce r_interp env avoid t ty cstr (sigma,cstrevars evars)) | StratFold c -> Strategies.fold_glob (fst c) -let mkappc s l = CAppExpl (Loc.ghost,(None,(Libnames.Ident (Loc.ghost,Id.of_string s))),l) +(* By default the strategy for "rewrite_db" is top-down *) + +let mkappc s l = CAppExpl (Loc.ghost,(None,(Libnames.Ident (Loc.ghost,Id.of_string s)),None),l) let declare_an_instance n s args = ((Loc.ghost,Name n), Explicit, - CAppExpl (Loc.ghost, (None, Qualid (Loc.ghost, qualid_of_string s)), + CAppExpl (Loc.ghost, (None, Qualid (Loc.ghost, qualid_of_string s),None), args)) let declare_instance a aeq n s = declare_an_instance n s [a;aeq] let anew_instance global binders instance fields = - new_instance binders instance (Some (CRecord (Loc.ghost,None,fields))) + new_instance (Flags.is_universe_polymorphism ()) + binders instance (Some (CRecord (Loc.ghost,None,fields))) ~global ~generalize:false None let declare_instance_refl global binders a aeq n lemma = @@ -1437,51 +1724,49 @@ let proper_projection r ty = let ctx, inst = decompose_prod_assum ty in let mor, args = destApp inst in let instarg = mkApp (r, rel_vect 0 (List.length ctx)) in - let app = mkApp (Lazy.force proper_proj, + let app = mkApp (Lazy.force PropGlobal.proper_proj, Array.append args [| instarg |]) in it_mkLambda_or_LetIn app ctx let declare_projection n instance_id r = - let ty = Global.type_of_global r in - let c = constr_of_global r in + let c,uctx = Universes.fresh_global_instance (Global.env()) r in + let poly = Global.is_polymorphic r in + let ty = Retyping.get_type_of (Global.env ()) Evd.empty c in let term = proper_projection c ty in - let env = Global.env() in - let typ = Typing.type_of env Evd.empty term in + let typ = Typing.type_of (Global.env ()) Evd.empty term in let ctx, typ = decompose_prod_assum typ in let typ = let n = let rec aux t = match kind_of_term t with - App (f, [| a ; a' ; rel; rel' |]) when eq_constr f (Lazy.force respectful) -> - succ (aux rel') - | _ -> 0 + | App (f, [| a ; a' ; rel; rel' |]) + when Globnames.is_global (PropGlobal.respectful_ref ()) f -> + succ (aux rel') + | _ -> 0 in let init = match kind_of_term typ with - App (f, args) when eq_constr f (Lazy.force respectful) -> + App (f, args) when Globnames.is_global (PropGlobal.respectful_ref ()) f -> mkApp (f, fst (Array.chop (Array.length args - 2) args)) | _ -> typ in aux init in - let ctx,ccl = Reductionops.splay_prod_n env Evd.empty (3 * n) typ + let ctx,ccl = Reductionops.splay_prod_n (Global.env()) Evd.empty (3 * n) typ in it_mkProd_or_LetIn ccl ctx in let typ = it_mkProd_or_LetIn typ ctx in - let cst = - { const_entry_body = Future.from_val (term,Declareops.no_seff); - const_entry_secctx = None; - const_entry_type = Some typ; - const_entry_opaque = false; - const_entry_inline_code = false; - const_entry_feedback = None; - } in - ignore(Declare.declare_constant n (Entries.DefinitionEntry cst, Decl_kinds.IsDefinition Decl_kinds.Definition)) + let cst = + Declare.definition_entry ~types:typ ~poly ~univs:(Univ.ContextSet.to_context uctx) + term + in + ignore(Declare.declare_constant n + (Entries.DefinitionEntry cst, Decl_kinds.IsDefinition Decl_kinds.Definition)) let build_morphism_signature m = let env = Global.env () in - let m = Constrintern.interp_constr Evd.empty env m in - let t = Typing.type_of env Evd.empty m in - let evdref = ref (Evd.empty, Evar.Set.empty) in + let m,ctx = Constrintern.interp_constr Evd.empty env m in + let sigma = Evd.from_env ~ctx env in + let t = Typing.type_of env sigma m in let cstrs = let rec aux t = match kind_of_term t with @@ -1490,21 +1775,19 @@ let build_morphism_signature m = | _ -> [] in aux t in - let evars, t', sig_, cstrs = build_signature !evdref env t cstrs None in - let _ = evdref := evars in + let evars, t', sig_, cstrs = + PropGlobal.build_signature (Evd.empty, Evar.Set.empty) env t cstrs None in + let evd = ref evars in let _ = List.iter (fun (ty, rel) -> Option.iter (fun rel -> - let default = mkApp (Lazy.force default_relation, [| ty; rel |]) in - let evars,c = new_cstr_evar !evdref env default in - evdref := evars) + let default = e_app_poly evd PropGlobal.default_relation [| ty; rel |] in + ignore(e_new_cstr_evar evd env default)) rel) cstrs in - let morph = - mkApp (Lazy.force proper_type, [| t; sig_; m |]) - in - let evd = solve_constraints env (goalevars !evdref) in + let morph = e_app_poly evd PropGlobal.proper_type [| t; sig_; m |] in + let evd = solve_constraints env !evd in let m = Evarutil.nf_evar evd morph in Evarutil.check_evars env Evd.empty evd m; m @@ -1512,12 +1795,10 @@ let default_morphism sign m = let env = Global.env () in let t = Typing.type_of env Evd.empty m in let evars, _, sign, cstrs = - build_signature (Evd.empty, Evar.Set.empty) env t (fst sign) (snd sign) + PropGlobal.build_signature (Evd.empty, Evar.Set.empty) env t (fst sign) (snd sign) in - let morph = - mkApp (Lazy.force proper_type, [| t; sign; m |]) - in - let evars, mor = resolve_one_typeclass env (fst evars) morph in + let evars, morph = app_poly evars PropGlobal.proper_type [| t; sign; m |] in + let evars, mor = resolve_one_typeclass env (goalevars evars) morph in mor, proper_projection mor morph let add_setoid global binders a aeq t n = @@ -1532,6 +1813,7 @@ let add_setoid global binders a aeq t n = (Ident (Loc.ghost,Id.of_string "Equivalence_Symmetric"), mkappc "Seq_sym" [a;aeq;t]); (Ident (Loc.ghost,Id.of_string "Equivalence_Transitive"), mkappc "Seq_trans" [a;aeq;t])]) + let make_tactic name = let open Tacexpr in let loc = Loc.ghost in @@ -1541,39 +1823,50 @@ let make_tactic name = let add_morphism_infer glob m n = init_setoid (); + let poly = Flags.is_universe_polymorphism () in let instance_id = add_suffix n "_Proper" in let instance = build_morphism_signature m in + let ctx = Univ.ContextSet.empty (*FIXME *) in if Lib.is_modtype () then let cst = Declare.declare_constant ~internal:Declare.KernelSilent instance_id - (Entries.ParameterEntry (None,instance,None), Decl_kinds.IsAssumption Decl_kinds.Logical) + (Entries.ParameterEntry + (None,poly,(instance,Univ.UContext.empty),None), + Decl_kinds.IsAssumption Decl_kinds.Logical) in - add_instance (Typeclasses.new_instance (Lazy.force proper_class) None glob (ConstRef cst)); + add_instance (Typeclasses.new_instance + (Lazy.force PropGlobal.proper_class) None glob + poly (ConstRef cst)); declare_projection n instance_id (ConstRef cst) else - let kind = Decl_kinds.Global, Decl_kinds.DefinitionBody Decl_kinds.Instance in + let kind = Decl_kinds.Global, poly, + Decl_kinds.DefinitionBody Decl_kinds.Instance + in let tac = make_tactic "Coq.Classes.SetoidTactics.add_morphism_tactic" in + let hook _ = function + | Globnames.ConstRef cst -> + add_instance (Typeclasses.new_instance + (Lazy.force PropGlobal.proper_class) None + glob poly (ConstRef cst)); + declare_projection n instance_id (ConstRef cst) + | _ -> assert false + in Flags.silently (fun () -> - Lemmas.start_proof instance_id kind instance - (fun _ -> function - Globnames.ConstRef cst -> - add_instance (Typeclasses.new_instance (Lazy.force proper_class) None - glob (ConstRef cst)); - declare_projection n instance_id (ConstRef cst) - | _ -> assert false); + Lemmas.start_proof instance_id kind (instance, ctx) hook; ignore (Pfedit.by (Tacinterp.interp tac))) () let add_morphism glob binders m s n = init_setoid (); + let poly = Flags.is_universe_polymorphism () in let instance_id = add_suffix n "_Proper" in let instance = ((Loc.ghost,Name instance_id), Explicit, CAppExpl (Loc.ghost, - (None, Qualid (Loc.ghost, Libnames.qualid_of_string "Coq.Classes.Morphisms.Proper")), + (None, Qualid (Loc.ghost, Libnames.qualid_of_string "Coq.Classes.Morphisms.Proper"),None), [cHole; s; m])) in let tac = Tacinterp.interp (make_tactic "add_morphism_tactic") in - ignore(new_instance ~global:glob binders instance (Some (CRecord (Loc.ghost,None,[]))) + ignore(new_instance ~global:glob poly binders instance (Some (CRecord (Loc.ghost,None,[]))) ~generalize:false ~tac ~hook:(declare_projection n instance_id) None) (** Bind to "rewrite" too *) @@ -1601,22 +1894,24 @@ let check_evar_map_of_evars_defs evd = check_freemetas_is_empty rebus2 freemetas2 ) metas -let unification_rewrite l2r c1 c2 cl car rel but env = +let unification_rewrite flags l2r c1 c2 cl car rel but gl = + let env = pf_env gl in + let evd = Evd.merge (project gl) cl.evd in let (evd',c') = try (* ~flags:(false,true) to allow to mark occurrences that must not be rewritten simply by replacing them with let-defined definitions in the context *) - Unification.w_unify_to_subterm + Unification.w_unify_to_subterm ~flags:{ rewrite_unif_flags with Unification.resolve_evars = true } env - cl.evd ((if l2r then c1 else c2),but) + evd ((if l2r then c1 else c2),but) with Pretype_errors.PretypeError _ -> (* ~flags:(true,true) to make Ring work (since it really exploits conversion) *) - Unification.w_unify_to_subterm - ~flags:{ rewrite2_unif_flags with Unification.resolve_evars = true } - env cl.evd ((if l2r then c1 else c2),but) + Unification.w_unify_to_subterm + ~flags:{ flags with Unification.resolve_evars = true } + env evd ((if l2r then c1 else c2),but) in let cl' = {cl with evd = evd'} in let cl' = Clenvtac.clenv_pose_dependent_evars true cl' in @@ -1626,51 +1921,60 @@ let unification_rewrite l2r c1 c2 cl car rel but env = and car = nf car and rel = nf rel in check_evar_map_of_evars_defs cl'.evd; let prf = nf (Clenv.clenv_value cl') and prfty = nf (Clenv.clenv_type cl') in - let cl' = { cl' with templval = mk_freelisted prf ; templtyp = mk_freelisted prfty } in - let abs = (prf, prfty) in - abs, {cl=cl'; ext=Evar.Set.empty; prf=(mkRel 1); car=car; rel=rel; - c1=c1; c2=c2; c=None; abs=true; } + let sort = sort_of_rel env evd' (pf_concl gl) in + let cl' = { cl' with templval = mk_freelisted prf ; templtyp = mk_freelisted prfty; + evd = Evd.diff cl'.evd (project gl) } + in + {cl=cl'; prf=(mkRel 1); car=car; rel=rel; l2r=l2r; + c1=c1; c2=c2; c=None; abs=Some (prf, prfty); sort = Sorts.is_prop sort; flags = flags} let get_hyp gl evars (c,l) clause l2r = - let env = pf_env gl in - let hi = decompose_applied_relation env evars None (c,l) in + let flags = rewrite2_unif_flags in + let hi = decompose_applied_relation (pf_env gl) evars evars flags None (c,l) l2r in let but = match clause with - | Some id -> pf_get_hyp_typ gl id + | Some id -> pf_get_hyp_typ gl id | None -> Evarutil.nf_evar evars (pf_concl gl) in - unification_rewrite l2r hi.c1 hi.c2 hi.cl hi.car hi.rel but env + let unif = unification_rewrite flags hi.l2r hi.c1 hi.c2 hi.cl hi.car hi.rel but gl in + { unif with flags = rewrite_unif_flags } let general_rewrite_flags = { under_lambdas = false; on_morphisms = true } +let apply_lemma gl (c,l) cl l2r occs = + let sigma = project gl in + let hypinfo = ref (get_hyp gl sigma (c,l) cl l2r) in + let app = apply_rule hypinfo None occs in + let rec aux () = + Strategies.choice app (subterm true general_rewrite_flags (fun env -> aux () env)) + in !hypinfo, aux () + + +let cl_rewrite_clause_tac abs strat meta cl gl = + cl_rewrite_clause_tac ~abs strat meta cl gl + +(* let rewriteclaustac_key = Profile.declare_profile "cl_rewrite_clause_tac";; *) +(* let cl_rewrite_clause_tac = Profile.profile5 rewriteclaustac_key cl_rewrite_clause_tac *) + let general_s_rewrite cl l2r occs (c,l) ~new_goals gl = - let app = apply_rule l2r rewrite_unif_flags None occs in - let recstrat aux = Strategies.choice app (subterm true general_rewrite_flags aux) in - let substrat = Strategies.fix recstrat in - let abs, hypinfo = get_hyp gl (project gl) (c,l) cl l2r in - let strat () env avoid t ty cstr evars = - let _, res = substrat (hypinfo, 0) env avoid t ty cstr evars in - (), res - in + let meta = Evarutil.new_meta() in + let hypinfo, strat = apply_lemma gl (c,l) cl l2r occs in try - (tclWEAK_PROGRESS + tclWEAK_PROGRESS (tclTHEN - (Refiner.tclEVARS hypinfo.cl.evd) - (cl_rewrite_clause_tac ~abs:(Some abs) strat cl))) gl + (Refiner.tclEVARS (Evd.merge (project gl) hypinfo.cl.evd)) + (cl_rewrite_clause_tac hypinfo.abs strat (mkMeta meta) cl)) gl with RewriteFailure e -> - let {c1=x; c2=y} = hypinfo in + let {l2r=l2r; c1=x; c2=y} = hypinfo in raise (Pretype_errors.PretypeError (pf_env gl,project gl, Pretype_errors.NoOccurrenceFound ((if l2r then x else y), cl))) -open Proofview.Notations - let general_s_rewrite_clause x = + init_setoid (); + fun b occs cl ~new_goals -> match x with - | None -> general_s_rewrite None - | Some id -> general_s_rewrite (Some id) -let general_s_rewrite_clause x y z w ~new_goals = - newtactic_init_setoid () <*> - Proofview.V82.tactic (general_s_rewrite_clause x y z w ~new_goals) + | None -> Proofview.V82.tactic (general_s_rewrite None b occs cl ~new_goals) + | Some id -> Proofview.V82.tactic (general_s_rewrite (Some id) b occs cl ~new_goals) let _ = Hook.set Equality.general_rewrite_clause general_s_rewrite_clause @@ -1682,63 +1986,61 @@ let not_declared env ty rel = let setoid_proof ty fn fallback = Proofview.Goal.enter begin fun gl -> - let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in let concl = Proofview.Goal.concl gl in - Proofview.tclORELSE - begin - try - let rel, args = decompose_app_rel env sigma concl in - let evm = sigma in - let car = pi3 (List.hd (fst (Reduction.dest_prod env (Typing.type_of env evm rel)))) in - fn env evm car rel - with e -> Proofview.tclZERO e - end - begin function - | e -> - Proofview.tclORELSE - fallback - begin function - | Hipattern.NoEquationFound -> - (* spiwack: [Errors.push] here is unlikely to do what - it's intended to, or anything meaningful for that - matter. *) - let e = Errors.push e in - begin match e with - | Not_found -> - let rel, args = decompose_app_rel env sigma concl in - not_declared env ty rel - | _ -> Proofview.tclZERO e - end - | e' -> Proofview.tclZERO e' - end - end + try + let rel, args = decompose_app_rel env sigma concl in + let car = pi3 (List.hd (fst (Reduction.dest_prod env (Typing.type_of env sigma rel)))) in + Proofview.V82.tactic (fn env sigma car rel) + with e when Errors.noncritical e -> + Proofview.tclORELSE fallback (function + | Hipattern.NoEquationFound -> + let e = Errors.push e in + begin match e with + | Not_found -> + let rel, args = decompose_app_rel env sigma concl in + not_declared env ty rel + | _ -> raise e + end + | e -> Proofview.tclZERO e) end +let tac_open ((evm,_), c) tac = + tclTHEN (Refiner.tclEVARS evm) (tac c) + +let poly_proof getp gett env evm car rel = + if Sorts.is_prop (sort_of_rel env evm rel) then + getp env (evm,Evar.Set.empty) car rel + else gett env (evm,Evar.Set.empty) car rel + let setoid_reflexivity = setoid_proof "reflexive" - (fun env evm car rel -> Proofview.V82.tactic (apply (get_reflexive_proof env evm car rel))) + (fun env evm car rel -> + tac_open (poly_proof PropGlobal.get_reflexive_proof TypeGlobal.get_reflexive_proof + env evm car rel) apply) (reflexivity_red true) let setoid_symmetry = setoid_proof "symmetric" - (fun env evm car rel -> Proofview.V82.tactic (apply (get_symmetric_proof env evm car rel))) + (fun env evm car rel -> + tac_open (poly_proof PropGlobal.get_symmetric_proof TypeGlobal.get_symmetric_proof + env evm car rel) apply) (symmetry_red true) let setoid_transitivity c = setoid_proof "transitive" (fun env evm car rel -> - Proofview.V82.tactic begin - let proof = get_transitive_proof env evm car rel in - match c with - | None -> eapply proof - | Some c -> apply_with_bindings (proof,ImplicitBindings [ c ]) - end) + let proof = poly_proof PropGlobal.get_transitive_proof TypeGlobal.get_transitive_proof + env evm car rel in + match c with + | None -> tac_open proof eapply + | Some c -> tac_open proof (fun t -> apply_with_bindings (t,ImplicitBindings [ c ]))) (transitivity_red true c) - + let setoid_symmetry_in id = - Proofview.Goal.enter begin fun gl -> - let ctype = Tacmach.New.of_old (fun gl -> pf_type_of gl (mkVar id)) gl in + Proofview.V82.tactic (fun gl -> + let ctype = pf_type_of gl (mkVar id) in let binders,concl = decompose_prod_assum ctype in let (equiv, args) = decompose_app concl in let rec split_last_two = function @@ -1750,12 +2052,81 @@ let setoid_symmetry_in id = let he,c1,c2 = mkApp (equiv, Array.of_list others),c1,c2 in let new_hyp' = mkApp (he, [| c2 ; c1 |]) in let new_hyp = it_mkProd_or_LetIn new_hyp' binders in - Tacticals.New.tclTHENS (Tactics.cut new_hyp) - [ Proofview.V82.tactic (intro_replacing id); - Tacticals.New.tclTHENLIST [ intros; setoid_symmetry; Proofview.V82.tactic (apply (mkVar id)); Tactics.assumption ] ] - end + tclTHENS (Proofview.V82.of_tactic (Tactics.cut new_hyp)) + [ intro_replacing id; + tclTHENLIST [ Proofview.V82.of_tactic intros; Proofview.V82.of_tactic setoid_symmetry; apply (mkVar id); Proofview.V82.of_tactic Tactics.assumption ] ] + gl) let _ = Hook.set Tactics.setoid_reflexivity setoid_reflexivity let _ = Hook.set Tactics.setoid_symmetry setoid_symmetry let _ = Hook.set Tactics.setoid_symmetry_in setoid_symmetry_in let _ = Hook.set Tactics.setoid_transitivity setoid_transitivity + +let implify id gl = + let (_, b, ctype) = pf_get_hyp gl id in + let binders,concl = decompose_prod_assum ctype in + let evm, ctype' = + match binders with + | (_, None, ty as hd) :: tl when noccurn 1 concl -> + let env = Environ.push_rel_context tl (pf_env gl) in + let sigma = project gl in + let tyhd = Typing.type_of env sigma ty + and tyconcl = Typing.type_of (Environ.push_rel hd env) sigma concl in + let ((sigma,_), app), unfold = + PropGlobal.arrow_morphism (sigma, Evar.Set.empty) tyhd + (subst1 mkProp tyconcl) ty (subst1 mkProp concl) + in + sigma, it_mkProd_or_LetIn app tl + | _ -> project gl, ctype + in tclTHEN (Refiner.tclEVARS evm) (Tacmach.convert_hyp (id, b, ctype')) gl + +let rec fold_matches env sigma c = + map_constr_with_full_binders Environ.push_rel + (fun env c -> + match kind_of_term c with + | Case _ -> + let cst, env, c', _eff = fold_match ~force:true env sigma c in + fold_matches env sigma c' + | _ -> fold_matches env sigma c) + env c + +let fold_match_tac c gl = + let _, _, c', eff = fold_match ~force:true (pf_env gl) (project gl) c in + let gl = { gl with sigma = Evd.emit_side_effects eff gl.sigma } in + change (Some (snd (Patternops.pattern_of_constr (project gl) c))) c' onConcl gl + +let fold_matches_tac c gl = + let c' = fold_matches (pf_env gl) (project gl) c in + (* let gl = { gl with sigma = Evd.emit_side_effects eff gl.sigma } in *) + change (Some (snd (Patternops.pattern_of_constr (project gl) c))) c' onConcl gl + +let myapply id l gl = + let gr = id in + let _, impls = List.hd (Impargs.implicits_of_global gr) in + let env = pf_env gl in + let evars = ref (project gl) in + let evd, ty = fresh_global env !evars gr in + let _ = evars := evd in + let app = + let rec aux ty impls args args' = + match impls, kind_of_term ty with + | Some (_, _, (_, _)) :: impls, Prod (n, t, t') -> + let arg = Evarutil.e_new_evar evars env t in + aux (subst1 arg t') impls args (arg :: args') + | None :: impls, Prod (n, t, t') -> + (match args with + | [] -> + if dependent (mkRel 1) t' then + let arg = Evarutil.e_new_evar evars env t in + aux (subst1 arg t') impls args (arg :: args') + else + let arg = Evarutil.mk_new_meta () in + evars := meta_declare (destMeta arg) t !evars; + aux (subst1 arg t') impls args (arg :: args') + | arg :: args -> + aux (subst1 arg t') impls args (arg :: args')) + | _, _ -> mkApp (Universes.constr_of_global gr, Array.of_list (List.rev args')) + in aux ty impls l [] + in + tclTHEN (Refiner.tclEVARS !evars) (apply app) gl + diff --git a/tactics/rewrite.mli b/tactics/rewrite.mli index e2d9a41d8..9bdfc08d2 100644 --- a/tactics/rewrite.mli +++ b/tactics/rewrite.mli @@ -41,10 +41,6 @@ val cl_rewrite_clause : interp_sign * (glob_constr_and_expr * glob_constr_and_expr bindings) -> bool -> Locus.occurrences -> Id.t option -> tactic -val cl_rewrite_clause_newtac' : - interp_sign * (glob_constr_and_expr * glob_constr_and_expr bindings) -> - bool -> Locus.occurrences -> Id.t option -> unit Proofview.tactic - val is_applied_rewrite_relation : env -> evar_map -> Context.rel_context -> constr -> types option @@ -61,12 +57,6 @@ val add_morphism_infer : bool -> constr_expr -> Id.t -> unit val add_morphism : bool -> local_binder list -> constr_expr -> constr_expr -> Id.t -> unit -val get_reflexive_proof : env -> evar_map -> constr -> constr -> constr - -val get_symmetric_proof : env -> evar_map -> constr -> constr -> constr - -val get_transitive_proof : env -> evar_map -> constr -> constr -> constr - val default_morphism : (types * constr option) option list * (types * types option) option -> constr -> constr * constr diff --git a/tactics/taccoerce.ml b/tactics/taccoerce.ml index 2c1de14ea..95c6b6bfb 100644 --- a/tactics/taccoerce.ml +++ b/tactics/taccoerce.ml @@ -157,7 +157,7 @@ let coerce_to_evaluable_ref env v = else fail () else let ev = match Value.to_constr v with - | Some c when isConst c -> EvalConstRef (destConst c) + | Some c when isConst c -> EvalConstRef (Univ.out_punivs (destConst c)) | Some c when isVar c -> EvalVarRef (destVar c) | _ -> fail () in @@ -213,7 +213,7 @@ let coerce_to_reference env v = let coerce_to_inductive v = match Value.to_constr v with - | Some c when isInd c -> destInd c + | Some c when isInd c -> Univ.out_punivs (destInd c) | _ -> raise (CannotCoerceTo "an inductive type") (* Quantified named or numbered hypothesis or hypothesis in context *) diff --git a/tactics/tacintern.ml b/tactics/tacintern.ml index cd2319c01..fa76b2a94 100644 --- a/tactics/tacintern.ml +++ b/tactics/tacintern.ml @@ -138,12 +138,13 @@ let intern_ltac_variable ist = function let intern_constr_reference strict ist = function | Ident (_,id) as r when not strict && find_hyp id ist -> - GVar (dloc,id), Some (CRef r) + GVar (dloc,id), Some (CRef (r,None)) | Ident (_,id) as r when find_ctxvar id ist -> - GVar (dloc,id), if strict then None else Some (CRef r) + GVar (dloc,id), if strict then None else Some (CRef (r,None)) | r -> let loc,_ as lqid = qualid_of_reference r in - GRef (loc,locate_global_with_alias lqid), if strict then None else Some (CRef r) + GRef (loc,locate_global_with_alias lqid,None), + if strict then None else Some (CRef (r,None)) let intern_move_location ist = function | MoveAfter id -> MoveAfter (intern_hyp_or_metaid ist id) @@ -278,7 +279,7 @@ let intern_induction_arg ist = function | ElimOnIdent (loc,id) -> if !strict_check then (* If in a defined tactic, no intros-until *) - match intern_constr ist (CRef (Ident (dloc,id))) with + match intern_constr ist (CRef (Ident (dloc,id), None)) with | GVar (loc,id),_ -> ElimOnIdent (loc,id) | c -> ElimOnConstr (c,NoBindings) else diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index ecd7fce31..128d8ea87 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -295,6 +295,9 @@ let interp_ident = interp_ident_gen false let interp_fresh_ident = interp_ident_gen true let pf_interp_ident id gl = interp_ident_gen false id (pf_env gl) +let interp_global ist gl gr = + Evd.fresh_global (pf_env gl) (project gl) gr + (* Interprets an optional identifier which must be fresh *) let interp_fresh_name ist env = function | Anonymous -> Anonymous @@ -842,7 +845,7 @@ let interp_induction_arg ist gl arg = if Tactics.is_quantified_hypothesis id gl then ElimOnIdent (loc,id) else - let c = (GVar (loc,id),Some (CRef (Ident (loc,id)))) in + let c = (GVar (loc,id),Some (CRef (Ident (loc,id),None))) in let (sigma,c) = interp_constr ist env sigma c in ElimOnConstr (sigma,(c,NoBindings)) @@ -2104,8 +2107,7 @@ let () = Geninterp.register_interp0 wit_intro_pattern interp; let interp ist gl pat = (project gl, interp_clause ist (pf_env gl) pat) in Geninterp.register_interp0 wit_clause_dft_concl interp; - - let interp ist gl s = (project gl, interp_sort s) in + let interp ist gl s = interp_sort (project gl) s in Geninterp.register_interp0 wit_sort interp let () = @@ -2143,7 +2145,8 @@ let _ = if has_type arg (glbwit wit_tactic) then let tac = out_gen (glbwit wit_tactic) arg in let tac = interp_tactic ist tac in - let prf = Proof.start sigma [env, ty] in + let ctx = Evd.get_universe_context_set sigma in + let prf = Proof.start sigma [env, (ty, ctx)] in let (prf, _) = try Proof.run_tactic env tac prf with Proof_errors.TacticFailure e as src -> diff --git a/tactics/tacsubst.ml b/tactics/tacsubst.ml index 997975196..47fa4f942 100644 --- a/tactics/tacsubst.ml +++ b/tactics/tacsubst.ml @@ -74,7 +74,7 @@ open Printer let subst_global_reference subst = let subst_global ref = let ref',t' = subst_global subst ref in - if not (eq_constr (constr_of_global ref') t') then + if not (eq_constr (Universes.constr_of_global ref') t') then msg_warning (strbrk "The reference " ++ pr_global ref ++ str " is not " ++ str " expanded to \"" ++ pr_lconstr t' ++ str "\", but to " ++ pr_global ref') ; @@ -175,7 +175,7 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with | TacDecomposeAnd c -> TacDecomposeAnd (subst_glob_constr subst c) | TacDecomposeOr c -> TacDecomposeOr (subst_glob_constr subst c) | TacDecompose (l,c) -> - let l = List.map (subst_or_var (subst_inductive subst)) l in + let l = List.map (subst_or_var (subst_ind subst)) l in TacDecompose (l,subst_glob_constr subst c) | TacSpecialize (n,l) -> TacSpecialize (n,subst_glob_with_bindings subst l) | TacLApply c -> TacLApply (subst_glob_constr subst c) diff --git a/tactics/tacticMatching.ml b/tactics/tacticMatching.ml index b11841a65..cb54263bb 100644 --- a/tactics/tacticMatching.ml +++ b/tactics/tacticMatching.ml @@ -232,7 +232,7 @@ module PatternMatching (E:StaticEnvironment) = struct matchings of [term] with the pattern [pat => lhs]. If refresh is true, refreshes the universes of [term]. *) let pattern_match_term refresh pat term lhs = - let term = if refresh then Termops.refresh_universes_strict term else term in +(* let term = if refresh then Termops.refresh_universes_strict term else term in *) match pat with | Term p -> begin diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index bd33e5146..f647ac510 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -145,7 +145,7 @@ let ifOnHyp pred tac1 tac2 id gl = the elimination. *) type branch_args = { - ity : inductive; (* the type we were eliminating on *) + ity : pinductive; (* the type we were eliminating on *) largs : constr list; (* its arguments *) branchnum : int; (* the branch number *) pred : constr; (* the predicate we used *) @@ -185,7 +185,7 @@ let compute_induction_names n = function | Some (loc,_) -> user_err_loc (loc,"",str "Disjunctive/conjunctive introduction pattern expected.") -let compute_construtor_signatures isrec (_,k as ity) = +let compute_construtor_signatures isrec ((_,k as ity),u) = let rec analrec c recargs = match kind_of_term c, recargs with | Prod (_,_,c), recarg::rest -> @@ -214,10 +214,19 @@ let elimination_sort_of_clause = function | None -> elimination_sort_of_goal | Some id -> elimination_sort_of_hyp id + +let pf_with_evars glsev k gls = + let evd, a = glsev gls in + tclTHEN (Refiner.tclEVARS evd) (k a) gls + +let pf_constr_of_global gr k = + pf_with_evars (fun gls -> pf_apply Evd.fresh_global gls gr) k + (* computing the case/elim combinators *) let gl_make_elim ind gl = - Indrec.lookup_eliminator ind (elimination_sort_of_goal gl) + let gr = Indrec.lookup_eliminator (fst ind) (elimination_sort_of_goal gl) in + pf_apply Evd.fresh_global gl gr let gl_make_case_dep ind gl = pf_apply Indrec.build_case_analysis_scheme gl ind true @@ -535,7 +544,8 @@ module New = struct isrec allnames tac predicate ind (c, t) = Proofview.Goal.enter begin fun gl -> let indclause = Tacmach.New.of_old (fun gl -> mk_clenv_from gl (c, t)) gl in - let elim = Tacmach.New.of_old (mk_elim ind) gl in + (** FIXME: evar leak. *) + let sigma, elim = Tacmach.New.of_old (mk_elim ind) gl in (* applying elimination_scheme just a little modified *) let elimclause = Tacmach.New.of_old (fun gls -> mk_clenv_from gls (elim,Tacmach.New.pf_type_of gl elim)) gl in let indmv = @@ -550,7 +560,7 @@ module New = struct | _ -> let name_elim = match kind_of_term elim with - | Const kn -> string_of_con kn + | Const (kn, _) -> string_of_con kn | Var id -> string_of_id id | _ -> "\b" in @@ -559,7 +569,7 @@ module New = struct let elimclause' = clenv_fchain indmv elimclause indclause in let branchsigns = compute_construtor_signatures isrec ind in let brnames = compute_induction_names (Array.length branchsigns) allnames in - let flags = Unification.elim_flags in + let flags = Unification.elim_flags () in let elimclause' = match predicate with | None -> elimclause' @@ -591,9 +601,9 @@ module New = struct Proofview.Goal.enter begin fun gl -> let (ind,t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in let isrec,mkelim = - if (Global.lookup_mind (fst ind)).mind_record - then false,gl_make_case_dep - else true,gl_make_elim + match (Global.lookup_mind (fst (fst ind))).mind_record with + | None -> true,gl_make_elim + | Some _ -> false,gl_make_case_dep in general_elim_then_using mkelim isrec None tac None ind (c, t) end @@ -630,4 +640,12 @@ module New = struct | None -> elimination_sort_of_goal gl | Some id -> elimination_sort_of_hyp id gl + let pf_constr_of_global ref tac = + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + let (sigma, c) = Evd.fresh_global env sigma ref in + Proofview.V82.tclEVARS sigma <*> (tac c) + end + end diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli index fcc23df22..cc1528797 100644 --- a/tactics/tacticals.mli +++ b/tactics/tacticals.mli @@ -101,7 +101,7 @@ val onClauseLR : (Id.t option -> tactic) -> clause -> tactic (** {6 Elimination tacticals. } *) type branch_args = { - ity : inductive; (** the type we were eliminating on *) + ity : pinductive; (** the type we were eliminating on *) largs : constr list; (** its arguments *) branchnum : int; (** the branch number *) pred : constr; (** the predicate we used *) @@ -132,6 +132,9 @@ val elimination_sort_of_goal : goal sigma -> sorts_family val elimination_sort_of_hyp : Id.t -> goal sigma -> sorts_family val elimination_sort_of_clause : Id.t option -> goal sigma -> sorts_family +val pf_with_evars : (goal sigma -> Evd.evar_map * 'a) -> ('a -> tactic) -> tactic +val pf_constr_of_global : Globnames.global_reference -> (constr -> tactic) -> tactic + val elim_on_ba : (branch_assumptions -> tactic) -> branch_args -> tactic val case_on_ba : (branch_assumptions -> tactic) -> branch_args -> tactic @@ -237,12 +240,14 @@ module New : sig val case_then_using : intro_pattern_expr located option -> (branch_args -> unit Proofview.tactic) -> - constr option -> inductive -> Term.constr * Term.types -> unit Proofview.tactic + constr option -> pinductive -> Term.constr * Term.types -> unit Proofview.tactic val case_nodep_then_using : intro_pattern_expr located option -> (branch_args -> unit Proofview.tactic) -> - constr option -> inductive -> Term.constr * Term.types -> unit Proofview.tactic + constr option -> pinductive -> Term.constr * Term.types -> unit Proofview.tactic val elim_on_ba : (branch_assumptions -> unit Proofview.tactic) -> branch_args -> unit Proofview.tactic val case_on_ba : (branch_assumptions -> unit Proofview.tactic) -> branch_args -> unit Proofview.tactic + + val pf_constr_of_global : Globnames.global_reference -> (constr -> unit Proofview.tactic) -> unit Proofview.tactic end diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 151c5b2ce..280950600 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -97,7 +97,7 @@ let tactic_infer_flags = { let finish_evar_resolution env initial_sigma (sigma,c) = let sigma = Pretyping.solve_remaining_evars tactic_infer_flags env initial_sigma sigma - in nf_evar sigma c + in Evd.evar_universe_context sigma, nf_evar sigma c (*********************************************) (* Tactics *) @@ -112,7 +112,8 @@ let head_constr_bound t = let _,ccl = decompose_prod_assum t in let hd,args = decompose_app ccl in match kind_of_term hd with - | Const _ | Ind _ | Construct _ | Var _ -> (hd,args) + | Const _ | Ind _ | Construct _ | Var _ -> hd + | Proj (p, _) -> mkConst p | _ -> raise Bound let head_constr c = @@ -128,6 +129,19 @@ let convert_concl = Tacmach.convert_concl let convert_hyp = Tacmach.convert_hyp let thin_body = Tacmach.thin_body +let convert_gen pb x y gl = + try tclEVARS (pf_apply Evd.conversion gl pb x y) gl + with Reduction.NotConvertible -> + tclFAIL_lazy 0 (lazy (str"Not convertible")) + (* Adding more information in this message, even under the lazy, can result in huge *) + (* blowups, time and spacewise... (see autos used in DoubleCyclic.) 2.3s against 15s. *) + (* ++ Printer.pr_constr_env env x ++ *) + (* str" and " ++ Printer.pr_constr_env env y)) *) + gl + +let convert = convert_gen Reduction.CONV +let convert_leq = convert_gen Reduction.CUMUL + let error_clear_dependency env id = function | Evarutil.OccurHypInSimpleClause None -> errorlabstrm "" (pr_id id ++ str " is used in conclusion.") @@ -302,25 +316,54 @@ let reduct_option redfun = function | Some id -> reduct_in_hyp (fst redfun) id | None -> reduct_in_concl (revert_cast redfun) +(** Versions with evars to maintain the unification of universes resulting + from conversions. *) + +let tclWITHEVARS f k gl = + let evm, c' = pf_apply f gl in + tclTHEN (tclEVARS evm) (k c') gl + +let e_reduct_in_concl (redfun,sty) gl = + tclWITHEVARS + (fun env sigma -> redfun env sigma (pf_concl gl)) + (fun c -> convert_concl_no_check c sty) gl + +let e_pf_reduce_decl (redfun : e_reduction_function) where (id,c,ty) env sigma = + match c with + | None -> + if where == InHypValueOnly then + errorlabstrm "" (pr_id id ++ str "has no value."); + let sigma',ty' = redfun env sigma ty in + sigma', (id,None,ty') + | Some b -> + let sigma',b' = if where != InHypTypeOnly then redfun env sigma b else sigma, b in + let sigma',ty' = if where != InHypValueOnly then redfun env sigma ty else sigma', ty in + sigma', (id,Some b',ty') + +let e_reduct_in_hyp redfun (id,where) gl = + tclWITHEVARS + (e_pf_reduce_decl redfun where (pf_get_hyp gl id)) + convert_hyp_no_check gl + (* Now we introduce different instances of the previous tacticals *) let change_and_check cv_pb t env sigma c = - if is_fconv cv_pb env sigma t c then - t - else - errorlabstrm "convert-check-hyp" (str "Not convertible.") + let evd, b = infer_conv ~pb:cv_pb env sigma t c in + if b then evd, t + else + errorlabstrm "convert-check-hyp" (str "Not convertible.") (* Use cumulativity only if changing the conclusion not a subterm *) let change_on_subterm cv_pb t = function | None -> change_and_check cv_pb t | Some occl -> - contextually false occl + e_contextually false occl (fun subst -> change_and_check Reduction.CONV (replace_vars (Id.Map.bindings subst) t)) let change_in_concl occl t = - reduct_in_concl ((change_on_subterm Reduction.CUMUL t occl),DEFAULTcast) + e_reduct_in_concl ((change_on_subterm Reduction.CUMUL t occl),DEFAULTcast) let change_in_hyp occl t id = - with_check (reduct_in_hyp (change_on_subterm Reduction.CONV t occl) id) + with_check (e_reduct_in_hyp (change_on_subterm Reduction.CONV t occl) id) let change_option occl t = function | Some id -> change_in_hyp occl t id @@ -785,7 +828,7 @@ let index_of_ind_arg t = | None -> error "Could not find inductive argument of elimination scheme." in aux None 0 t -let elimination_clause_scheme with_evars ?(flags=elim_flags) i elimclause indclause gl = +let elimination_clause_scheme with_evars ?(flags=elim_flags ()) i elimclause indclause gl = let indmv = (match kind_of_term (nth_arg i elimclause.templval.rebus) with | Meta mv -> mv @@ -830,13 +873,14 @@ let general_elim with_evars c e = let general_case_analysis_in_context with_evars (c,lbindc) gl = let (mind,_) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in let sort = elimination_sort_of_goal gl in - let elim = + let sigma, elim = if occur_term c (pf_concl gl) then pf_apply build_case_analysis_scheme gl mind true sort else pf_apply build_case_analysis_scheme_default gl mind sort in - general_elim with_evars (c,lbindc) - {elimindex = None; elimbody = (elim,NoBindings)} gl + tclTHEN (tclEVARS sigma) + (general_elim with_evars (c,lbindc) + {elimindex = None; elimbody = (elim,NoBindings)}) gl let general_case_analysis with_evars (c,lbindc as cx) = match kind_of_term c with @@ -855,17 +899,22 @@ exception IsRecord let is_record mind = (Global.lookup_mind (fst mind)).mind_record +let find_ind_eliminator ind s gl = + let gr = lookup_eliminator ind s in + let evd, c = pf_apply Evd.fresh_global gl gr in + evd, c + let find_eliminator c gl = - let (ind,t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in - if is_record ind then raise IsRecord; - let c = lookup_eliminator ind (elimination_sort_of_goal gl) in - {elimindex = None; elimbody = (c,NoBindings)} + let ((ind,u),t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in + if is_record ind <> None then raise IsRecord; + let evd, c = find_ind_eliminator ind (elimination_sort_of_goal gl) gl in + evd, {elimindex = None; elimbody = (c,NoBindings)} let default_elim with_evars (c,_ as cx) = Proofview.tclORELSE (Proofview.Goal.enter begin fun gl -> - let elim = Tacmach.New.of_old (find_eliminator c) gl in - Proofview.V82.tactic (general_elim with_evars cx elim) + let evd, elim = Tacmach.New.of_old (find_eliminator c) gl in + Proofview.V82.tactic (tclTHEN (tclEVARS evd) (general_elim with_evars cx elim)) end) begin function | IsRecord -> @@ -902,13 +951,13 @@ let simplest_elim c = default_elim false (c,NoBindings) (e.g. it could replace id:A->B->C by id:C, knowing A/\B) *) -let clenv_fchain_in id ?(flags=elim_flags) mv elimclause hypclause = +let clenv_fchain_in id ?(flags=elim_flags ()) mv elimclause hypclause = try clenv_fchain ~flags mv elimclause hypclause with PretypeError (env,evd,NoOccurrenceFound (op,_)) -> (* Set the hypothesis name in the message *) raise (PretypeError (env,evd,NoOccurrenceFound (op,Some id))) -let elimination_in_clause_scheme with_evars ?(flags=elim_flags) id i elimclause indclause gl = +let elimination_in_clause_scheme with_evars ?(flags=elim_flags ()) id i elimclause indclause gl = let indmv = destMeta (nth_arg i elimclause.templval.rebus) in let hypmv = try match List.remove Int.equal indmv (clenv_independent elimclause) with @@ -933,7 +982,7 @@ type conjunction_status = | DefinedRecord of constant option list | NotADefinedRecordUseScheme of constr -let make_projection sigma params cstr sign elim i n c = +let make_projection env sigma params cstr sign elim i n c u = let elim = match elim with | NotADefinedRecordUseScheme elim -> (* bugs: goes from right to left when i increases! *) @@ -947,24 +996,32 @@ let make_projection sigma params cstr sign elim i n c = && not (isEvar (fst (whd_betaiota_stack sigma t))) then let t = lift (i+1-n) t in - Some (beta_applist (elim,params@[t;branch]),t) + let abselim = beta_applist (elim,params@[t;branch]) in + let c = beta_applist (abselim, [mkApp (c, extended_rel_vect 0 sign)]) in + Some (it_mkLambda_or_LetIn c sign, it_mkProd_or_LetIn t sign) else None | DefinedRecord l -> (* goes from left to right when i increases! *) match List.nth l i with | Some proj -> - let t = Typeops.type_of_constant (Global.env()) proj in let args = extended_rel_vect 0 sign in - Some (beta_applist (mkConst proj,params),prod_applist t (params@[mkApp (c,args)])) + let proj = + if Environ.is_projection proj env then + mkProj (proj, mkApp (c, args)) + else + mkApp (mkConstU (proj,u), Array.append (Array.of_list params) + [|mkApp (c, args)|]) + in + let app = it_mkLambda_or_LetIn proj sign in + let t = Retyping.get_type_of env sigma app in + Some (app, t) | None -> None - in Option.map (fun (abselim,elimt) -> - let c = beta_applist (abselim,[mkApp (c,extended_rel_vect 0 sign)]) in - (it_mkLambda_or_LetIn c sign, it_mkProd_or_LetIn elimt sign)) elim + in elim let descend_in_conjunctions tac exit c gl = try - let (ind,t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in + let ((ind,u),t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in let sign,ccl = decompose_prod_assum t in match match_with_tuple ccl with | Some (_,_,isrec) -> @@ -972,18 +1029,18 @@ let descend_in_conjunctions tac exit c gl = let sort = elimination_sort_of_goal gl in let id = fresh_id [] (Id.of_string "H") gl in let IndType (indf,_) = pf_apply find_rectype gl ccl in - let params = snd (dest_ind_family indf) in + let (_,inst), params = dest_ind_family indf in let cstr = (get_constructors (pf_env gl) indf).(0) in let elim = try DefinedRecord (Recordops.lookup_projections ind) with Not_found -> - let elim = pf_apply build_case_analysis_scheme gl ind false sort in - NotADefinedRecordUseScheme elim in + let elim = pf_apply build_case_analysis_scheme gl (ind,u) false sort in + NotADefinedRecordUseScheme (snd elim) in tclFIRST (List.init n (fun i gl -> - match make_projection (project gl) params cstr sign elim i n c with + match pf_apply make_projection gl params cstr sign elim i n c u with | None -> tclFAIL 0 (mt()) gl - | Some (p,pt) -> + | Some (p,pt) -> tclTHENS (internal_cut id pt) [refine p; (* Might be ill-typed due to forbidden elimination. *) @@ -999,7 +1056,7 @@ let descend_in_conjunctions tac exit c gl = let general_apply with_delta with_destruct with_evars (loc,(c,lbind)) gl0 = let flags = - if with_delta then default_unify_flags else default_no_delta_unify_flags in + if with_delta then default_unify_flags () else default_no_delta_unify_flags () in (* The actual type of the theorem. It will be matched against the goal. If this fails, then the head constant will be unfolded step by step. *) @@ -1094,7 +1151,7 @@ let apply_in_once_main flags innerclause (d,lbind) gl = let apply_in_once sidecond_first with_delta with_destruct with_evars id (loc,(d,lbind)) gl0 = - let flags = if with_delta then elim_flags else elim_no_delta_flags in + let flags = if with_delta then elim_flags () else elim_no_delta_flags () in let t' = pf_get_hyp_typ gl0 id in let innerclause = mk_clenv_from_n gl0 (Some 0) (mkVar id,t') in let rec aux with_destruct c gl = @@ -1144,13 +1201,17 @@ let cut_and_apply c = (* Exact tactics *) (********************************************************************) +(* let convert_leqkey = Profile.declare_profile "convert_leq";; *) +(* let convert_leq = Profile.profile3 convert_leqkey convert_leq *) + +(* let refine_no_checkkey = Profile.declare_profile "refine_no_check";; *) +(* let refine_no_check = Profile.profile2 refine_no_checkkey refine_no_check *) + let exact_check c gl = let concl = (pf_concl gl) in let ct = pf_type_of gl c in - if pf_conv_x_leq gl ct concl then - refine_no_check c gl - else - error "Not an exact proof." + try tclTHEN (convert_leq ct concl) (refine_no_check c) gl + with _ -> error "Not an exact proof." (*FIXME error handling here not the best *) let exact_no_check = refine_no_check let new_exact_no_check c = @@ -1162,8 +1223,8 @@ let vm_cast_no_check c gl = let exact_proof c gl = - let c = Constrintern.interp_casted_constr (project gl) (pf_env gl) c (pf_concl gl) - in refine_no_check c gl + let c,ctx = Constrintern.interp_casted_constr (project gl) (pf_env gl) c (pf_concl gl) + in tclPUSHCONTEXT Evd.univ_flexible ctx (refine_no_check c) gl let assumption = let rec arec gl only_eq = function @@ -1174,12 +1235,12 @@ let assumption = else Tacticals.New.tclZEROMSG (str "No such assumption.") | (id, c, t)::rest -> let concl = Proofview.Goal.concl gl in - let is_same_type = - if only_eq then eq_constr t concl + let sigma = Proofview.Goal.sigma gl in + let (sigma, is_same_type) = + if only_eq then (sigma, eq_constr t concl) else - let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in - is_conv_leq env sigma t concl + infer_conv env sigma t concl in if is_same_type then Proofview.Refine.refine (fun h -> (h, mkVar id)) else arec gl only_eq rest @@ -1233,7 +1294,7 @@ let specialize mopt (c,lbind) g = tclEVARS evd, nf_evar evd c else let clause = pf_apply make_clenv_binding g (c,pf_type_of g c) lbind in - let flags = { default_unify_flags with resolve_evars = true } in + let flags = { (default_unify_flags ()) with resolve_evars = true } in let clause = clenv_unify_meta_types ~flags clause in let (thd,tstack) = whd_nored_stack clause.evd (clenv_value clause) in let nargs = List.length tstack in @@ -1299,14 +1360,20 @@ let constructor_tac with_evars expctdnumopt i lbind = let reduce_to_quantified_ind = Tacmach.New.pf_apply Tacred.reduce_to_quantified_ind gl in - let (mind,redcl) = reduce_to_quantified_ind cl in - let nconstr = - Array.length (snd (Global.lookup_inductive mind)).mind_consnames in - check_number_of_constructors expctdnumopt i nconstr; - let cons = mkConstruct (ith_constructor_of_inductive mind i) in - let apply_tac = Proofview.V82.tactic (general_apply true false with_evars (dloc,(cons,lbind))) in - (Tacticals.New.tclTHENLIST - [Proofview.V82.tactic (convert_concl_no_check redcl DEFAULTcast); intros; apply_tac]) + try (* reduce_to_quantified_ind can raise an exception *) + let (mind,redcl) = reduce_to_quantified_ind cl in + let nconstr = + Array.length (snd (Global.lookup_inductive (fst mind))).mind_consnames in + check_number_of_constructors expctdnumopt i nconstr; + + let sigma, cons = Evd.fresh_constructor_instance + (Proofview.Goal.env gl) (Proofview.Goal.sigma gl) (fst mind, i) in + let cons = mkConstructU cons in + + let apply_tac = Proofview.V82.tactic (general_apply true false with_evars (dloc,(cons,lbind))) in + (Tacticals.New.tclTHENLIST + [Proofview.V82.tactic (tclTHEN (tclEVARS sigma) (convert_concl_no_check redcl DEFAULTcast)); intros; apply_tac]) + with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e end let one_constructor i lbind = constructor_tac false None i lbind @@ -1331,7 +1398,7 @@ let any_constructor with_evars tacopt = in let mind = fst (reduce_to_quantified_ind cl) in let nconstr = - Array.length (snd (Global.lookup_inductive mind)).mind_consnames in + Array.length (snd (Global.lookup_inductive (fst mind))).mind_consnames in if Int.equal nconstr 0 then error "The type has no constructors."; tclANY tac (List.interval 1 nconstr) end @@ -1395,7 +1462,7 @@ let intro_decomp_eq loc b l l' thin tac id = let c = mkVar id in let t = Tacmach.New.pf_type_of gl c in let _,t = Tacmach.New.pf_reduce_to_quantified_ind gl t in - let eq,eq_args = my_find_eq_data_decompose gl t in + let eq,u,eq_args = my_find_eq_data_decompose gl t in let eq_clause = Tacmach.New.pf_apply make_clenv_binding gl (c,t) NoBindings in !intro_decomp_eq_function (fun n -> tac ((dloc,id)::thin) (adjust_intro_patterns n l @ l')) @@ -1406,7 +1473,7 @@ let intro_or_and_pattern loc b ll l' thin tac id = Proofview.Goal.raw_enter begin fun gl -> let c = mkVar id in let t = Tacmach.New.pf_type_of gl c in - let (ind,t) = Tacmach.New.pf_reduce_to_quantified_ind gl t in + let ((ind,u),t) = Tacmach.New.pf_reduce_to_quantified_ind gl t in let nv = mis_constr_nargs ind in let bracketed = b || not (List.is_empty l') in let adjust n l = if bracketed then adjust_intro_patterns n l else l in @@ -1660,14 +1727,14 @@ let generalized_name c t ids cl = function constante dont on aurait pu prendre directement le nom *) named_hd (Global.env()) t Anonymous -let generalize_goal gl i ((occs,c,b),na) cl = +let generalize_goal gl i ((occs,c,b),na) (cl,evd) = let t = pf_type_of gl c in let decls,cl = decompose_prod_n_assum i cl in let dummy_prod = it_mkProd_or_LetIn mkProp decls in - let newdecls,_ = decompose_prod_n_assum i (subst_term c dummy_prod) in - let cl' = subst_closed_term_occ occs c (it_mkProd_or_LetIn cl newdecls) in + let newdecls,_ = decompose_prod_n_assum i (subst_term_gen eq_constr_nounivs c dummy_prod) in + let cl',evd' = subst_closed_term_univs_occ evd occs c (it_mkProd_or_LetIn cl newdecls) in let na = generalized_name c t (pf_ids_of_hyps gl) cl' na in - mkProd_or_LetIn (na,b,t) cl' + mkProd_or_LetIn (na,b,t) cl', evd let generalize_dep ?(with_let=false) c gl = let env = pf_env gl in @@ -1697,18 +1764,23 @@ let generalize_dep ?(with_let=false) c gl = | _ -> None else None in - let cl'' = generalize_goal gl 0 ((AllOccurrences,c,body),Anonymous) cl' in + let cl'',evd = generalize_goal gl 0 ((AllOccurrences,c,body),Anonymous) + (cl',project gl) in let args = instance_from_named_context to_quantify_rev in - tclTHEN - (apply_type cl'' (if Option.is_empty body then c::args else args)) - (thin (List.rev tothin')) + tclTHENLIST + [tclPUSHEVARUNIVCONTEXT (Evd.evar_universe_context evd); + apply_type cl'' (if Option.is_empty body then c::args else args); + thin (List.rev tothin')] gl let generalize_gen_let lconstr gl = - let newcl = - List.fold_right_i (generalize_goal gl) 0 lconstr (pf_concl gl) in - apply_type newcl (List.map_filter (fun ((_,c,b),_) -> - if Option.is_empty b then Some c else None) lconstr) gl + let newcl, evd = + List.fold_right_i (generalize_goal gl) 0 lconstr + (pf_concl gl,project gl) + in + tclTHEN (tclPUSHEVARUNIVCONTEXT (Evd.evar_universe_context evd)) + (apply_type newcl (List.map_filter (fun ((_,c,b),_) -> + if Option.is_empty b then Some c else None) lconstr)) gl let generalize_gen lconstr = generalize_gen_let (List.map (fun ((occs,c),na) -> @@ -1804,19 +1876,30 @@ let default_matching_flags sigma = { let make_pattern_test env sigma0 (sigma,c) = let flags = default_matching_flags sigma0 in - let matching_fun t = - try let sigma = w_unify env sigma Reduction.CONV ~flags c t in Some(sigma,t) + let matching_fun _ t = + try let sigma = w_unify env sigma Reduction.CONV ~flags c t in + Some(sigma, t) with e when Errors.noncritical e -> raise NotUnifiable in let merge_fun c1 c2 = match c1, c2 with - | Some (_,c1), Some (_,c2) when not (is_fconv Reduction.CONV env sigma0 c1 c2) -> - raise NotUnifiable - | _ -> c1 in + | Some (evd,c1), Some (_,c2) -> + (try let evd = w_unify env evd Reduction.CONV ~flags c1 c2 in + Some (evd, c1) + with e when Errors.noncritical e -> raise NotUnifiable) + | Some _, None -> c1 + | None, Some _ -> c2 + | None, None -> None + in { match_fun = matching_fun; merge_fun = merge_fun; testing_state = None; last_found = None }, (fun test -> match test.testing_state with - | None -> finish_evar_resolution env sigma0 (sigma,c) - | Some (sigma,_) -> nf_evar sigma c) + | None -> + let ctx, c = finish_evar_resolution env sigma0 (sigma,c) in + Proofview.V82.tactic (tclPUSHEVARUNIVCONTEXT ctx), c + | Some (sigma,_) -> + let univs, subst = nf_univ_variables sigma in + Proofview.V82.tactic (tclPUSHEVARUNIVCONTEXT (Evd.evar_universe_context univs)), + subst_univs_constr subst (nf_evar sigma c)) let letin_abstract id c (test,out) (occs,check_occs) gl = let env = pf_env gl in @@ -1854,13 +1937,13 @@ let letin_tac_gen with_eq name (sigmac,c) test ty occs = if not (mem_named_context x hyps) then x else error ("The variable "^(Id.to_string x)^" is already declared.") in - let (depdecls,lastlhyp,ccl,c) = + let (depdecls,lastlhyp,ccl,(tac,c)) = Tacmach.New.of_old (letin_abstract id c test occs) gl in let t = match ty with Some t -> t | None -> Tacmach.New.pf_apply (fun e s -> typ_of e s c) gl in - let (newcl,eq_tac) = match with_eq with + let (sigma,newcl,eq_tac) = match with_eq with | Some (lr,(loc,ido)) -> let heq = match ido with | IntroAnonymous -> new_fresh_id [id] (add_prefix "Heq" id) gl @@ -1869,26 +1952,34 @@ let letin_tac_gen with_eq name (sigmac,c) test ty occs = | _ -> Errors.error "Expect an introduction pattern naming one hypothesis." in let eqdata = build_coq_eq_data () in let args = if lr then [t;mkVar id;c] else [t;c;mkVar id]in - let eq = applist (eqdata.eq,args) in - let refl = applist (eqdata.refl, [t;mkVar id]) in + let sigma, eq = Evd.fresh_global env (Proofview.Goal.sigma gl) eqdata.eq in + let sigma, refl = Evd.fresh_global env sigma eqdata.refl in + let eq = applist (eq,args) in + let refl = applist (refl, [t;mkVar id]) in + sigma, mkNamedLetIn id c t (mkLetIn (Name heq, refl, eq, ccl)), Tacticals.New.tclTHEN (intro_gen loc (IntroMustBe heq) lastlhyp true false) (Proofview.V82.tactic (thin_body [heq;id])) | None -> - (mkNamedLetIn id c t ccl, Proofview.tclUNIT ()) in + (Proofview.Goal.sigma gl, mkNamedLetIn id c t ccl, Proofview.tclUNIT ()) in Tacticals.New.tclTHENLIST - [ Proofview.V82.tactic (convert_concl_no_check newcl DEFAULTcast); + [ Proofview.V82.tclEVARS sigma; tac; Proofview.V82.tactic (convert_concl_no_check newcl DEFAULTcast); intro_gen dloc (IntroMustBe id) lastlhyp true false; Proofview.V82.tactic (tclMAP convert_hyp_no_check depdecls); eq_tac ] end -let make_eq_test c = (make_eq_test c,fun _ -> c) +let make_eq_test evd c = + let out cstr = + let tac = tclPUSHEVARUNIVCONTEXT (Evd.evar_universe_context cstr.testing_state) in + Proofview.V82.tactic tac, c + in + (Tacred.make_eq_univs_test Evd.empty c, out) let letin_tac with_eq name c ty occs = Proofview.tclEVARMAP >>= fun sigma -> - letin_tac_gen with_eq name (sigma,c) (make_eq_test c) ty (occs,true) + letin_tac_gen with_eq name (sigma,c) (make_eq_test sigma c) ty (occs,true) let letin_pat_tac with_eq name c ty occs = Proofview.Goal.raw_enter begin fun gl -> @@ -2401,25 +2492,28 @@ let error_ind_scheme s = let s = if not (String.is_empty s) then s^" " else s in error ("Cannot recognize "^s^"an induction scheme.") -let coq_eq = Lazy.lazy_from_fun Coqlib.build_coq_eq -let coq_eq_refl = lazy ((Coqlib.build_coq_eq_data ()).Coqlib.refl) +let glob = Universes.constr_of_global + +let coq_eq = lazy (glob (Coqlib.build_coq_eq ())) +let coq_eq_refl = lazy (glob (Coqlib.build_coq_eq_refl ())) let coq_heq = lazy (Coqlib.coq_constant "mkHEq" ["Logic";"JMeq"] "JMeq") let coq_heq_refl = lazy (Coqlib.coq_constant "mkHEq" ["Logic";"JMeq"] "JMeq_refl") + let mkEq t x y = - mkApp (Lazy.force coq_eq, [| refresh_universes_strict t; x; y |]) + mkApp (Lazy.force coq_eq, [| t; x; y |]) let mkRefl t x = - mkApp (Lazy.force coq_eq_refl, [| refresh_universes_strict t; x |]) + mkApp (Lazy.force coq_eq_refl, [| t; x |]) let mkHEq t x u y = mkApp (Lazy.force coq_heq, - [| refresh_universes_strict t; x; refresh_universes_strict u; y |]) + [| t; x; u; y |]) let mkHRefl t x = mkApp (Lazy.force coq_heq_refl, - [| refresh_universes_strict t; x |]) + [| t; x |]) let lift_togethern n l = let l', _ = @@ -2437,8 +2531,8 @@ let ids_of_constr ?(all=false) vars c = | Var id -> Id.Set.add id vars | App (f, args) -> (match kind_of_term f with - | Construct (ind,_) - | Ind ind -> + | Construct ((ind,_),_) + | Ind (ind,_) -> let (mib,mip) = Global.lookup_inductive ind in Array.fold_left_from (if all then 0 else mib.Declarations.mind_nparams) @@ -2449,8 +2543,8 @@ let ids_of_constr ?(all=false) vars c = let decompose_indapp f args = match kind_of_term f with - | Construct (ind,_) - | Ind ind -> + | Construct ((ind,_),_) + | Ind (ind,_) -> let (mib,mip) = Global.lookup_inductive ind in let first = mib.Declarations.mind_nparams_rec in let pars, args = Array.chop first args in @@ -2552,8 +2646,7 @@ let abstract_args gl generalize_vars dep id defined f args = List.hd rel, c in let argty = pf_type_of gl arg in - let argty = refresh_universes_strict argty in - let ty = refresh_universes_strict ty in + let ty = (* refresh_universes_strict *) ty in let lenctx = List.length ctx in let liftargty = lift lenctx argty in let leq = constr_cmp Reduction.CUMUL liftargty ty in @@ -2656,7 +2749,7 @@ let specialize_eqs id gl = match kind_of_term ty with | Prod (na, t, b) -> (match kind_of_term t with - | App (eq, [| eqty; x; y |]) when eq_constr eq (Lazy.force coq_eq) -> + | App (eq, [| eqty; x; y |]) when eq_constr (Lazy.force coq_eq) eq -> let c = if noccur_between 1 (List.length ctx) x then y else x in let pt = mkApp (Lazy.force coq_eq, [| eqty; c; c |]) in let p = mkApp (Lazy.force coq_eq_refl, [| eqty; c |]) in @@ -2691,7 +2784,7 @@ let specialize_eqs id gl = let ty' = Evarutil.nf_evar !evars ty' in if worked then tclTHENFIRST (Tacmach.internal_cut true id ty') - (exact_no_check (refresh_universes_strict acc')) gl + (exact_no_check ((* refresh_universes_strict *) acc')) gl else tclFAIL 0 (str "Nothing to do in hypothesis " ++ pr_id id) gl @@ -2912,7 +3005,7 @@ let compute_scheme_signature scheme names_info ind_type_guess = extra final argument of the form (f x y ...) in the conclusion. In the non standard case, naming of generated hypos is slightly different. *) -let compute_elim_signature ((elimc,elimt),ind_type_guess) names_info = +let compute_elim_signature (evd,(elimc,elimt),ind_type_guess) names_info = let scheme = compute_elim_sig ~elimc:elimc elimt in compute_scheme_signature scheme names_info ind_type_guess, scheme @@ -2920,8 +3013,8 @@ let guess_elim isrec hyp0 gl = let tmptyp0 = pf_get_hyp_typ gl hyp0 in let mind,_ = pf_reduce_to_quantified_ind gl tmptyp0 in let s = elimination_sort_of_goal gl in - let elimc = - if isrec && not (is_record mind) then lookup_eliminator mind s + let evd, elimc = + if isrec && not (is_record (fst mind) <> None) then find_ind_eliminator (fst mind) s gl else if use_dependent_propositions_elimination () && dependent_no_evar (mkVar hyp0) (pf_concl gl) @@ -2930,12 +3023,12 @@ let guess_elim isrec hyp0 gl = else pf_apply build_case_analysis_scheme_default gl mind s in let elimt = pf_type_of gl elimc in - ((elimc, NoBindings), elimt), mkInd mind + evd, ((elimc, NoBindings), elimt), mkIndU mind let given_elim hyp0 (elimc,lbind as e) gl = let tmptyp0 = pf_get_hyp_typ gl hyp0 in let ind_type_guess,_ = decompose_app ((strip_prod tmptyp0)) in - (e, pf_type_of gl elimc), ind_type_guess + project gl, (e, pf_type_of gl elimc), ind_type_guess let find_elim isrec elim hyp0 gl = match elim with @@ -2950,21 +3043,21 @@ type eliminator_source = | ElimOver of bool * Id.t let find_induction_type isrec elim hyp0 gl = - let scheme,elim = + let evd,scheme,elim = match elim with | None -> - let (elimc,elimt),_ = guess_elim isrec hyp0 gl in + let evd, (elimc,elimt),_ = guess_elim isrec hyp0 gl in let scheme = compute_elim_sig ~elimc elimt in (* We drop the scheme waiting to know if it is dependent *) - scheme, ElimOver (isrec,hyp0) + project gl, scheme, ElimOver (isrec,hyp0) | Some e -> - let (elimc,elimt),ind_guess = given_elim hyp0 e gl in + let evd, (elimc,elimt),ind_guess = given_elim hyp0 e gl in let scheme = compute_elim_sig ~elimc elimt in if Option.is_empty scheme.indarg then error "Cannot find induction type"; let indsign = compute_scheme_signature scheme hyp0 ind_guess in let elim = ({elimindex = Some(-1); elimbody = elimc},elimt) in - scheme, ElimUsing (elim,indsign) in - Option.get scheme.indref,scheme.nparams, elim + evd, scheme, ElimUsing (elim,indsign) in + evd,(Option.get scheme.indref,scheme.nparams, elim) let find_elim_signature isrec elim hyp0 gl = compute_elim_signature (find_elim isrec elim hyp0 gl) hyp0 @@ -2984,10 +3077,10 @@ let is_functional_induction elim gl = let get_eliminator elim gl = match elim with | ElimUsing (elim,indsign) -> - (* bugged, should be computed *) true, elim, indsign + Proofview.Goal.sigma gl, (* bugged, should be computed *) true, elim, indsign | ElimOver (isrec,id) -> - let (elimc,elimt),_ as elims = Tacmach.New.of_old (guess_elim isrec id) gl in - isrec, ({elimindex = None; elimbody = elimc}, elimt), + let evd, (elimc,elimt),_ as elims = Tacmach.New.of_old (guess_elim isrec id) gl in + evd, isrec, ({elimindex = None; elimbody = elimc}, elimt), fst (compute_elim_signature elims id) (* Instantiate all meta variables of elimclause using lid, some elts @@ -3041,7 +3134,7 @@ let induction_tac_felim with_evars indvars nparams elim gl = (* elimclause' is built from elimclause by instanciating all args and params. *) let elimclause' = recolle_clenv nparams indvars elimclause gl in (* one last resolution (useless?) *) - let resolved = clenv_unique_resolver ~flags:elim_flags elimclause' gl in + let resolved = clenv_unique_resolver ~flags:(elim_flags ()) elimclause' gl in clenv_refine with_evars resolved gl (* Apply induction "in place" replacing the hypothesis on which @@ -3049,13 +3142,14 @@ let induction_tac_felim with_evars indvars nparams elim gl = let apply_induction_with_discharge induct_tac elim indhyps destopt avoid names tac = Proofview.Goal.enter begin fun gl -> - let (isrec, elim, indsign) = get_eliminator elim gl in + let (sigma, isrec, elim, indsign) = get_eliminator elim gl in let names = compute_induction_names (Array.length indsign) names in - (if isrec then Tacticals.New.tclTHENFIRSTn else Tacticals.New.tclTHENLASTn) + Tacticals.New.tclTHEN (Proofview.V82.tclEVARS sigma) + ((if isrec then Tacticals.New.tclTHENFIRSTn else Tacticals.New.tclTHENLASTn) (Tacticals.New.tclTHEN (induct_tac elim) (Proofview.V82.tactic (tclMAP (fun id -> tclTRY (expand_hyp id)) (List.rev indhyps)))) - (Array.map2 (induct_discharge destopt avoid tac) indsign names) + (Array.map2 (induct_discharge destopt avoid tac) indsign names)) end (* Apply induction "in place" taking into account dependent @@ -3066,7 +3160,7 @@ let apply_induction_in_context hyp0 elim indvars names induct_tac = let env = Proofview.Goal.env gl in let concl = Tacmach.New.pf_nf_concl gl in let statuslists,lhyp0,indhyps,deps = cook_sign hyp0 indvars env in - let deps = List.map (on_pi3 refresh_universes_strict) deps in +(* let deps = List.map (on_pi3 refresh_universes_strict) deps in *) let tmpcl = it_mkNamedProd_or_LetIn concl deps in let dephyps = List.map (fun (id,_,_) -> id) deps in let deps_cstr = @@ -3163,11 +3257,11 @@ let induction_from_context isrec with_evars (indref,nparams,elim) (hyp0,lbind) n let induction_with_atomization_of_ind_arg isrec with_evars elim names (hyp0,lbind) inhyps = Proofview.Goal.enter begin fun gl -> - let elim_info = Tacmach.New.of_old (find_induction_type isrec elim hyp0) gl in - Tacticals.New.tclTHEN - (atomize_param_of_ind elim_info hyp0) + let sigma, elim_info = Tacmach.New.of_old (find_induction_type isrec elim hyp0) gl in + Tacticals.New.tclTHENLIST + [Proofview.V82.tclEVARS sigma; (atomize_param_of_ind elim_info hyp0); (induction_from_context isrec with_evars elim_info - (hyp0,lbind) names inhyps) + (hyp0,lbind) names inhyps)] end (* Induction on a list of induction arguments. Analyse the elim @@ -3319,9 +3413,10 @@ let induct_destruct isrec with_evars (lc,elim,names,cls) = str "Example: induction x1 x2 x3 using my_scheme."); if not (Option.is_empty cls) then error "'in' clause not supported here."; - let finish_evar_resolution = Tacmach.New.pf_apply finish_evar_resolution gl in - let lc = List.map - (map_induction_arg finish_evar_resolution) lc in + let finish_evar_resolution (sigma, c) = + snd (finish_evar_resolution (Proofview.Goal.env gl) (Proofview.Goal.sigma gl) (sigma, c)) + in + let lc = List.map (map_induction_arg finish_evar_resolution) lc in begin match lc with | [_] -> (* Hook to recover standard induction on non-standard induction schemes *) @@ -3398,20 +3493,22 @@ let elim_scheme_type elim t gl = | Meta mv -> let clause' = (* t is inductive, then CUMUL or CONV is irrelevant *) - clenv_unify ~flags:elim_flags Reduction.CUMUL t + clenv_unify ~flags:(elim_flags ()) Reduction.CUMUL t (clenv_meta_type clause mv) clause in - res_pf clause' ~flags:elim_flags gl + res_pf clause' ~flags:(elim_flags ()) gl | _ -> anomaly (Pp.str "elim_scheme_type") let elim_type t gl = let (ind,t) = pf_reduce_to_atomic_ind gl t in - let elimc = lookup_eliminator ind (elimination_sort_of_goal gl) in - elim_scheme_type elimc t gl + let evd, elimc = find_ind_eliminator (fst ind) (elimination_sort_of_goal gl) gl in + tclTHEN (tclEVARS evd) (elim_scheme_type elimc t) gl let case_type t gl = let (ind,t) = pf_reduce_to_atomic_ind gl t in - let elimc = pf_apply build_case_analysis_scheme_default gl ind (elimination_sort_of_goal gl) in - elim_scheme_type elimc t gl + let evd, elimc = + pf_apply build_case_analysis_scheme_default gl ind (elimination_sort_of_goal gl) + in + tclTHEN (tclEVARS evd) (elim_scheme_type elimc t) gl (************************************************) @@ -3492,7 +3589,7 @@ let symmetry_red allowred = Proofview.V82.tactic begin tclTHEN (convert_concl_no_check concl DEFAULTcast) - (apply eq_data.sym) + (pf_constr_of_global eq_data.sym apply) end | None,eq,eq_kind -> prove_symmetry eq eq_kind end @@ -3587,8 +3684,8 @@ let transitivity_red allowred t = tclTHEN (convert_concl_no_check concl DEFAULTcast) (match t with - | None -> eapply eq_data.trans - | Some t -> apply_list [eq_data.trans;t]) + | None -> pf_constr_of_global eq_data.trans eapply + | Some t -> pf_constr_of_global eq_data.trans (fun trans -> apply_list [trans;t])) end | None,eq,eq_kind -> match t with @@ -3613,7 +3710,7 @@ let intros_transitivity n = Tacticals.New.tclTHEN intros (transitivity_gen n) the current goal, abstracted with respect to the local signature, is solved by tac *) -let interpretable_as_section_decl d1 d2 = match d1,d2 with +let interpretable_as_section_decl d1 d2 = match d2,d1 with | (_,Some _,_), (_,None,_) -> false | (_,Some b1,t1), (_,Some b2,t2) -> eq_constr b1 b2 && eq_constr t1 t2 | (_,None,t1), (_,_,t2) -> eq_constr t1 t2 @@ -3639,9 +3736,16 @@ let abstract_subproof id tac = try flush_and_check_evars (Proofview.Goal.sigma gl) concl with Uninstantiated_evar _ -> error "\"abstract\" cannot handle existentials." in + + let evd, ctx, concl = + (* FIXME: should be done only if the tactic succeeds *) + let evd, nf = nf_evars_and_universes (Proofview.Goal.sigma gl) in + let ctx = Evd.get_universe_context_set evd in + evd, ctx, nf concl + in let solve_tac = tclCOMPLETE (tclTHEN (tclDO (List.length sign) intro) tac) in - let (const, safe) = - try Pfedit.build_constant_by_tactic id secsign concl solve_tac + let (const, safe, subst) = + try Pfedit.build_constant_by_tactic id secsign (concl, ctx) solve_tac with Proof_errors.TacticFailure e as src -> (* if the tactic [tac] fails, it reports a [TacticFailure e], which is an error irrelevant to the proof system (in fact it @@ -3655,12 +3759,13 @@ let abstract_subproof id tac = let decl = (cd, IsProof Lemma) in (** ppedrot: seems legit to have abstracted subproofs as local*) let cst = Declare.declare_constant ~internal:Declare.KernelSilent ~local:true id decl in - let lem = mkConst cst in + let evd, lem = Evd.fresh_global (Global.env ()) evd (ConstRef cst) in let open Declareops in let eff = Safe_typing.sideff_of_con (Global.safe_env ()) cst in let effs = cons_side_effects eff no_seff in let args = List.rev (instance_from_named_context sign) in - let solve = Proofview.tclEFFECTS effs <*> new_exact_no_check (applist (lem, args)) in + let solve = Proofview.V82.tactic (tclEVARS evd) <*> + Proofview.tclEFFECTS effs <*> new_exact_no_check (applist (lem, args)) in if not safe then Proofview.mark_as_unsafe <*> solve else solve end @@ -3682,12 +3787,53 @@ let admit_as_an_axiom = simplest_case (Coqlib.build_coq_proof_admitted ()) <*> Proofview.mark_as_unsafe +(* let current_sign = Global.named_context() *) +(* and global_sign = pf_hyps gl in *) +(* let poly = Flags.is_universe_polymorphism () in (\*FIXME*\) *) +(* let sign,secsign = *) +(* List.fold_right *) +(* (fun (id,_,_ as d) (s1,s2) -> *) +(* if mem_named_context id current_sign & *) +(* interpretable_as_section_decl (Context.lookup_named id current_sign) d *) +(* then (s1,add_named_decl d s2) *) +(* else (add_named_decl d s1,s2)) *) +(* global_sign (empty_named_context,empty_named_context) in *) +(* let name = add_suffix (get_current_proof_name ()) "_admitted" in *) +(* let na = next_global_ident_away name (pf_ids_of_hyps gl) in *) +(* let evd, nf = nf_evars_and_universes (project gl) in *) +(* let ctx = Evd.universe_context evd in *) +(* let newconcl = nf (pf_concl gl) in *) +(* let newsign = Context.map_named_context nf sign in *) +(* let concl = it_mkNamedProd_or_LetIn newconcl newsign in *) +(* if occur_existential concl then error"\"admit\" cannot handle existentials."; *) +(* let entry = *) +(* (Pfedit.get_used_variables(),poly,(concl,ctx),None) *) +(* in *) +(* let cd = Entries.ParameterEntry entry in *) +(* let decl = (cd, IsAssumption Logical) in *) +(* (\** ppedrot: seems legit to have admitted subproofs as local*\) *) +(* let con = Declare.declare_constant ~internal:Declare.KernelSilent ~local:true na decl in *) +(* let evd, axiom = evd, (mkConstU (con, Univ.UContext.instance ctx)) in *) +(* (\* let evd, axiom = Evd.fresh_global (pf_env gl) (project gl) (ConstRef con) in *\) *) +(* let gl = tclTHEN (tclEVARS evd) *) +(* (tclTHEN (convert_concl_no_check newconcl DEFAULTcast) *) +(* (exact_check *) +(* (applist (axiom, *) +(* List.rev (Array.to_list (instance_from_named_context sign)))))) *) +(* gl *) +(* in *) +(* Pp.feedback Interface.AddedAxiom; *) +(* gl *) +(* >>>>>>> .merge_file_iUuzZK *) + let unify ?(state=full_transparent_state) x y gl = try let flags = - {default_unify_flags with - modulo_delta = state; - modulo_conv_on_closed_terms = Some state} + {(default_unify_flags ()) with + modulo_delta = state; + modulo_delta_types = state; + modulo_delta_in_merge = Some state; + modulo_conv_on_closed_terms = Some state} in let evd = w_unify (pf_env gl) (project gl) Reduction.CONV ~flags x y in tclEVARS evd gl diff --git a/tactics/tactics.mli b/tactics/tactics.mli index 9a2af0835..937efdae1 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -26,8 +26,8 @@ open Locus (** {6 General functions. } *) -val head_constr : constr -> constr * constr list -val head_constr_bound : constr -> constr * constr list +val head_constr : constr -> constr +val head_constr_bound : constr -> constr val is_quantified_hypothesis : Id.t -> goal sigma -> bool exception Bound @@ -45,6 +45,9 @@ val fix : Id.t option -> int -> tactic val mutual_cofix : Id.t -> (Id.t * constr) list -> int -> tactic val cofix : Id.t option -> tactic +val convert : constr -> constr -> tactic +val convert_leq : constr -> constr -> tactic + (** {6 Introduction tactics. } *) val fresh_id_in_env : Id.t list -> Id.t -> env -> Id.t diff --git a/tactics/tauto.ml4 b/tactics/tauto.ml4 index 2a35e32d9..8d3d33510 100644 --- a/tactics/tauto.ml4 +++ b/tactics/tauto.ml4 @@ -97,16 +97,16 @@ let is_unit_or_eq flags ist = let is_record t = let (hdapp,args) = decompose_app t in match (kind_of_term hdapp) with - | Ind ind -> + | Ind (ind,u) -> let (mib,mip) = Global.lookup_inductive ind in - mib.Declarations.mind_record + mib.Declarations.mind_record <> None | _ -> false let bugged_is_binary t = isApp t && let (hdapp,args) = decompose_app t in match (kind_of_term hdapp) with - | Ind ind -> + | Ind (ind,u) -> let (mib,mip) = Global.lookup_inductive ind in Int.equal mib.Declarations.mind_nparams 2 | _ -> false @@ -319,7 +319,7 @@ let tauto_gen flags = Proofview.tclBIND (Proofview.tclUNIT ()) begin fun () -> try - let nnpp = constr_of_global (Nametab.global_of_path coq_nnpp_path) in + let nnpp = Universes.constr_of_global (Nametab.global_of_path coq_nnpp_path) in (* try intuitionistic version first to avoid an axiom if possible *) Tacticals.New.tclORELSE (tauto_intuitionistic flags) (tauto_classical flags nnpp) with Not_found -> diff --git a/tactics/termdn.ml b/tactics/termdn.ml new file mode 100644 index 000000000..1c4c4b648 --- /dev/null +++ b/tactics/termdn.ml @@ -0,0 +1,136 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Util +open Names +open Term +open Pattern +open Patternops +open Globnames + +(* Discrimination nets of terms. + See the module dn.ml for further explanations. + Eduardo (5/8/97) *) +module Make = + functor (Z : Map.OrderedType) -> +struct + + module X = struct + type t = constr_pattern + let compare = Pervasives.compare (** FIXME *) + end + + type term_label = + | GRLabel of global_reference + | ProdLabel + | LambdaLabel + | SortLabel + + module Y = struct + type t = term_label + let compare x y = + let make_name n = + match n with + | GRLabel(ConstRef con) -> + GRLabel(ConstRef(constant_of_kn(canonical_con con))) + | GRLabel(IndRef (kn,i)) -> + GRLabel(IndRef(mind_of_kn(canonical_mind kn),i)) + | GRLabel(ConstructRef ((kn,i),j ))-> + GRLabel(ConstructRef((mind_of_kn(canonical_mind kn),i),j)) + | k -> k + in + Pervasives.compare (make_name x) (make_name y) + end + + + module Dn = Dn.Make(X)(Y)(Z) + + type t = Dn.t + + type 'a lookup_res = 'a Dn.lookup_res + +(*If we have: f a b c ..., decomp gives: (f,[a;b;c;...])*) + +let decomp = + let rec decrec acc c = match kind_of_term c with + | App (f,l) -> decrec (Array.fold_right (fun a l -> a::l) l acc) f + | Cast (c1,_,_) -> decrec acc c1 + | Proj (p, c) -> decrec (c :: acc) (mkConst p) + | _ -> (c,acc) + in + decrec [] + +let decomp_pat = + let rec decrec acc = function + | PApp (f,args) -> decrec (Array.to_list args @ acc) f + | c -> (c,acc) + in + decrec [] + +let constr_pat_discr t = + if not (occur_meta_pattern t) then + None + else + match decomp_pat t with + | PRef ((IndRef _) as ref), args + | PRef ((ConstructRef _ ) as ref), args -> Some (GRLabel ref,args) + | PRef ((VarRef v) as ref), args -> Some(GRLabel ref,args) + | _ -> None + +let constr_pat_discr_st (idpred,cpred) t = + match decomp_pat t with + | PRef ((IndRef _) as ref), args + | PRef ((ConstructRef _ ) as ref), args -> Some (GRLabel ref,args) + | PRef ((VarRef v) as ref), args when not (Id.Pred.mem v idpred) -> + Some(GRLabel ref,args) + | PVar v, args when not (Id.Pred.mem v idpred) -> + Some(GRLabel (VarRef v),args) + | PRef ((ConstRef c) as ref), args when not (Cpred.mem c cpred) -> + Some (GRLabel ref, args) + | PProd (_, d, c), [] -> Some (ProdLabel, [d ; c]) + | PLambda (_, d, c), l -> Some (LambdaLabel, [d ; c] @ l) + | PSort s, [] -> Some (SortLabel, []) + | _ -> None + +open Dn + +let constr_val_discr t = + let c, l = decomp t in + match kind_of_term c with + | Ind (ind_sp,u) -> Label(GRLabel (IndRef ind_sp),l) + | Construct (cstr_sp,u) -> Label(GRLabel (ConstructRef cstr_sp),l) + | Var id -> Label(GRLabel (VarRef id),l) + | Const _ -> Everything + | Proj _ -> Everything + | _ -> Nothing + +let constr_val_discr_st (idpred,cpred) t = + let c, l = decomp t in + match kind_of_term c with + | Const (c,_) -> if Cpred.mem c cpred then Everything else Label(GRLabel (ConstRef c),l) + | Ind (ind_sp,_) -> Label(GRLabel (IndRef ind_sp),l) + | Construct (cstr_sp,_) -> Label(GRLabel (ConstructRef cstr_sp),l) + | Proj (p,c) -> if Cpred.mem p cpred then Everything else Label(GRLabel (ConstRef p),c::l) + | Var id when not (Id.Pred.mem id idpred) -> Label(GRLabel (VarRef id),l) + | Prod (n, d, c) -> Label(ProdLabel, [d; c]) + | Lambda (n, d, c) -> Label(LambdaLabel, [d; c] @ l) + | Sort _ -> Label (SortLabel, []) + | Evar _ -> Everything + | _ -> Nothing + +let create = Dn.create + +let add dn st = Dn.add dn (constr_pat_discr_st st) + +let rmv dn st = Dn.rmv dn (constr_pat_discr_st st) + +let lookup dn st t = Dn.lookup dn (constr_val_discr_st st) t + +let app f dn = Dn.app f dn + +end diff --git a/test-suite/success/Projection.v b/test-suite/success/Projection.v index d8faa88a7..3ffd41ea0 100644 --- a/test-suite/success/Projection.v +++ b/test-suite/success/Projection.v @@ -1,3 +1,9 @@ +Record foo (A : Type) := { B :> Type }. + +Lemma bar (f : foo nat) (x : f) : x = x. + destruct f. simpl B. simpl B in x. +Abort. + Structure S : Type := {Dom : Type; Op : Dom -> Dom -> Dom}. Check (fun s : S => Dom s). diff --git a/test-suite/success/indelim.v b/test-suite/success/indelim.v new file mode 100644 index 000000000..91b6dee2e --- /dev/null +++ b/test-suite/success/indelim.v @@ -0,0 +1,61 @@ +Inductive boolP : Prop := +| trueP : boolP +| falseP : boolP. + +Fail Check boolP_rect. + + +Inductive True : Prop := I : True. + +Inductive False : Prop :=. + +Inductive Empty_set : Set :=. + +Fail Inductive Large_set : Set := + large_constr : forall A : Set, A -> Large_set. + +Inductive smallunitProp : Prop := +| onlyProps : True -> smallunitProp. + +Check smallunitProp_rect. + +Inductive nonsmallunitProp : Prop := +| notonlyProps : nat -> nonsmallunitProp. + +Fail Check nonsmallunitProp_rect. +Set Printing Universes. +Inductive inferProp := +| hasonlyProps : True -> nonsmallunitProp -> inferProp. + +Check (inferProp : Prop). + +Inductive inferSet := +| hasaset : nat -> True -> nonsmallunitProp -> inferSet. + +Fail Check (inferSet : Prop). + +Check (inferSet : Set). + +Inductive inferLargeSet := +| hasalargeset : Set -> True -> nonsmallunitProp -> inferLargeSet. + +Fail Check (inferLargeSet : Set). + +Inductive largeProp : Prop := somelargeprop : Set -> largeProp. + + +Inductive comparison : Set := + | Eq : comparison + | Lt : comparison + | Gt : comparison. + +Inductive CompareSpecT (Peq Plt Pgt : Prop) : comparison -> Type := + | CompEqT : Peq -> CompareSpecT Peq Plt Pgt Eq + | CompLtT : Plt -> CompareSpecT Peq Plt Pgt Lt + | CompGtT : Pgt -> CompareSpecT Peq Plt Pgt Gt. + +Inductive color := Red | Black. + +Inductive option (A : Type) : Type := +| None : option A +| Some : A -> option A.
\ No newline at end of file diff --git a/test-suite/success/polymorphism.v b/test-suite/success/polymorphism.v index 56cab0f68..7c1166c4c 100644 --- a/test-suite/success/polymorphism.v +++ b/test-suite/success/polymorphism.v @@ -1,12 +1,249 @@ +Set Universe Polymorphism. + +Inductive empty :=. +Inductive emptyt : Type :=. +Inductive singleton : Type := + single. +Inductive singletoninfo : Type := + singleinfo : unit -> singletoninfo. +Inductive singletonset : Set := + singleset. + +Inductive singletonnoninfo : Type := + singlenoninfo : empty -> singletonnoninfo. + +Inductive singletoninfononinfo : Prop := + singleinfononinfo : unit -> singletoninfononinfo. + +Inductive bool : Type := + | true | false. + +Inductive smashedbool : Prop := + | trueP | falseP. + +Section foo. + Let T := Type. + Inductive polybool : T := + | trueT | falseT. +End foo. + +Inductive list (A: Type) : Type := +| nil : list A +| cons : A -> list A -> list A. + +Module ftypSetSet. +Inductive ftyp : Type := + | Funit : ftyp + | Ffun : list ftyp -> ftyp + | Fref : area -> ftyp +with area : Type := + | Stored : ftyp -> area +. +End ftypSetSet. + + +Module ftypSetProp. +Inductive ftyp : Type := + | Funit : ftyp + | Ffun : list ftyp -> ftyp + | Fref : area -> ftyp +with area : Type := + | Stored : (* ftyp -> *)area +. +End ftypSetProp. + +Module ftypSetSetForced. +Inductive ftyp : Type := + | Funit : ftyp + | Ffun : list ftyp -> ftyp + | Fref : area -> ftyp +with area : Set (* Type *) := + | Stored : (* ftyp -> *)area +. +End ftypSetSetForced. + +Unset Universe Polymorphism. + +Set Printing Universes. +Module Easy. + + Polymorphic Inductive prod (A : Type) (B : Type) : Type := + pair : A -> B -> prod A B. + + Check prod nat nat. + Print Universes. + + + Polymorphic Inductive sum (A B:Type) : Type := + | inl : A -> sum A B + | inr : B -> sum A B. + Print sum. + Check (sum nat nat). + +End Easy. + +Section Hierarchy. + +Definition Type3 := Type. +Definition Type2 := Type : Type3. +Definition Type1 := Type : Type2. + +Definition id1 := ((forall A : Type1, A) : Type2). +Definition id2 := ((forall A : Type2, A) : Type3). +Definition id1' := ((forall A : Type1, A) : Type3). +Fail Definition id1impred := ((forall A : Type1, A) : Type1). + +End Hierarchy. + +Section structures. + +Record hypo : Type := mkhypo { + hypo_type : Type; + hypo_proof : hypo_type + }. + +Definition typehypo (A : Type) : hypo := {| hypo_proof := A |}. + +Polymorphic Record dyn : Type := + mkdyn { + dyn_type : Type; + dyn_proof : dyn_type + }. + +Definition monotypedyn (A : Type) : dyn := {| dyn_proof := A |}. +Polymorphic Definition typedyn (A : Type) : dyn := {| dyn_proof := A |}. + +Definition atypedyn : dyn := typedyn Type. + +Definition projdyn := dyn_type atypedyn. + +Definition nested := {| dyn_type := dyn; dyn_proof := atypedyn |}. + +Definition nested2 := {| dyn_type := dyn; dyn_proof := nested |}. + +Definition projnested2 := dyn_type nested2. + +Polymorphic Definition nest (d : dyn) := {| dyn_proof := d |}. + +Polymorphic Definition twoprojs (d : dyn) := dyn_proof d = dyn_proof d. + +End structures. + +Section cats. + Local Set Universe Polymorphism. + Require Import Utf8. + Definition fibration (A : Type) := A -> Type. + Definition Hom (A : Type) := A -> A -> Type. + + Record sigma (A : Type) (P : fibration A) := + { proj1 : A; proj2 : P proj1} . + + Class Identity {A} (M : Hom A) := + identity : ∀ x, M x x. + + Class Inverse {A} (M : Hom A) := + inverse : ∀ x y:A, M x y -> M y x. + + Class Composition {A} (M : Hom A) := + composition : ∀ {x y z:A}, M x y -> M y z -> M x z. + + Notation "g ° f" := (composition f g) (at level 50). + + Class Equivalence T (Eq : Hom T):= + { + Equivalence_Identity :> Identity Eq ; + Equivalence_Inverse :> Inverse Eq ; + Equivalence_Composition :> Composition Eq + }. + + Class EquivalenceType (T : Type) : Type := + { + m2: Hom T; + equiv_struct :> Equivalence T m2 }. + + Polymorphic Record cat (T : Type) := + { cat_hom : Hom T; + cat_equiv : forall x y, EquivalenceType (cat_hom x y) }. + + Definition catType := sigma Type cat. + + Notation "[ T ]" := (proj1 T). + + Require Import Program. + + Program Definition small_cat : cat Empty_set := + {| cat_hom x y := unit |}. + Next Obligation. + refine ({|m2:=fun x y => True|}). + constructor; red; intros; trivial. + Defined. + + Record iso (T U : Set) := + { f : T -> U; + g : U -> T }. + + Program Definition Set_cat : cat Set := + {| cat_hom := iso |}. + Next Obligation. + refine ({|m2:=fun x y => True|}). + constructor; red; intros; trivial. + Defined. + + Record isoT (T U : Type) := + { isoT_f : T -> U; + isoT_g : U -> T }. + + Program Definition Type_cat : cat Type := + {| cat_hom := isoT |}. + Next Obligation. + refine ({|m2:=fun x y => True|}). + constructor; red; intros; trivial. + Defined. + + Polymorphic Record cat1 (T : Type) := + { cat1_car : Type; + cat1_hom : Hom cat1_car; + cat1_hom_cat : forall x y, cat (cat1_hom x y) }. +End cats. + +Polymorphic Definition id {A : Type} (a : A) : A := a. + +Definition typeid := (@id Type). + + + + (* Some tests of sort-polymorphisme *) Section S. -Variable A:Type. +Polymorphic Variable A:Type. (* Definition f (B:Type) := (A * B)%type. *) -Inductive I (B:Type) : Type := prod : A->B->I B. +Polymorphic Inductive I (B:Type) : Type := prod : A->B->I B. + +Check I nat. + End S. (* Check f nat nat : Set. *) -Check I nat nat : Set.
\ No newline at end of file +Definition foo:= I nat nat : Set. +Print Universes. Print foo. Set Printing Universes. Print foo. + +(* Polymorphic axioms: *) +Polymorphic Axiom funext : forall (A B : Type) (f g : A -> B), + (forall x, f x = g x) -> f = g. + +(* Check @funext. *) +(* Check funext. *) + +Polymorphic Definition fun_ext (A B : Type) := + forall (f g : A -> B), + (forall x, f x = g x) -> f = g. + +Polymorphic Class Funext A B := extensional : fun_ext A B. + +Section foo. + Context `{forall A B, Funext A B}. + Print Universes. +End foo. diff --git a/theories/Arith/Compare_dec.v b/theories/Arith/Compare_dec.v index a90a9ce99..76132aed0 100644 --- a/theories/Arith/Compare_dec.v +++ b/theories/Arith/Compare_dec.v @@ -201,7 +201,7 @@ Qed. Lemma nat_compare_spec : forall x y, CompareSpec (x=y) (x<y) (y<x) (nat_compare x y). Proof. - intros. + intros. destruct (nat_compare x y) eqn:?; constructor. apply nat_compare_eq; auto. apply <- nat_compare_lt; auto. diff --git a/theories/Arith/Le.v b/theories/Arith/Le.v index 1febb76b6..c3386787d 100644 --- a/theories/Arith/Le.v +++ b/theories/Arith/Le.v @@ -54,7 +54,7 @@ Hint Resolve le_0_n le_Sn_0: arith v62. Theorem le_n_0_eq : forall n, n <= 0 -> 0 = n. Proof. - induction n; auto with arith. + induction n. auto with arith. idtac. auto with arith. intro; contradiction le_Sn_0 with n. Qed. Hint Immediate le_n_0_eq: arith v62. diff --git a/theories/Classes/CEquivalence.v b/theories/Classes/CEquivalence.v new file mode 100644 index 000000000..68a6dcd63 --- /dev/null +++ b/theories/Classes/CEquivalence.v @@ -0,0 +1,139 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** * Typeclass-based setoids. Definitions on [Equivalence]. + + Author: Matthieu Sozeau + Institution: LRI, CNRS UMR 8623 - University Paris Sud +*) + +Require Import Coq.Program.Basics. +Require Import Coq.Program.Tactics. + +Require Import Coq.Classes.Init. +Require Import Relation_Definitions. +Require Export Coq.Classes.RelationClasses. +Require Import Coq.Classes.Morphisms. + +Set Implicit Arguments. +Unset Strict Implicit. + +Generalizable Variables A R eqA B S eqB. +Local Obligation Tactic := try solve [simpl_crelation]. + +Local Open Scope signature_scope. + +Definition equiv `{Equivalence A R} : crelation A := R. + +(** Overloaded notations for setoid equivalence and inequivalence. + Not to be confused with [eq] and [=]. *) + +Notation " x === y " := (equiv x y) (at level 70, no associativity) : equiv_scope. + +Notation " x =/= y " := (complement equiv x y) (at level 70, no associativity) : equiv_scope. + +Local Open Scope equiv_scope. + +(** Overloading for [PER]. *) + +Definition pequiv `{PER A R} : crelation A := R. + +(** Overloaded notation for partial equivalence. *) + +Infix "=~=" := pequiv (at level 70, no associativity) : equiv_scope. + +(** Shortcuts to make proof search easier. *) + +Program Instance equiv_reflexive `(sa : Equivalence A) : Reflexive equiv. + +Program Instance equiv_symmetric `(sa : Equivalence A) : Symmetric equiv. + +Program Instance equiv_transitive `(sa : Equivalence A) : Transitive equiv. + + Next Obligation. + Proof. intros A R sa x y z Hxy Hyz. + now transitivity y. + Qed. + +(** Use the [substitute] command which substitutes an equivalence in every hypothesis. *) + +Ltac setoid_subst H := + match type of H with + ?x === ?y => substitute H ; clear H x + end. + +Ltac setoid_subst_nofail := + match goal with + | [ H : ?x === ?y |- _ ] => setoid_subst H ; setoid_subst_nofail + | _ => idtac + end. + +(** [subst*] will try its best at substituting every equality in the goal. *) + +Tactic Notation "subst" "*" := subst_no_fail ; setoid_subst_nofail. + +(** Simplify the goal w.r.t. equivalence. *) + +Ltac equiv_simplify_one := + match goal with + | [ H : ?x === ?x |- _ ] => clear H + | [ H : ?x === ?y |- _ ] => setoid_subst H + | [ |- ?x =/= ?y ] => let name:=fresh "Hneq" in intro name + | [ |- ~ ?x === ?y ] => let name:=fresh "Hneq" in intro name + end. + +Ltac equiv_simplify := repeat equiv_simplify_one. + +(** "reify" relations which are equivalences to applications of the overloaded [equiv] method + for easy recognition in tactics. *) + +Ltac equivify_tac := + match goal with + | [ s : Equivalence ?A ?R, H : ?R ?x ?y |- _ ] => change R with (@equiv A R s) in H + | [ s : Equivalence ?A ?R |- context C [ ?R ?x ?y ] ] => change (R x y) with (@equiv A R s x y) + end. + +Ltac equivify := repeat equivify_tac. + +Section Respecting. + + (** Here we build an equivalence instance for functions which relates respectful ones only, + we do not export it. *) + + Definition respecting `(eqa : Equivalence A (R : crelation A), + eqb : Equivalence B (R' : crelation B)) : Type := + { morph : A -> B | respectful R R' morph morph }. + + Program Instance respecting_equiv `(eqa : Equivalence A R, eqb : Equivalence B R') : + Equivalence (fun (f g : respecting eqa eqb) => + forall (x y : A), R x y -> R' (proj1_sig f x) (proj1_sig g y)). + + Solve Obligations with unfold respecting in * ; simpl_crelation ; program_simpl. + + Next Obligation. + Proof. + intros. intros f g h H H' x y Rxy. + unfold respecting in *. program_simpl. transitivity (g y); auto. firstorder. + Qed. + +End Respecting. + +(** The default equivalence on function spaces, with higher-priority than [eq]. *) + +Instance pointwise_reflexive {A} `(reflb : Reflexive B eqB) : + Reflexive (pointwise_relation A eqB) | 9. +Proof. firstorder. Qed. +Instance pointwise_symmetric {A} `(symb : Symmetric B eqB) : + Symmetric (pointwise_relation A eqB) | 9. +Proof. firstorder. Qed. +Instance pointwise_transitive {A} `(transb : Transitive B eqB) : + Transitive (pointwise_relation A eqB) | 9. +Proof. firstorder. Qed. +Instance pointwise_equivalence {A} `(eqb : Equivalence B eqB) : + Equivalence (pointwise_relation A eqB) | 9. +Proof. split; apply _. Qed. diff --git a/theories/Classes/CMorphisms.v b/theories/Classes/CMorphisms.v new file mode 100644 index 000000000..5737c88b5 --- /dev/null +++ b/theories/Classes/CMorphisms.v @@ -0,0 +1,799 @@ +(* -*- coding: utf-8 -*- *) +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** * Typeclass-based morphism definition and standard, minimal instances + + Author: Matthieu Sozeau + Institution: LRI, CNRS UMR 8623 - University Paris Sud +*) + +Require Import Coq.Program.Basics. +Require Import Coq.Program.Tactics. +Require Export Coq.Classes.RelationClasses. + +Generalizable Variables A eqA B C D R RA RB RC m f x y. +Local Obligation Tactic := simpl_crelation. + +Set Universe Polymorphism. + +(** * Morphisms. + + We now turn to the definition of [Proper] and declare standard instances. + These will be used by the [setoid_rewrite] tactic later. *) + +(** A morphism for a relation [R] is a proper element of the relation. + The relation [R] will be instantiated by [respectful] and [A] by an arrow + type for usual morphisms. *) +Section Proper. + Let U := Type. + Context {A B : U}. + + Class Proper (R : crelation A) (m : A) := + proper_prf : R m m. + + (** Every element in the carrier of a reflexive relation is a morphism + for this relation. We use a proxy class for this case which is used + internally to discharge reflexivity constraints. The [Reflexive] + instance will almost always be used, but it won't apply in general to + any kind of [Proper (A -> B) _ _] goal, making proof-search much + slower. A cleaner solution would be to be able to set different + priorities in different hint bases and select a particular hint + database for resolution of a type class constraint. *) + + Class ProperProxy (R : crelation A) (m : A) := + proper_proxy : R m m. + + Lemma eq_proper_proxy (x : A) : ProperProxy (@eq A) x. + Proof. firstorder. Qed. + + Lemma reflexive_proper_proxy `(Reflexive A R) (x : A) : ProperProxy R x. + Proof. firstorder. Qed. + + Lemma proper_proper_proxy x `(Proper R x) : ProperProxy R x. + Proof. firstorder. Qed. + + (** Respectful morphisms. *) + + (** The fully dependent version, not used yet. *) + + Definition respectful_hetero + (A B : Type) + (C : A -> Type) (D : B -> Type) + (R : A -> B -> Type) + (R' : forall (x : A) (y : B), C x -> D y -> Type) : + (forall x : A, C x) -> (forall x : B, D x) -> Type := + fun f g => forall x y, R x y -> R' x y (f x) (g y). + + (** The non-dependent version is an instance where we forget dependencies. *) + + Definition respectful (R : crelation A) (R' : crelation B) : crelation (A -> B) := + Eval compute in @respectful_hetero A A (fun _ => B) (fun _ => B) R (fun _ _ => R'). + +End Proper. + +(** We favor the use of Leibniz equality or a declared reflexive crelation + when resolving [ProperProxy], otherwise, if the crelation is given (not an evar), + we fall back to [Proper]. *) +Hint Extern 1 (ProperProxy _ _) => + class_apply @eq_proper_proxy || class_apply @reflexive_proper_proxy : typeclass_instances. + +Hint Extern 2 (ProperProxy ?R _) => + not_evar R; class_apply @proper_proper_proxy : typeclass_instances. + +(** Notations reminiscent of the old syntax for declaring morphisms. *) +Delimit Scope signature_scope with signature. + +Module ProperNotations. + + Notation " R ++> R' " := (@respectful _ _ (R%signature) (R'%signature)) + (right associativity, at level 55) : signature_scope. + + Notation " R ==> R' " := (@respectful _ _ (R%signature) (R'%signature)) + (right associativity, at level 55) : signature_scope. + + Notation " R --> R' " := (@respectful _ _ (flip (R%signature)) (R'%signature)) + (right associativity, at level 55) : signature_scope. + +End ProperNotations. + +Arguments Proper {A}%type R%signature m. +Arguments respectful {A B}%type (R R')%signature _ _. + +Export ProperNotations. + +Local Open Scope signature_scope. + +(** [solve_proper] try to solve the goal [Proper (?==> ... ==>?) f] + by repeated introductions and setoid rewrites. It should work + fine when [f] is a combination of already known morphisms and + quantifiers. *) + +Ltac solve_respectful t := + match goal with + | |- respectful _ _ _ _ => + let H := fresh "H" in + intros ? ? H; solve_respectful ltac:(setoid_rewrite H; t) + | _ => t; reflexivity + end. + +Ltac solve_proper := unfold Proper; solve_respectful ltac:(idtac). + +(** [f_equiv] is a clone of [f_equal] that handles setoid equivalences. + For example, if we know that [f] is a morphism for [E1==>E2==>E], + then the goal [E (f x y) (f x' y')] will be transformed by [f_equiv] + into the subgoals [E1 x x'] and [E2 y y']. +*) + +Ltac f_equiv := + match goal with + | |- ?R (?f ?x) (?f' _) => + let T := type of x in + let Rx := fresh "R" in + evar (Rx : crelation T); + let H := fresh in + assert (H : (Rx==>R)%signature f f'); + unfold Rx in *; clear Rx; [ f_equiv | apply H; clear H; try reflexivity ] + | |- ?R ?f ?f' => + solve [change (Proper R f); eauto with typeclass_instances | reflexivity ] + | _ => idtac + end. + +Section Relations. + Let U := Type. + Context {A B : U}. + + (** [forall_def] reifies the dependent product as a definition. *) + + Definition forall_def (P : A -> U) : Type := forall x : A, P x. + + (** Dependent pointwise lifting of a crelation on the range. *) + + Definition forall_relation (P : A -> U) + (sig : forall a, crelation (P a)) : crelation (forall x, P x) := + fun f g => forall a, sig a (f a) (g a). + + (** Non-dependent pointwise lifting *) + Definition pointwise_relation (R : crelation B) : crelation (A -> B) := + fun f g => forall a, R (f a) (g a). + + Lemma pointwise_pointwise (R : crelation B) : + relation_equivalence (pointwise_relation R) (@eq A ==> R). + Proof. intros. split. simpl_crelation. firstorder. Qed. + + (** Subcrelations induce a morphism on the identity. *) + + Global Instance subrelation_id_proper `(subrelation A RA RA') : Proper (RA ==> RA') id. + Proof. firstorder. Qed. + + (** The subrelation property goes through products as usual. *) + + Lemma subrelation_respectful `(subl : subrelation A RA' RA, subr : subrelation B RB RB') : + subrelation (RA ==> RB) (RA' ==> RB'). + Proof. simpl_crelation. Qed. + + (** And of course it is reflexive. *) + + Lemma subrelation_refl R : @subrelation A R R. + Proof. simpl_crelation. Qed. + + (** [Proper] is itself a covariant morphism for [subrelation]. + We use an unconvertible premise to avoid looping. + *) + + Lemma subrelation_proper `(mor : Proper A R' m) + `(unc : Unconvertible (crelation A) R R') + `(sub : subrelation A R' R) : Proper R m. + Proof. + intros. apply sub. apply mor. + Qed. + + Global Instance proper_subrelation_proper : + Proper (subrelation ++> eq ==> impl) (@Proper A). + Proof. reduce. subst. firstorder. Qed. + + Global Instance proper_subrelation_proper_arrow : + Proper (subrelation ++> eq ==> arrow) (@Proper A). + Proof. reduce. subst. firstorder. Qed. + + Global Instance pointwise_subrelation `(sub : subrelation B R R') : + subrelation (pointwise_relation R) (pointwise_relation R') | 4. + Proof. reduce. unfold pointwise_relation in *. apply sub. auto. Qed. + + (** For dependent function types. *) + Lemma forall_subrelation (P : A -> U) (R S : forall x : A, crelation (P x)) : + (forall a, subrelation (R a) (S a)) -> + subrelation (forall_relation P R) (forall_relation P S). + Proof. reduce. firstorder. Qed. +End Relations. + +Typeclasses Opaque respectful pointwise_relation forall_relation. +Arguments forall_relation {A P}%type sig%signature _ _. +Arguments pointwise_relation A%type {B}%type R%signature _ _. + +Hint Unfold Reflexive : core. +Hint Unfold Symmetric : core. +Hint Unfold Transitive : core. + +(** Resolution with subrelation: favor decomposing products over applying reflexivity + for unconstrained goals. *) +Ltac subrelation_tac T U := + (is_ground T ; is_ground U ; class_apply @subrelation_refl) || + class_apply @subrelation_respectful || class_apply @subrelation_refl. + +Hint Extern 3 (@subrelation _ ?T ?U) => subrelation_tac T U : typeclass_instances. + +CoInductive apply_subrelation : Prop := do_subrelation. + +Ltac proper_subrelation := + match goal with + [ H : apply_subrelation |- _ ] => clear H ; class_apply @subrelation_proper + end. + +Hint Extern 5 (@Proper _ ?H _) => proper_subrelation : typeclass_instances. + +(** Essential subrelation instances for [iff], [impl] and [pointwise_relation]. *) + +Instance iff_impl_subrelation : subrelation iff impl | 2. +Proof. firstorder. Qed. + +Instance iff_flip_impl_subrelation : subrelation iff (flip impl) | 2. +Proof. firstorder. Qed. + +(** Essential subrelation instances for [iffT] and [arrow]. *) + +Instance iffT_arrow_subrelation : subrelation iffT arrow | 2. +Proof. firstorder. Qed. + +Instance iffT_flip_arrow_subrelation : subrelation iffT (flip arrow) | 2. +Proof. firstorder. Qed. + +(** We use an extern hint to help unification. *) + +Hint Extern 4 (subrelation (@forall_relation ?A ?B ?R) (@forall_relation _ _ ?S)) => + apply (@forall_subrelation A B R S) ; intro : typeclass_instances. + +Section GenericInstances. + (* Share universes *) + Let U := Type. + Context {A B C : U}. + + (** We can build a PER on the Coq function space if we have PERs on the domain and + codomain. *) + + Program Instance respectful_per `(PER A R, PER B R') : PER (R ==> R'). + + Next Obligation. + Proof with auto. + assert(R x0 x0). + transitivity y0... symmetry... + transitivity (y x0)... + Qed. + + (** The complement of a crelation conserves its proper elements. *) + + Program Definition complement_proper + `(mR : Proper (A -> A -> Prop) (RA ==> RA ==> iff) R) : + Proper (RA ==> RA ==> iff) (complement R) := _. + + Next Obligation. + Proof. + unfold complement. + pose (mR x y X x0 y0 X0). + intuition. + Qed. + + (** The [flip] too, actually the [flip] instance is a bit more general. *) + + Program Definition flip_proper + `(mor : Proper (A -> B -> C) (RA ==> RB ==> RC) f) : + Proper (RB ==> RA ==> RC) (flip f) := _. + + Next Obligation. + Proof. + apply mor ; auto. + Qed. + + + (** Every Transitive crelation gives rise to a binary morphism on [impl], + contravariant in the first argument, covariant in the second. *) + + Global Program + Instance trans_contra_co_morphism + `(Transitive A R) : Proper (R --> R ++> impl) R. + + Next Obligation. + Proof with auto. + transitivity x... + transitivity x0... + Qed. + + Global Program + Instance trans_contra_co_type_morphism + `(Transitive A R) : Proper (R --> R ++> arrow) R. + + Next Obligation. + Proof with auto. + transitivity x... + transitivity x0... + Qed. + + (** Proper declarations for partial applications. *) + + Global Program + Instance trans_contra_inv_impl_morphism + `(Transitive A R) : Proper (R --> flip impl) (R x) | 3. + + Next Obligation. + Proof with auto. + transitivity y... + Qed. + + Global Program + Instance trans_contra_inv_impl_type_morphism + `(Transitive A R) : Proper (R --> flip arrow) (R x) | 3. + + Next Obligation. + Proof with auto. + transitivity y... + Qed. + + Global Program + Instance trans_co_impl_morphism + `(Transitive A R) : Proper (R ++> impl) (R x) | 3. + + Next Obligation. + Proof with auto. + transitivity x0... + Qed. + + Global Program + Instance trans_co_impl_type_morphism + `(Transitive A R) : Proper (R ++> arrow) (R x) | 3. + + Next Obligation. + Proof with auto. + transitivity x0... + Qed. + + Global Program + Instance trans_sym_co_inv_impl_morphism + `(PER A R) : Proper (R ++> flip impl) (R x) | 3. + + Next Obligation. + Proof with auto. + transitivity y... symmetry... + Qed. + + Global Program + Instance trans_sym_co_inv_impl_type_morphism + `(PER A R) : Proper (R ++> flip arrow) (R x) | 3. + + Next Obligation. + Proof with auto. + transitivity y... symmetry... + Qed. + + Global Program Instance trans_sym_contra_impl_morphism + `(PER A R) : Proper (R --> impl) (R x) | 3. + + Next Obligation. + Proof with auto. + transitivity x0... symmetry... + Qed. + + Global Program Instance trans_sym_contra_arrow_morphism + `(PER A R) : Proper (R --> arrow) (R x) | 3. + + Next Obligation. + Proof with auto. + transitivity x0... symmetry... + Qed. + + Global Program Instance per_partial_app_morphism + `(PER A R) : Proper (R ==> iff) (R x) | 2. + + Next Obligation. + Proof with auto. + split. intros ; transitivity x0... + intros. + transitivity y... + symmetry... + Qed. + + Global Program Instance per_partial_app_type_morphism + `(PER A R) : Proper (R ==> iffT) (R x) | 2. + + Next Obligation. + Proof with auto. + split. intros ; transitivity x0... + intros. + transitivity y... + symmetry... + Qed. + + (** Every Transitive crelation induces a morphism by "pushing" an [R x y] on the left of an [R x z] proof to get an [R y z] goal. *) + + Global Program + Instance trans_co_eq_inv_impl_morphism + `(Transitive A R) : Proper (R ==> (@eq A) ==> flip impl) R | 2. + + Next Obligation. + Proof with auto. + transitivity y... + Qed. + + Global Program + Instance trans_co_eq_inv_arrow_morphism + `(Transitive A R) : Proper (R ==> (@eq A) ==> flip arrow) R | 2. + + Next Obligation. + Proof with auto. + transitivity y... + Qed. + + (** Every Symmetric and Transitive crelation gives rise to an equivariant morphism. *) + + Global Program + Instance PER_morphism `(PER A R) : Proper (R ==> R ==> iff) R | 1. + + Next Obligation. + Proof with auto. + split ; intros. + transitivity x0... transitivity x... symmetry... + + transitivity y... transitivity y0... symmetry... + Qed. + + (** Every Symmetric and Transitive crelation gives rise to an equivariant morphism. *) + + Global Program + Instance PER_type_morphism `(PER A R) : Proper (R ==> R ==> iffT) R | 1. + + Next Obligation. + Proof with auto. + split ; intros. + transitivity x0... transitivity x... symmetry... + + transitivity y... transitivity y0... symmetry... + Qed. + + Lemma symmetric_equiv_flip `(Symmetric A R) : relation_equivalence R (flip R). + Proof. firstorder. Qed. + + Global Program Instance compose_proper RA RB RC : + Proper ((RB ==> RC) ==> (RA ==> RB) ==> (RA ==> RC)) (@compose A B C). + + Next Obligation. + Proof. + simpl_crelation. + unfold compose. firstorder. + Qed. + + (** Coq functions are morphisms for Leibniz equality, + applied only if really needed. *) + + Global Instance reflexive_eq_dom_reflexive `(Reflexive B R') : + Reflexive (@Logic.eq A ==> R'). + Proof. simpl_crelation. Qed. + + (** [respectful] is a morphism for crelation equivalence. *) + + Global Instance respectful_morphism : + Proper (relation_equivalence ++> relation_equivalence ++> relation_equivalence) + (@respectful A B). + Proof. + intros R R' HRR' S S' HSS' f g. + unfold respectful, relation_equivalence in * ; simpl in *. + split ; intros H x y Hxy. + setoid_rewrite <- HSS'. apply H. now rewrite HRR'. + rewrite HSS'. apply H. now rewrite <- HRR'. + Qed. + + (** [R] is Reflexive, hence we can build the needed proof. *) + + Lemma Reflexive_partial_app_morphism `(Proper (A -> B) (R ==> R') m, ProperProxy A R x) : + Proper R' (m x). + Proof. simpl_crelation. Qed. + + Class Params (of : A) (arity : nat). + + Lemma flip_respectful (R : crelation A) (R' : crelation B) : + relation_equivalence (flip (R ==> R')) (flip R ==> flip R'). + Proof. + intros. + unfold flip, respectful. + split ; intros ; intuition. + Qed. + + + (** Treating flip: can't make them direct instances as we + need at least a [flip] present in the goal. *) + + Lemma flip1 `(subrelation A R' R) : subrelation (flip (flip R')) R. + Proof. firstorder. Qed. + + Lemma flip2 `(subrelation A R R') : subrelation R (flip (flip R')). + Proof. firstorder. Qed. + + (** That's if and only if *) + + Lemma eq_subrelation `(Reflexive A R) : subrelation (@eq A) R. + Proof. simpl_crelation. Qed. + + (** Once we have normalized, we will apply this instance to simplify the problem. *) + + Definition proper_flip_proper `(mor : Proper A R m) : Proper (flip R) m := mor. + + (** Every reflexive crelation gives rise to a morphism, + only for immediately solving goals without variables. *) + + Lemma reflexive_proper `{Reflexive A R} (x : A) : Proper R x. + Proof. firstorder. Qed. + + Lemma proper_eq (x : A) : Proper (@eq A) x. + Proof. intros. apply reflexive_proper. Qed. + +End GenericInstances. + +Class PartialApplication. + +CoInductive normalization_done : Prop := did_normalization. + +Ltac partial_application_tactic := + let rec do_partial_apps H m cont := + match m with + | ?m' ?x => class_apply @Reflexive_partial_app_morphism ; + [(do_partial_apps H m' ltac:idtac)|clear H] + | _ => cont + end + in + let rec do_partial H ar m := + match ar with + | 0%nat => do_partial_apps H m ltac:(fail 1) + | S ?n' => + match m with + ?m' ?x => do_partial H n' m' + end + end + in + let params m sk fk := + (let m' := fresh in head_of_constr m' m ; + let n := fresh in evar (n:nat) ; + let v := eval compute in n in clear n ; + let H := fresh in + assert(H:Params m' v) by typeclasses eauto ; + let v' := eval compute in v in subst m'; + (sk H v' || fail 1)) + || fk + in + let on_morphism m cont := + params m ltac:(fun H n => do_partial H n m) + ltac:(cont) + in + match goal with + | [ _ : normalization_done |- _ ] => fail 1 + | [ _ : @Params _ _ _ |- _ ] => fail 1 + | [ |- @Proper ?T _ (?m ?x) ] => + match goal with + | [ H : PartialApplication |- _ ] => + class_apply @Reflexive_partial_app_morphism; [|clear H] + | _ => on_morphism (m x) + ltac:(class_apply @Reflexive_partial_app_morphism) + end + end. + +(** Bootstrap !!! *) + +Instance proper_proper : Proper (relation_equivalence ==> eq ==> iffT) (@Proper A). +Proof. + intros A R R' HRR' x y <-. red in HRR'. + split ; red ; intros. + now setoid_rewrite <- HRR'. + now setoid_rewrite HRR'. +Qed. + +Ltac proper_reflexive := + match goal with + | [ _ : normalization_done |- _ ] => fail 1 + | _ => class_apply proper_eq || class_apply @reflexive_proper + end. + + +Hint Extern 1 (subrelation (flip _) _) => class_apply @flip1 : typeclass_instances. +Hint Extern 1 (subrelation _ (flip _)) => class_apply @flip2 : typeclass_instances. + +Hint Extern 1 (Proper _ (complement _)) => apply @complement_proper + : typeclass_instances. +Hint Extern 1 (Proper _ (flip _)) => apply @flip_proper + : typeclass_instances. +Hint Extern 2 (@Proper _ (flip _) _) => class_apply @proper_flip_proper + : typeclass_instances. +Hint Extern 4 (@Proper _ _ _) => partial_application_tactic + : typeclass_instances. +Hint Extern 7 (@Proper _ _ _) => proper_reflexive + : typeclass_instances. + +(** Special-purpose class to do normalization of signatures w.r.t. flip. *) + +Section Normalize. + Context (A : Type). + + Class Normalizes (m : crelation A) (m' : crelation A) : Prop := + normalizes : relation_equivalence m m'. + + (** Current strategy: add [flip] everywhere and reduce using [subrelation] + afterwards. *) + + Lemma proper_normalizes_proper `(Normalizes R0 R1, Proper A R1 m) : Proper R0 m. + Proof. + red in H, H0. red in H. + setoid_rewrite H. + assumption. + Qed. + + Lemma flip_atom R : Normalizes R (flip (flip R)). + Proof. + firstorder. + Qed. + +End Normalize. + +Lemma flip_arrow `(NA : Normalizes A R (flip R'''), NB : Normalizes B R' (flip R'')) : + Normalizes (A -> B) (R ==> R') (flip (R''' ==> R'')%signature). +Proof. + unfold Normalizes in *. intros. + rewrite NA, NB. firstorder. +Qed. + +Ltac normalizes := + match goal with + | [ |- Normalizes _ (respectful _ _) _ ] => class_apply @flip_arrow + | _ => class_apply @flip_atom + end. + +Ltac proper_normalization := + match goal with + | [ _ : normalization_done |- _ ] => fail 1 + | [ _ : apply_subrelation |- @Proper _ ?R _ ] => + let H := fresh "H" in + set(H:=did_normalization) ; class_apply @proper_normalizes_proper + end. + +Hint Extern 1 (Normalizes _ _ _) => normalizes : typeclass_instances. +Hint Extern 6 (@Proper _ _ _) => proper_normalization + : typeclass_instances. + +(** When the crelation on the domain is symmetric, we can + flip the crelation on the codomain. Same for binary functions. *) + +Lemma proper_sym_flip : + forall `(Symmetric A R1)`(Proper (A->B) (R1==>R2) f), + Proper (R1==>flip R2) f. +Proof. +intros A R1 Sym B R2 f Hf. +intros x x' Hxx'. apply Hf, Sym, Hxx'. +Qed. + +Lemma proper_sym_flip_2 : + forall `(Symmetric A R1)`(Symmetric B R2)`(Proper (A->B->C) (R1==>R2==>R3) f), + Proper (R1==>R2==>flip R3) f. +Proof. +intros A R1 Sym1 B R2 Sym2 C R3 f Hf. +intros x x' Hxx' y y' Hyy'. apply Hf; auto. +Qed. + +(** When the crelation on the domain is symmetric, a predicate is + compatible with [iff] as soon as it is compatible with [impl]. + Same with a binary crelation. *) + +Lemma proper_sym_impl_iff : forall `(Symmetric A R)`(Proper _ (R==>impl) f), + Proper (R==>iff) f. +Proof. +intros A R Sym f Hf x x' Hxx'. repeat red in Hf. split; eauto. +Qed. + +Lemma proper_sym_arrow_iffT : forall `(Symmetric A R)`(Proper _ (R==>arrow) f), + Proper (R==>iffT) f. +Proof. +intros A R Sym f Hf x x' Hxx'. repeat red in Hf. split; eauto. +Qed. + +Lemma proper_sym_impl_iff_2 : + forall `(Symmetric A R)`(Symmetric B R')`(Proper _ (R==>R'==>impl) f), + Proper (R==>R'==>iff) f. +Proof. +intros A R Sym B R' Sym' f Hf x x' Hxx' y y' Hyy'. +repeat red in Hf. split; eauto. +Qed. + +Lemma proper_sym_arrow_iffT_2 : + forall `(Symmetric A R)`(Symmetric B R')`(Proper _ (R==>R'==>arrow) f), + Proper (R==>R'==>iffT) f. +Proof. +intros A R Sym B R' Sym' f Hf x x' Hxx' y y' Hyy'. +repeat red in Hf. split; eauto. +Qed. + +(** A [PartialOrder] is compatible with its underlying equivalence. *) +Require Import Relation_Definitions. +Instance PartialOrder_proper `(PartialOrder A eqA (R : relation A)) : + Proper (eqA==>eqA==>iff) R. +Proof. +intros. +apply proper_sym_impl_iff_2; auto with *. +intros x x' Hx y y' Hy Hr. +transitivity x. +generalize (partial_order_equivalence x x'); compute; intuition. +transitivity y; auto. +generalize (partial_order_equivalence y y'); compute; intuition. +Qed. + +Instance PartialOrder_proper_type `(PartialOrder A eqA R) : + Proper (eqA==>eqA==>iffT) R. +Proof. +intros. +apply proper_sym_arrow_iffT_2; auto with *. +intros x x' Hx y y' Hy Hr. +transitivity x. +generalize (partial_order_equivalence x x'); compute; intuition. +transitivity y; auto. +generalize (partial_order_equivalence y y'); compute; intuition. +Qed. + +(** From a [PartialOrder] to the corresponding [StrictOrder]: + [lt = le /\ ~eq]. + If the order is total, we could also say [gt = ~le]. *) + +Lemma PartialOrder_StrictOrder `(PartialOrder A eqA R) : + StrictOrder (relation_conjunction R (complement eqA)). +Proof. +split; compute. +intros x (_,Hx). apply Hx, Equivalence_Reflexive. +intros x y z (Hxy,Hxy') (Hyz,Hyz'). split. +apply PreOrder_Transitive with y; assumption. +intro Hxz. +apply Hxy'. +apply partial_order_antisym; auto. +rewrite Hxz. auto. +Qed. + +(** From a [StrictOrder] to the corresponding [PartialOrder]: + [le = lt \/ eq]. + If the order is total, we could also say [ge = ~lt]. *) + +Lemma StrictOrder_PreOrder + `(Equivalence A eqA, StrictOrder A R, Proper _ (eqA==>eqA==>iffT) R) : + PreOrder (relation_disjunction R eqA). +Proof. +split. +intros x. right. reflexivity. +intros x y z [Hxy|Hxy] [Hyz|Hyz]. +left. transitivity y; auto. +left. rewrite <- Hyz; auto. +left. rewrite Hxy; auto. +right. transitivity y; auto. +Qed. + +Hint Extern 4 (PreOrder (relation_disjunction _ _)) => + class_apply StrictOrder_PreOrder : typeclass_instances. + +Lemma StrictOrder_PartialOrder + `(Equivalence A eqA, StrictOrder A R, Proper _ (eqA==>eqA==>iffT) R) : + PartialOrder eqA (relation_disjunction R eqA). +Proof. +intros. intros x y. compute. intuition. +elim (StrictOrder_Irreflexive x). +transitivity y; auto. +Qed. + +Hint Extern 4 (StrictOrder (relation_conjunction _ _)) => + class_apply PartialOrder_StrictOrder : typeclass_instances. + +Hint Extern 4 (PartialOrder _ (relation_disjunction _ _)) => + class_apply StrictOrder_PartialOrder : typeclass_instances. diff --git a/theories/Classes/CRelationClasses.v b/theories/Classes/CRelationClasses.v new file mode 100644 index 000000000..ca38ac5b4 --- /dev/null +++ b/theories/Classes/CRelationClasses.v @@ -0,0 +1,354 @@ +(* -*- coding: utf-8 -*- *) +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** * Typeclass-based relations, tactics and standard instances + + This is the basic theory needed to formalize morphisms and setoids. + + Author: Matthieu Sozeau + Institution: LRI, CNRS UMR 8623 - University Paris Sud +*) + +Require Export Coq.Classes.Init. +Require Import Coq.Program.Basics. +Require Import Coq.Program.Tactics. + +Generalizable Variables A B C D R S T U l eqA eqB eqC eqD. + +Set Universe Polymorphism. + +Definition crelation (A : Type) := A -> A -> Type. + +Definition iffT (A B : Type) := ((A -> B) * (B -> A))%type. + +(** We allow to unfold the [crelation] definition while doing morphism search. *) + +Section Defs. + Context {A : Type}. + + (** We rebind crelational properties in separate classes to be able to overload each proof. *) + + Class Reflexive (R : crelation A) := + reflexivity : forall x : A, R x x. + + Definition complement (R : crelation A) : crelation A := + fun x y => R x y -> False. + + (** Opaque for proof-search. *) + Typeclasses Opaque complement iffT. + + (** These are convertible. *) + Lemma complement_inverse R : complement (flip R) = flip (complement R). + Proof. reflexivity. Qed. + + Class Irreflexive (R : crelation A) := + irreflexivity : Reflexive (complement R). + + Class Symmetric (R : crelation A) := + symmetry : forall {x y}, R x y -> R y x. + + Class Asymmetric (R : crelation A) := + asymmetry : forall {x y}, R x y -> (complement R y x : Type). + + Class Transitive (R : crelation A) := + transitivity : forall {x y z}, R x y -> R y z -> R x z. + + (** Various combinations of reflexivity, symmetry and transitivity. *) + + (** A [PreOrder] is both Reflexive and Transitive. *) + + Class PreOrder (R : crelation A) := { + PreOrder_Reflexive :> Reflexive R | 2 ; + PreOrder_Transitive :> Transitive R | 2 }. + + (** A [StrictOrder] is both Irreflexive and Transitive. *) + + Class StrictOrder (R : crelation A) := { + StrictOrder_Irreflexive :> Irreflexive R ; + StrictOrder_Transitive :> Transitive R }. + + (** By definition, a strict order is also asymmetric *) + Global Instance StrictOrder_Asymmetric `(StrictOrder R) : Asymmetric R. + Proof. firstorder. Qed. + + (** A partial equivalence crelation is Symmetric and Transitive. *) + + Class PER (R : crelation A) := { + PER_Symmetric :> Symmetric R | 3 ; + PER_Transitive :> Transitive R | 3 }. + + (** Equivalence crelations. *) + + Class Equivalence (R : crelation A) := { + Equivalence_Reflexive :> Reflexive R ; + Equivalence_Symmetric :> Symmetric R ; + Equivalence_Transitive :> Transitive R }. + + (** An Equivalence is a PER plus reflexivity. *) + + Global Instance Equivalence_PER {R} `(Equivalence R) : PER R | 10 := + { PER_Symmetric := Equivalence_Symmetric ; + PER_Transitive := Equivalence_Transitive }. + + (** We can now define antisymmetry w.r.t. an equivalence crelation on the carrier. *) + + Class Antisymmetric eqA `{equ : Equivalence eqA} (R : crelation A) := + antisymmetry : forall {x y}, R x y -> R y x -> eqA x y. + + Class subrelation (R R' : crelation A) := + is_subrelation : forall {x y}, R x y -> R' x y. + + (** Any symmetric crelation is equal to its inverse. *) + + Lemma subrelation_symmetric R `(Symmetric R) : subrelation (flip R) R. + Proof. hnf. intros x y H'. red in H'. apply symmetry. assumption. Qed. + + Section flip. + + Lemma flip_Reflexive `{Reflexive R} : Reflexive (flip R). + Proof. tauto. Qed. + + Program Definition flip_Irreflexive `(Irreflexive R) : Irreflexive (flip R) := + irreflexivity (R:=R). + + Program Definition flip_Symmetric `(Symmetric R) : Symmetric (flip R) := + fun x y H => symmetry (R:=R) H. + + Program Definition flip_Asymmetric `(Asymmetric R) : Asymmetric (flip R) := + fun x y H H' => asymmetry (R:=R) H H'. + + Program Definition flip_Transitive `(Transitive R) : Transitive (flip R) := + fun x y z H H' => transitivity (R:=R) H' H. + + Program Definition flip_Antisymmetric `(Antisymmetric eqA R) : + Antisymmetric eqA (flip R). + Proof. firstorder. Qed. + + (** Inversing the larger structures *) + + Lemma flip_PreOrder `(PreOrder R) : PreOrder (flip R). + Proof. firstorder. Qed. + + Lemma flip_StrictOrder `(StrictOrder R) : StrictOrder (flip R). + Proof. firstorder. Qed. + + Lemma flip_PER `(PER R) : PER (flip R). + Proof. firstorder. Qed. + + Lemma flip_Equivalence `(Equivalence R) : Equivalence (flip R). + Proof. firstorder. Qed. + + End flip. + + Section complement. + + Definition complement_Irreflexive `(Reflexive R) + : Irreflexive (complement R). + Proof. firstorder. Qed. + + Definition complement_Symmetric `(Symmetric R) : Symmetric (complement R). + Proof. firstorder. Qed. + End complement. + + + (** Rewrite crelation on a given support: declares a crelation as a rewrite + crelation for use by the generalized rewriting tactic. + It helps choosing if a rewrite should be handled + by the generalized or the regular rewriting tactic using leibniz equality. + Users can declare an [RewriteRelation A RA] anywhere to declare default + crelations. This is also done automatically by the [Declare Relation A RA] + commands. *) + + Class RewriteRelation (RA : crelation A). + + (** Any [Equivalence] declared in the context is automatically considered + a rewrite crelation. *) + + Global Instance equivalence_rewrite_crelation `(Equivalence eqA) : RewriteRelation eqA. + + (** Leibniz equality. *) + Section Leibniz. + Global Instance eq_Reflexive : Reflexive (@eq A) := @eq_refl A. + Global Instance eq_Symmetric : Symmetric (@eq A) := @eq_sym A. + Global Instance eq_Transitive : Transitive (@eq A) := @eq_trans A. + + (** Leibinz equality [eq] is an equivalence crelation. + The instance has low priority as it is always applicable + if only the type is constrained. *) + + Global Program Instance eq_equivalence : Equivalence (@eq A) | 10. + End Leibniz. + +End Defs. + +(** Default rewrite crelations handled by [setoid_rewrite]. *) +Instance: RewriteRelation impl. +Instance: RewriteRelation iff. + +(** Hints to drive the typeclass resolution avoiding loops + due to the use of full unification. *) +Hint Extern 1 (Reflexive (complement _)) => class_apply @irreflexivity : typeclass_instances. +Hint Extern 3 (Symmetric (complement _)) => class_apply complement_Symmetric : typeclass_instances. +Hint Extern 3 (Irreflexive (complement _)) => class_apply complement_Irreflexive : typeclass_instances. + +Hint Extern 3 (Reflexive (flip _)) => apply flip_Reflexive : typeclass_instances. +Hint Extern 3 (Irreflexive (flip _)) => class_apply flip_Irreflexive : typeclass_instances. +Hint Extern 3 (Symmetric (flip _)) => class_apply flip_Symmetric : typeclass_instances. +Hint Extern 3 (Asymmetric (flip _)) => class_apply flip_Asymmetric : typeclass_instances. +Hint Extern 3 (Antisymmetric (flip _)) => class_apply flip_Antisymmetric : typeclass_instances. +Hint Extern 3 (Transitive (flip _)) => class_apply flip_Transitive : typeclass_instances. +Hint Extern 3 (StrictOrder (flip _)) => class_apply flip_StrictOrder : typeclass_instances. +Hint Extern 3 (PreOrder (flip _)) => class_apply flip_PreOrder : typeclass_instances. + +Hint Extern 4 (subrelation (flip _) _) => + class_apply @subrelation_symmetric : typeclass_instances. + +Hint Resolve irreflexivity : ord. + +Unset Implicit Arguments. + +(** A HintDb for crelations. *) + +Ltac solve_crelation := + match goal with + | [ |- ?R ?x ?x ] => reflexivity + | [ H : ?R ?x ?y |- ?R ?y ?x ] => symmetry ; exact H + end. + +Hint Extern 4 => solve_crelation : crelations. + +(** We can already dualize all these properties. *) + +(** * Standard instances. *) + +Ltac reduce_hyp H := + match type of H with + | context [ _ <-> _ ] => fail 1 + | _ => red in H ; try reduce_hyp H + end. + +Ltac reduce_goal := + match goal with + | [ |- _ <-> _ ] => fail 1 + | _ => red ; intros ; try reduce_goal + end. + +Tactic Notation "reduce" "in" hyp(Hid) := reduce_hyp Hid. + +Ltac reduce := reduce_goal. + +Tactic Notation "apply" "*" constr(t) := + first [ refine t | refine (t _) | refine (t _ _) | refine (t _ _ _) | refine (t _ _ _ _) | + refine (t _ _ _ _ _) | refine (t _ _ _ _ _ _) | refine (t _ _ _ _ _ _ _) ]. + +Ltac simpl_crelation := + unfold flip, impl, arrow ; try reduce ; program_simpl ; + try ( solve [ dintuition ]). + +Local Obligation Tactic := simpl_crelation. + +(** Logical implication. *) + +Program Instance impl_Reflexive : Reflexive impl. +Program Instance impl_Transitive : Transitive impl. + +(** Logical equivalence. *) + +Instance iff_Reflexive : Reflexive iff := iff_refl. +Instance iff_Symmetric : Symmetric iff := iff_sym. +Instance iff_Transitive : Transitive iff := iff_trans. + +(** Logical equivalence [iff] is an equivalence crelation. *) + +Program Instance iff_equivalence : Equivalence iff. + +Program Instance arrow_Reflexive : Reflexive arrow. +Program Instance arrow_Transitive : Transitive arrow. + +Instance iffT_Reflexive : Reflexive iffT. +Proof. firstorder. Defined. +Instance iffT_Symmetric : Symmetric iffT. +Proof. firstorder. Defined. +Instance iffT_Transitive : Transitive iffT. +Proof. firstorder. Defined. + +(** We now develop a generalization of results on crelations for arbitrary predicates. + The resulting theory can be applied to homogeneous binary crelations but also to + arbitrary n-ary predicates. *) + +Local Open Scope list_scope. + +(** A compact representation of non-dependent arities, with the codomain singled-out. *) + +(** We define the various operations which define the algebra on binary crelations *) +Section Binary. + Context {A : Type}. + + Definition relation_equivalence : crelation (crelation A) := + fun R R' => forall x y, iffT (R x y) (R' x y). + + Global Instance: RewriteRelation relation_equivalence. + + Definition relation_conjunction (R : crelation A) (R' : crelation A) : crelation A := + fun x y => prod (R x y) (R' x y). + + Definition relation_disjunction (R : crelation A) (R' : crelation A) : crelation A := + fun x y => sum (R x y) (R' x y). + + (** Relation equivalence is an equivalence, and subrelation defines a partial order. *) + + Set Automatic Introduction. + + Global Instance relation_equivalence_equivalence : + Equivalence relation_equivalence. + Proof. split; red; unfold relation_equivalence, iffT. firstorder. + firstorder. + intros. specialize (X x0 y0). specialize (X0 x0 y0). firstorder. + Qed. + + Global Instance relation_implication_preorder : PreOrder (@subrelation A). + Proof. firstorder. Qed. + + (** *** Partial Order. + A partial order is a preorder which is additionally antisymmetric. + We give an equivalent definition, up-to an equivalence crelation + on the carrier. *) + + Class PartialOrder eqA `{equ : Equivalence A eqA} R `{preo : PreOrder A R} := + partial_order_equivalence : relation_equivalence eqA (relation_conjunction R (flip R)). + + (** The equivalence proof is sufficient for proving that [R] must be a + morphism for equivalence (see Morphisms). It is also sufficient to + show that [R] is antisymmetric w.r.t. [eqA] *) + + Global Instance partial_order_antisym `(PartialOrder eqA R) : ! Antisymmetric A eqA R. + Proof with auto. + reduce_goal. + apply H. firstorder. + Qed. + + Lemma PartialOrder_inverse `(PartialOrder eqA R) : PartialOrder eqA (flip R). + Proof. firstorder. Qed. +End Binary. + +Hint Extern 3 (PartialOrder (flip _)) => class_apply PartialOrder_inverse : typeclass_instances. + +(** The partial order defined by subrelation and crelation equivalence. *) + +Program Instance subrelation_partial_order : + ! PartialOrder (crelation A) relation_equivalence subrelation. + +Next Obligation. +Proof. + unfold relation_equivalence in *. compute; firstorder. +Qed. + +Typeclasses Opaque relation_equivalence. + + diff --git a/theories/Classes/DecidableClass.v b/theories/Classes/DecidableClass.v index 6e6ba68a2..3b4ba786a 100644 --- a/theories/Classes/DecidableClass.v +++ b/theories/Classes/DecidableClass.v @@ -44,7 +44,7 @@ Qed. (** The generic function that should be used to program, together with some useful tactics. *) -Definition decide P {H : Decidable P} := @Decidable_witness P H. +Definition decide P {H : Decidable P} := Decidable_witness (Decidable:=H). Ltac _decide_ P H := let b := fresh "b" in diff --git a/theories/Classes/EquivDec.v b/theories/Classes/EquivDec.v index 39d7cdaa0..dcaf057b0 100644 --- a/theories/Classes/EquivDec.v +++ b/theories/Classes/EquivDec.v @@ -56,6 +56,7 @@ Local Open Scope program_scope. Program Definition nequiv_dec `{EqDec A} (x y : A) : { x =/= y } + { x === y } := swap_sumbool (x == y). + (** Overloaded notation for inequality. *) Infix "<>" := nequiv_dec (no associativity, at level 70) : equiv_scope. diff --git a/theories/Classes/Equivalence.v b/theories/Classes/Equivalence.v index 233e97c19..db04fbe39 100644 --- a/theories/Classes/Equivalence.v +++ b/theories/Classes/Equivalence.v @@ -24,7 +24,7 @@ Set Implicit Arguments. Unset Strict Implicit. Generalizable Variables A R eqA B S eqB. -Local Obligation Tactic := simpl_relation. +Local Obligation Tactic := try solve [simpl_relation]. Local Open Scope signature_scope. @@ -56,8 +56,8 @@ Program Instance equiv_symmetric `(sa : Equivalence A) : Symmetric equiv. Program Instance equiv_transitive `(sa : Equivalence A) : Transitive equiv. Next Obligation. - Proof. - transitivity y ; auto. + Proof. intros A R sa x y z Hxy Hyz. + now transitivity y. Qed. (** Use the [substitute] command which substitutes an equivalence in every hypothesis. *) @@ -116,8 +116,9 @@ Section Respecting. Solve Obligations with unfold respecting in * ; simpl_relation ; program_simpl. Next Obligation. - Proof. - unfold respecting in *. program_simpl. transitivity (y y0); auto. apply H0. reflexivity. + Proof. + intros. intros f g h H H' x y Rxy. + unfold respecting in *. program_simpl. transitivity (g y); auto. firstorder. Qed. End Respecting. diff --git a/theories/Classes/Morphisms.v b/theories/Classes/Morphisms.v index 617ff1906..921f21233 100644 --- a/theories/Classes/Morphisms.v +++ b/theories/Classes/Morphisms.v @@ -18,7 +18,7 @@ Require Import Coq.Program.Tactics. Require Import Coq.Relations.Relation_Definitions. Require Export Coq.Classes.RelationClasses. -Generalizable All Variables. +Generalizable Variables A eqA B C D R RA RB RC m f x y. Local Obligation Tactic := simpl_relation. (** * Morphisms. @@ -29,15 +29,39 @@ Local Obligation Tactic := simpl_relation. (** A morphism for a relation [R] is a proper element of the relation. The relation [R] will be instantiated by [respectful] and [A] by an arrow type for usual morphisms. *) - -Class Proper {A} (R : relation A) (m : A) : Prop := - proper_prf : R m m. - -(** Respectful morphisms. *) - -(** The fully dependent version, not used yet. *) - -Definition respectful_hetero +Section Proper. + Let U := Type. + Context {A B : U}. + + Class Proper (R : relation A) (m : A) : Prop := + proper_prf : R m m. + + (** Every element in the carrier of a reflexive relation is a morphism + for this relation. We use a proxy class for this case which is used + internally to discharge reflexivity constraints. The [Reflexive] + instance will almost always be used, but it won't apply in general to + any kind of [Proper (A -> B) _ _] goal, making proof-search much + slower. A cleaner solution would be to be able to set different + priorities in different hint bases and select a particular hint + database for resolution of a type class constraint. *) + + Class ProperProxy (R : relation A) (m : A) : Prop := + proper_proxy : R m m. + + Lemma eq_proper_proxy (x : A) : ProperProxy (@eq A) x. + Proof. firstorder. Qed. + + Lemma reflexive_proper_proxy `(Reflexive A R) (x : A) : ProperProxy R x. + Proof. firstorder. Qed. + + Lemma proper_proper_proxy x `(Proper R x) : ProperProxy R x. + Proof. firstorder. Qed. + + (** Respectful morphisms. *) + + (** The fully dependent version, not used yet. *) + + Definition respectful_hetero (A B : Type) (C : A -> Type) (D : B -> Type) (R : A -> B -> Prop) @@ -45,18 +69,24 @@ Definition respectful_hetero (forall x : A, C x) -> (forall x : B, D x) -> Prop := fun f g => forall x y, R x y -> R' x y (f x) (g y). -(** The non-dependent version is an instance where we forget dependencies. *) + (** The non-dependent version is an instance where we forget dependencies. *) + + Definition respectful (R : relation A) (R' : relation B) : relation (A -> B) := + Eval compute in @respectful_hetero A A (fun _ => B) (fun _ => B) R (fun _ _ => R'). -Definition respectful {A B : Type} - (R : relation A) (R' : relation B) : relation (A -> B) := - Eval compute in @respectful_hetero A A (fun _ => B) (fun _ => B) R (fun _ _ => R'). +End Proper. -(** Notations reminiscent of the old syntax for declaring morphisms. *) +(** We favor the use of Leibniz equality or a declared reflexive relation + when resolving [ProperProxy], otherwise, if the relation is given (not an evar), + we fall back to [Proper]. *) +Hint Extern 1 (ProperProxy _ _) => + class_apply @eq_proper_proxy || class_apply @reflexive_proper_proxy : typeclass_instances. -Delimit Scope signature_scope with signature. +Hint Extern 2 (ProperProxy ?R _) => + not_evar R; class_apply @proper_proper_proxy : typeclass_instances. -Arguments Proper {A}%type R%signature m. -Arguments respectful {A B}%type (R R')%signature _ _. +(** Notations reminiscent of the old syntax for declaring morphisms. *) +Delimit Scope signature_scope with signature. Module ProperNotations. @@ -66,11 +96,14 @@ Module ProperNotations. Notation " R ==> R' " := (@respectful _ _ (R%signature) (R'%signature)) (right associativity, at level 55) : signature_scope. - Notation " R --> R' " := (@respectful _ _ (inverse (R%signature)) (R'%signature)) + Notation " R --> R' " := (@respectful _ _ (flip (R%signature)) (R'%signature)) (right associativity, at level 55) : signature_scope. End ProperNotations. +Arguments Proper {A}%type R%signature m. +Arguments respectful {A B}%type (R R')%signature _ _. + Export ProperNotations. Local Open Scope signature_scope. @@ -106,80 +139,89 @@ Ltac f_equiv := assert (H : (Rx==>R)%signature f f'); unfold Rx in *; clear Rx; [ f_equiv | apply H; clear H; try reflexivity ] | |- ?R ?f ?f' => - try reflexivity; - change (Proper R f); eauto with typeclass_instances; fail + solve [change (Proper R f); eauto with typeclass_instances | reflexivity ] | _ => idtac end. -(** [forall_def] reifies the dependent product as a definition. *) - -Definition forall_def {A : Type} (B : A -> Type) : Type := forall x : A, B x. - -(** Dependent pointwise lifting of a relation on the range. *) - -Definition forall_relation {A : Type} {B : A -> Type} - (sig : forall a, relation (B a)) : relation (forall x, B x) := - fun f g => forall a, sig a (f a) (g a). - -Arguments forall_relation {A B}%type sig%signature _ _. - -(** Non-dependent pointwise lifting *) - -Definition pointwise_relation (A : Type) {B : Type} (R : relation B) : relation (A -> B) := - Eval compute in forall_relation (B:=fun _ => B) (fun _ => R). +Section Relations. + Let U := Type. + Context {A B : U} (P : A -> U). + + (** [forall_def] reifies the dependent product as a definition. *) + + Definition forall_def : Type := forall x : A, P x. + + (** Dependent pointwise lifting of a relation on the range. *) + + Definition forall_relation + (sig : forall a, relation (P a)) : relation (forall x, P x) := + fun f g => forall a, sig a (f a) (g a). + + (** Non-dependent pointwise lifting *) + Definition pointwise_relation (R : relation B) : relation (A -> B) := + fun f g => forall a, R (f a) (g a). + + Lemma pointwise_pointwise (R : relation B) : + relation_equivalence (pointwise_relation R) (@eq A ==> R). + Proof. intros. split; reduce; subst; firstorder. Qed. + + (** Subrelations induce a morphism on the identity. *) + + Global Instance subrelation_id_proper `(subrelation A RA RA') : Proper (RA ==> RA') id. + Proof. firstorder. Qed. + + (** The subrelation property goes through products as usual. *) + + Lemma subrelation_respectful `(subl : subrelation A RA' RA, subr : subrelation B RB RB') : + subrelation (RA ==> RB) (RA' ==> RB'). + Proof. unfold subrelation in *; firstorder. Qed. + + (** And of course it is reflexive. *) + + Lemma subrelation_refl R : @subrelation A R R. + Proof. unfold subrelation; firstorder. Qed. + + (** [Proper] is itself a covariant morphism for [subrelation]. + We use an unconvertible premise to avoid looping. + *) + + Lemma subrelation_proper `(mor : Proper A R' m) + `(unc : Unconvertible (relation A) R R') + `(sub : subrelation A R' R) : Proper R m. + Proof. + intros. apply sub. apply mor. + Qed. -Lemma pointwise_pointwise A B (R : relation B) : - relation_equivalence (pointwise_relation A R) (@eq A ==> R). -Proof. intros. split. simpl_relation. firstorder. Qed. + Global Instance proper_subrelation_proper : + Proper (subrelation ++> eq ==> impl) (@Proper A). + Proof. reduce. subst. firstorder. Qed. -(** We can build a PER on the Coq function space if we have PERs on the domain and - codomain. *) + Global Instance pointwise_subrelation `(sub : subrelation B R R') : + subrelation (pointwise_relation R) (pointwise_relation R') | 4. + Proof. reduce. unfold pointwise_relation in *. apply sub. apply H. Qed. + + (** For dependent function types. *) + Lemma forall_subrelation (R S : forall x : A, relation (P x)) : + (forall a, subrelation (R a) (S a)) -> subrelation (forall_relation R) (forall_relation S). + Proof. reduce. apply H. apply H0. Qed. +End Relations. +Typeclasses Opaque respectful pointwise_relation forall_relation. +Arguments forall_relation {A P}%type sig%signature _ _. +Arguments pointwise_relation A%type {B}%type R%signature _ _. + Hint Unfold Reflexive : core. Hint Unfold Symmetric : core. Hint Unfold Transitive : core. -Typeclasses Opaque respectful pointwise_relation forall_relation. - -Program Instance respectful_per `(PER A R, PER B R') : PER (R ==> R'). - - Next Obligation. - Proof with auto. - assert(R x0 x0). - transitivity y0... symmetry... - transitivity (y x0)... - Qed. - -(** Subrelations induce a morphism on the identity. *) - -Instance subrelation_id_proper `(subrelation A Râ‚ Râ‚‚) : Proper (Râ‚ ==> Râ‚‚) id. -Proof. firstorder. Qed. - -(** The subrelation property goes through products as usual. *) - -Lemma subrelation_respectful `(subl : subrelation A Râ‚‚ Râ‚, subr : subrelation B Sâ‚ Sâ‚‚) : - subrelation (Râ‚ ==> Sâ‚) (Râ‚‚ ==> Sâ‚‚). -Proof. simpl_relation. apply subr. apply H. apply subl. apply H0. Qed. - -(** And of course it is reflexive. *) - -Lemma subrelation_refl A R : @subrelation A R R. -Proof. simpl_relation. Qed. - +(** Resolution with subrelation: favor decomposing products over applying reflexivity + for unconstrained goals. *) Ltac subrelation_tac T U := (is_ground T ; is_ground U ; class_apply @subrelation_refl) || class_apply @subrelation_respectful || class_apply @subrelation_refl. Hint Extern 3 (@subrelation _ ?T ?U) => subrelation_tac T U : typeclass_instances. -(** [Proper] is itself a covariant morphism for [subrelation]. *) - -Lemma subrelation_proper `(mor : Proper A Râ‚ m, unc : Unconvertible (relation A) Râ‚ Râ‚‚, - sub : subrelation A Râ‚ Râ‚‚) : Proper Râ‚‚ m. -Proof. - intros. apply sub. apply mor. -Qed. - CoInductive apply_subrelation : Prop := do_subrelation. Ltac proper_subrelation := @@ -189,117 +231,112 @@ Ltac proper_subrelation := Hint Extern 5 (@Proper _ ?H _) => proper_subrelation : typeclass_instances. -Instance proper_subrelation_proper : - Proper (subrelation ++> eq ==> impl) (@Proper A). -Proof. reduce. subst. firstorder. Qed. - (** Essential subrelation instances for [iff], [impl] and [pointwise_relation]. *) Instance iff_impl_subrelation : subrelation iff impl | 2. Proof. firstorder. Qed. -Instance iff_inverse_impl_subrelation : subrelation iff (inverse impl) | 2. +Instance iff_flip_impl_subrelation : subrelation iff (flip impl) | 2. Proof. firstorder. Qed. -Instance pointwise_subrelation {A} `(sub : subrelation B R R') : - subrelation (pointwise_relation A R) (pointwise_relation A R') | 4. -Proof. reduce. unfold pointwise_relation in *. apply sub. apply H. Qed. - -(** For dependent function types. *) -Lemma forall_subrelation A (B : A -> Type) (R S : forall x : A, relation (B x)) : - (forall a, subrelation (R a) (S a)) -> subrelation (forall_relation R) (forall_relation S). -Proof. reduce. apply H. apply H0. Qed. - (** We use an extern hint to help unification. *) Hint Extern 4 (subrelation (@forall_relation ?A ?B ?R) (@forall_relation _ _ ?S)) => apply (@forall_subrelation A B R S) ; intro : typeclass_instances. -(** Any symmetric relation is equal to its inverse. *) +Section GenericInstances. + (* Share universes *) + Let U := Type. + Context {A B C : U}. -Lemma subrelation_symmetric A R `(Symmetric A R) : subrelation (inverse R) R. -Proof. reduce. red in H0. symmetry. assumption. Qed. - -Hint Extern 4 (subrelation (inverse _) _) => - class_apply @subrelation_symmetric : typeclass_instances. - -(** The complement of a relation conserves its proper elements. *) + (** We can build a PER on the Coq function space if we have PERs on the domain and + codomain. *) + + Program Instance respectful_per `(PER A R, PER B R') : PER (R ==> R'). -Program Definition complement_proper - `(mR : Proper (A -> A -> Prop) (RA ==> RA ==> iff) R) : - Proper (RA ==> RA ==> iff) (complement R) := _. + Next Obligation. + Proof with auto. + assert(R x0 x0). + transitivity y0... symmetry... + transitivity (y x0)... + Qed. - Next Obligation. + (** The complement of a relation conserves its proper elements. *) + + Program Definition complement_proper + `(mR : Proper (A -> A -> Prop) (RA ==> RA ==> iff) R) : + Proper (RA ==> RA ==> iff) (complement R) := _. + + Next Obligation. Proof. unfold complement. pose (mR x y H x0 y0 H0). intuition. Qed. -Hint Extern 1 (Proper _ (complement _)) => - apply @complement_proper : typeclass_instances. - -(** The [inverse] too, actually the [flip] instance is a bit more general. *) - -Program Definition flip_proper - `(mor : Proper (A -> B -> C) (RA ==> RB ==> RC) f) : - Proper (RB ==> RA ==> RC) (flip f) := _. + (** The [flip] too, actually the [flip] instance is a bit more general. *) + Program Definition flip_proper + `(mor : Proper (A -> B -> C) (RA ==> RB ==> RC) f) : + Proper (RB ==> RA ==> RC) (flip f) := _. + Next Obligation. Proof. apply mor ; auto. Qed. -Hint Extern 1 (Proper _ (flip _)) => - apply @flip_proper : typeclass_instances. -(** Every Transitive relation gives rise to a binary morphism on [impl], + (** Every Transitive relation gives rise to a binary morphism on [impl], contravariant in the first argument, covariant in the second. *) - -Program Instance trans_contra_co_morphism - `(Transitive A R) : Proper (R --> R ++> impl) R. - + + Global Program + Instance trans_contra_co_morphism + `(Transitive A R) : Proper (R --> R ++> impl) R. + Next Obligation. Proof with auto. transitivity x... transitivity x0... Qed. -(** Proper declarations for partial applications. *) + (** Proper declarations for partial applications. *) -Program Instance trans_contra_inv_impl_morphism - `(Transitive A R) : Proper (R --> inverse impl) (R x) | 3. + Global Program + Instance trans_contra_inv_impl_morphism + `(Transitive A R) : Proper (R --> flip impl) (R x) | 3. Next Obligation. Proof with auto. transitivity y... Qed. -Program Instance trans_co_impl_morphism - `(Transitive A R) : Proper (R ++> impl) (R x) | 3. + Global Program + Instance trans_co_impl_morphism + `(Transitive A R) : Proper (R ++> impl) (R x) | 3. Next Obligation. Proof with auto. transitivity x0... Qed. -Program Instance trans_sym_co_inv_impl_morphism - `(PER A R) : Proper (R ++> inverse impl) (R x) | 3. + Global Program + Instance trans_sym_co_inv_impl_morphism + `(PER A R) : Proper (R ++> flip impl) (R x) | 3. Next Obligation. Proof with auto. transitivity y... symmetry... Qed. -Program Instance trans_sym_contra_impl_morphism - `(PER A R) : Proper (R --> impl) (R x) | 3. + Global Program Instance trans_sym_contra_impl_morphism + `(PER A R) : Proper (R --> impl) (R x) | 3. Next Obligation. Proof with auto. transitivity x0... symmetry... Qed. -Program Instance per_partial_app_morphism + Global Program Instance per_partial_app_morphism `(PER A R) : Proper (R ==> iff) (R x) | 2. Next Obligation. @@ -310,20 +347,21 @@ Program Instance per_partial_app_morphism symmetry... Qed. -(** Every Transitive relation induces a morphism by "pushing" an [R x y] on the left of an [R x z] proof - to get an [R y z] goal. *) + (** Every Transitive relation induces a morphism by "pushing" an [R x y] on the left of an [R x z] proof to get an [R y z] goal. *) -Program Instance trans_co_eq_inv_impl_morphism - `(Transitive A R) : Proper (R ==> (@eq A) ==> inverse impl) R | 2. + Global Program + Instance trans_co_eq_inv_impl_morphism + `(Transitive A R) : Proper (R ==> (@eq A) ==> flip impl) R | 2. Next Obligation. Proof with auto. transitivity y... Qed. -(** Every Symmetric and Transitive relation gives rise to an equivariant morphism. *) + (** Every Symmetric and Transitive relation gives rise to an equivariant morphism. *) -Program Instance PER_morphism `(PER A R) : Proper (R ==> R ==> iff) R | 1. + Global Program + Instance PER_morphism `(PER A R) : Proper (R ==> R ==> iff) R | 1. Next Obligation. Proof with auto. @@ -333,11 +371,11 @@ Program Instance PER_morphism `(PER A R) : Proper (R ==> R ==> iff) R | 1. transitivity y... transitivity y0... symmetry... Qed. -Lemma symmetric_equiv_inverse `(Symmetric A R) : relation_equivalence R (flip R). -Proof. firstorder. Qed. + Lemma symmetric_equiv_flip `(Symmetric A R) : relation_equivalence R (flip R). + Proof. firstorder. Qed. -Program Instance compose_proper A B C Râ‚€ Râ‚ Râ‚‚ : - Proper ((Râ‚ ==> Râ‚‚) ==> (Râ‚€ ==> Râ‚) ==> (Râ‚€ ==> Râ‚‚)) (@compose A B C). + Global Program Instance compose_proper RA RB RC : + Proper ((RB ==> RC) ==> (RA ==> RB) ==> (RA ==> RC)) (@compose A B C). Next Obligation. Proof. @@ -345,63 +383,79 @@ Program Instance compose_proper A B C Râ‚€ Râ‚ Râ‚‚ : unfold compose. apply H. apply H0. apply H1. Qed. -(** Coq functions are morphisms for Leibniz equality, - applied only if really needed. *) + (** Coq functions are morphisms for Leibniz equality, + applied only if really needed. *) -Instance reflexive_eq_dom_reflexive (A : Type) `(Reflexive B R') : - Reflexive (@Logic.eq A ==> R'). -Proof. simpl_relation. Qed. - -(** [respectful] is a morphism for relation equivalence. *) - -Instance respectful_morphism : - Proper (relation_equivalence ++> relation_equivalence ++> relation_equivalence) (@respectful A B). -Proof. - reduce. - unfold respectful, relation_equivalence, predicate_equivalence in * ; simpl in *. - split ; intros. + Global Instance reflexive_eq_dom_reflexive `(Reflexive B R') : + Reflexive (@Logic.eq A ==> R'). + Proof. simpl_relation. Qed. + (** [respectful] is a morphism for relation equivalence. *) + + Global Instance respectful_morphism : + Proper (relation_equivalence ++> relation_equivalence ++> relation_equivalence) + (@respectful A B). + Proof. + reduce. + unfold respectful, relation_equivalence, predicate_equivalence in * ; simpl in *. + split ; intros. + rewrite <- H0. apply H1. rewrite H. assumption. - + rewrite H0. apply H1. rewrite <- H. assumption. -Qed. - -(** Every element in the carrier of a reflexive relation is a morphism for this relation. - We use a proxy class for this case which is used internally to discharge reflexivity constraints. - The [Reflexive] instance will almost always be used, but it won't apply in general to any kind of - [Proper (A -> B) _ _] goal, making proof-search much slower. A cleaner solution would be to be able - to set different priorities in different hint bases and select a particular hint database for - resolution of a type class constraint.*) - -Class ProperProxy {A} (R : relation A) (m : A) : Prop := - proper_proxy : R m m. - -Lemma eq_proper_proxy A (x : A) : ProperProxy (@eq A) x. -Proof. firstorder. Qed. - -Lemma reflexive_proper_proxy `(Reflexive A R) (x : A) : ProperProxy R x. -Proof. firstorder. Qed. - -Lemma proper_proper_proxy `(Proper A R x) : ProperProxy R x. -Proof. firstorder. Qed. - -Hint Extern 1 (ProperProxy _ _) => - class_apply @eq_proper_proxy || class_apply @reflexive_proper_proxy : typeclass_instances. -Hint Extern 2 (ProperProxy ?R _) => not_evar R; class_apply @proper_proper_proxy : typeclass_instances. + Qed. -(** [R] is Reflexive, hence we can build the needed proof. *) + (** [R] is Reflexive, hence we can build the needed proof. *) -Lemma Reflexive_partial_app_morphism `(Proper (A -> B) (R ==> R') m, ProperProxy A R x) : - Proper R' (m x). -Proof. simpl_relation. Qed. + Lemma Reflexive_partial_app_morphism `(Proper (A -> B) (R ==> R') m, ProperProxy A R x) : + Proper R' (m x). + Proof. simpl_relation. Qed. + + Class Params (of : A) (arity : nat). + + Lemma flip_respectful (R : relation A) (R' : relation B) : + relation_equivalence (flip (R ==> R')) (flip R ==> flip R'). + Proof. + intros. + unfold flip, respectful. + split ; intros ; intuition. + Qed. -Class Params {A : Type} (of : A) (arity : nat). + + (** Treating flip: can't make them direct instances as we + need at least a [flip] present in the goal. *) + + Lemma flip1 `(subrelation A R' R) : subrelation (flip (flip R')) R. + Proof. firstorder. Qed. + + Lemma flip2 `(subrelation A R R') : subrelation R (flip (flip R')). + Proof. firstorder. Qed. + + (** That's if and only if *) + + Lemma eq_subrelation `(Reflexive A R) : subrelation (@eq A) R. + Proof. simpl_relation. Qed. + + (** Once we have normalized, we will apply this instance to simplify the problem. *) + + Definition proper_flip_proper `(mor : Proper A R m) : Proper (flip R) m := mor. + + (** Every reflexive relation gives rise to a morphism, + only for immediately solving goals without variables. *) + + Lemma reflexive_proper `{Reflexive A R} (x : A) : Proper R x. + Proof. firstorder. Qed. + + Lemma proper_eq (x : A) : Proper (@eq A) x. + Proof. intros. apply reflexive_proper. Qed. + +End GenericInstances. Class PartialApplication. @@ -450,68 +504,6 @@ Ltac partial_application_tactic := end end. -Hint Extern 4 (@Proper _ _ _) => partial_application_tactic : typeclass_instances. - -Lemma inverse_respectful : forall (A : Type) (R : relation A) (B : Type) (R' : relation B), - relation_equivalence (inverse (R ==> R')) (inverse R ==> inverse R'). -Proof. - intros. - unfold flip, respectful. - split ; intros ; intuition. -Qed. - -(** Special-purpose class to do normalization of signatures w.r.t. inverse. *) - -Class Normalizes (A : Type) (m : relation A) (m' : relation A) : Prop := - normalizes : relation_equivalence m m'. - -(** Current strategy: add [inverse] everywhere and reduce using [subrelation] - afterwards. *) - -Lemma inverse_atom A R : Normalizes A R (inverse (inverse R)). -Proof. - firstorder. -Qed. - -Lemma inverse_arrow `(NA : Normalizes A R (inverse R'''), NB : Normalizes B R' (inverse R'')) : - Normalizes (A -> B) (R ==> R') (inverse (R''' ==> R'')%signature). -Proof. unfold Normalizes in *. intros. - rewrite NA, NB. firstorder. -Qed. - -Ltac inverse := - match goal with - | [ |- Normalizes _ (respectful _ _) _ ] => class_apply @inverse_arrow - | _ => class_apply @inverse_atom - end. - -Hint Extern 1 (Normalizes _ _ _) => inverse : typeclass_instances. - -(** Treating inverse: can't make them direct instances as we - need at least a [flip] present in the goal. *) - -Lemma inverse1 `(subrelation A R' R) : subrelation (inverse (inverse R')) R. -Proof. firstorder. Qed. - -Lemma inverse2 `(subrelation A R R') : subrelation R (inverse (inverse R')). -Proof. firstorder. Qed. - -Hint Extern 1 (subrelation (flip _) _) => class_apply @inverse1 : typeclass_instances. -Hint Extern 1 (subrelation _ (flip _)) => class_apply @inverse2 : typeclass_instances. - -(** That's if and only if *) - -Lemma eq_subrelation `(Reflexive A R) : subrelation (@eq A) R. -Proof. simpl_relation. Qed. - -(* Hint Extern 3 (subrelation eq ?R) => not_evar R ; class_apply eq_subrelation : typeclass_instances. *) - -(** Once we have normalized, we will apply this instance to simplify the problem. *) - -Definition proper_inverse_proper `(mor : Proper A R m) : Proper (inverse R) m := mor. - -Hint Extern 2 (@Proper _ (flip _) _) => class_apply @proper_inverse_proper : typeclass_instances. - (** Bootstrap !!! *) Instance proper_proper : Proper (relation_equivalence ==> eq ==> iff) (@Proper A). @@ -525,46 +517,83 @@ Proof. apply H0. Qed. -Lemma proper_normalizes_proper `(Normalizes A R0 R1, Proper A R1 m) : Proper R0 m. -Proof. - red in H, H0. - setoid_rewrite H. - assumption. -Qed. - -Ltac proper_normalization := +Ltac proper_reflexive := match goal with | [ _ : normalization_done |- _ ] => fail 1 - | [ _ : apply_subrelation |- @Proper _ ?R _ ] => let H := fresh "H" in - set(H:=did_normalization) ; class_apply @proper_normalizes_proper + | _ => class_apply proper_eq || class_apply @reflexive_proper end. -Hint Extern 6 (@Proper _ _ _) => proper_normalization : typeclass_instances. -(** Every reflexive relation gives rise to a morphism, only for immediately solving goals without variables. *) +Hint Extern 1 (subrelation (flip _) _) => class_apply @flip1 : typeclass_instances. +Hint Extern 1 (subrelation _ (flip _)) => class_apply @flip2 : typeclass_instances. -Lemma reflexive_proper `{Reflexive A R} (x : A) - : Proper R x. -Proof. firstorder. Qed. +Hint Extern 1 (Proper _ (complement _)) => apply @complement_proper + : typeclass_instances. +Hint Extern 1 (Proper _ (flip _)) => apply @flip_proper + : typeclass_instances. +Hint Extern 2 (@Proper _ (flip _) _) => class_apply @proper_flip_proper + : typeclass_instances. +Hint Extern 4 (@Proper _ _ _) => partial_application_tactic + : typeclass_instances. +Hint Extern 7 (@Proper _ _ _) => proper_reflexive + : typeclass_instances. -Lemma proper_eq A (x : A) : Proper (@eq A) x. -Proof. intros. apply reflexive_proper. Qed. +(** Special-purpose class to do normalization of signatures w.r.t. flip. *) -Ltac proper_reflexive := +Section Normalize. + Context (A : Type). + + Class Normalizes (m : relation A) (m' : relation A) : Prop := + normalizes : relation_equivalence m m'. + + (** Current strategy: add [flip] everywhere and reduce using [subrelation] + afterwards. *) + + Lemma proper_normalizes_proper `(Normalizes R0 R1, Proper A R1 m) : Proper R0 m. + Proof. + red in H, H0. + rewrite H. + assumption. + Qed. + + Lemma flip_atom R : Normalizes R (flip (flip R)). + Proof. + firstorder. + Qed. + +End Normalize. + +Lemma flip_arrow `(NA : Normalizes A R (flip R'''), NB : Normalizes B R' (flip R'')) : + Normalizes (A -> B) (R ==> R') (flip (R''' ==> R'')%signature). +Proof. + unfold Normalizes in *. intros. + rewrite NA, NB. firstorder. +Qed. + +Ltac normalizes := match goal with - | [ _ : normalization_done |- _ ] => fail 1 - | _ => class_apply proper_eq || class_apply @reflexive_proper + | [ |- Normalizes _ (respectful _ _) _ ] => class_apply @flip_arrow + | _ => class_apply @flip_atom end. -Hint Extern 7 (@Proper _ _ _) => proper_reflexive : typeclass_instances. +Ltac proper_normalization := + match goal with + | [ _ : normalization_done |- _ ] => fail 1 + | [ _ : apply_subrelation |- @Proper _ ?R _ ] => + let H := fresh "H" in + set(H:=did_normalization) ; class_apply @proper_normalizes_proper + end. +Hint Extern 1 (Normalizes _ _ _) => normalizes : typeclass_instances. +Hint Extern 6 (@Proper _ _ _) => proper_normalization + : typeclass_instances. (** When the relation on the domain is symmetric, we can - inverse the relation on the codomain. Same for binary functions. *) + flip the relation on the codomain. Same for binary functions. *) Lemma proper_sym_flip : forall `(Symmetric A R1)`(Proper (A->B) (R1==>R2) f), - Proper (R1==>inverse R2) f. + Proper (R1==>flip R2) f. Proof. intros A R1 Sym B R2 f Hf. intros x x' Hxx'. apply Hf, Sym, Hxx'. @@ -572,7 +601,7 @@ Qed. Lemma proper_sym_flip_2 : forall `(Symmetric A R1)`(Symmetric B R2)`(Proper (A->B->C) (R1==>R2==>R3) f), - Proper (R1==>R2==>inverse R3) f. + Proper (R1==>R2==>flip R3) f. Proof. intros A R1 Sym1 B R2 Sym2 C R3 f Hf. intros x x' Hxx' y y' Hyy'. apply Hf; auto. @@ -627,8 +656,6 @@ apply partial_order_antisym; auto. rewrite Hxz; auto. Qed. -Hint Extern 4 (StrictOrder (relation_conjunction _ _)) => - class_apply PartialOrder_StrictOrder : typeclass_instances. (** From a [StrictOrder] to the corresponding [PartialOrder]: [le = lt \/ eq]. @@ -659,5 +686,8 @@ elim (StrictOrder_Irreflexive x). transitivity y; auto. Qed. +Hint Extern 4 (StrictOrder (relation_conjunction _ _)) => + class_apply PartialOrder_StrictOrder : typeclass_instances. + Hint Extern 4 (PartialOrder _ (relation_disjunction _ _)) => class_apply StrictOrder_PartialOrder : typeclass_instances. diff --git a/theories/Classes/Morphisms_Prop.v b/theories/Classes/Morphisms_Prop.v index 6f02ac9f5..4f80a67ae 100644 --- a/theories/Classes/Morphisms_Prop.v +++ b/theories/Classes/Morphisms_Prop.v @@ -16,7 +16,7 @@ Require Import Coq.Classes.Morphisms. Require Import Coq.Program.Basics. Require Import Coq.Program.Tactics. -Local Obligation Tactic := simpl_relation. +Local Obligation Tactic := try solve [simpl_relation | firstorder auto]. (** Standard instances for [not], [iff] and [impl]. *) @@ -52,49 +52,20 @@ Program Instance iff_iff_iff_impl_morphism : Proper (iff ==> iff ==> iff) impl. Program Instance ex_iff_morphism {A : Type} : Proper (pointwise_relation A iff ==> iff) (@ex A). - Next Obligation. - Proof. - unfold pointwise_relation in H. - split ; intros. - destruct H0 as [x1 H1]. - exists x1. rewrite H in H1. assumption. - - destruct H0 as [x1 H1]. - exists x1. rewrite H. assumption. - Qed. - Program Instance ex_impl_morphism {A : Type} : Proper (pointwise_relation A impl ==> impl) (@ex A) | 1. - Next Obligation. - Proof. - unfold pointwise_relation in H. - exists H0. apply H. assumption. - Qed. - -Program Instance ex_inverse_impl_morphism {A : Type} : - Proper (pointwise_relation A (inverse impl) ==> inverse impl) (@ex A) | 1. - - Next Obligation. - Proof. - unfold pointwise_relation in H. - exists H0. apply H. assumption. - Qed. +Program Instance ex_flip_impl_morphism {A : Type} : + Proper (pointwise_relation A (flip impl) ==> flip impl) (@ex A) | 1. Program Instance all_iff_morphism {A : Type} : Proper (pointwise_relation A iff ==> iff) (@all A). - Next Obligation. - Proof. - unfold pointwise_relation, all in *. - intuition ; specialize (H x0) ; intuition. - Qed. - Program Instance all_impl_morphism {A : Type} : Proper (pointwise_relation A impl ==> impl) (@all A) | 1. -Program Instance all_inverse_impl_morphism {A : Type} : - Proper (pointwise_relation A (inverse impl) ==> inverse impl) (@all A) | 1. +Program Instance all_flip_impl_morphism {A : Type} : + Proper (pointwise_relation A (flip impl) ==> flip impl) (@all A) | 1. (** Equivalent points are simultaneously accessible or not *) @@ -104,13 +75,13 @@ Instance Acc_pt_morphism {A:Type}(E R : A->A->Prop) Proof. apply proper_sym_impl_iff; auto with *. intros x y EQ WF. apply Acc_intro; intros z Hz. - rewrite <- EQ in Hz. now apply Acc_inv with x. +rewrite <- EQ in Hz. now apply Acc_inv with x. Qed. (** Equivalent relations have the same accessible points *) Instance Acc_rel_morphism {A:Type} : - Proper (@relation_equivalence A ==> Logic.eq ==> iff) (@Acc A). + Proper (relation_equivalence ==> Logic.eq ==> iff) (@Acc A). Proof. apply proper_sym_impl_iff_2. red; now symmetry. red; now symmetry. intros R R' EQ a a' Ha WF. subst a'. @@ -121,7 +92,7 @@ Qed. (** Equivalent relations are simultaneously well-founded or not *) Instance well_founded_morphism {A : Type} : - Proper (@relation_equivalence A ==> iff) (@well_founded A). + Proper (relation_equivalence ==> iff) (@well_founded A). Proof. unfold well_founded. solve_proper. Qed. diff --git a/theories/Classes/Morphisms_Relations.v b/theories/Classes/Morphisms_Relations.v index ea2afb306..dc46b4bbb 100644 --- a/theories/Classes/Morphisms_Relations.v +++ b/theories/Classes/Morphisms_Relations.v @@ -30,8 +30,6 @@ Instance relation_disjunction_morphism : Proper (relation_equivalence (A:=A) ==> (* Predicate equivalence is exactly the same as the pointwise lifting of [iff]. *) -Require Import List. - Lemma predicate_equivalence_pointwise (l : Tlist) : Proper (@predicate_equivalence l ==> pointwise_lifting iff l) id. Proof. do 2 red. unfold predicate_equivalence. auto. Qed. @@ -52,6 +50,6 @@ Instance subrelation_pointwise : Proof. intro. apply (predicate_implication_pointwise (Tcons A (Tcons A Tnil))). Qed. -Lemma inverse_pointwise_relation A (R : relation A) : - relation_equivalence (pointwise_relation A (inverse R)) (inverse (pointwise_relation A R)). +Lemma flip_pointwise_relation A (R : relation A) : + relation_equivalence (pointwise_relation A (flip R)) (flip (pointwise_relation A R)). Proof. intros. split; firstorder. Qed. diff --git a/theories/Classes/RelationClasses.v b/theories/Classes/RelationClasses.v index b8fdac8c9..61edb2b98 100644 --- a/theories/Classes/RelationClasses.v +++ b/theories/Classes/RelationClasses.v @@ -20,41 +20,187 @@ Require Import Coq.Program.Basics. Require Import Coq.Program.Tactics. Require Import Coq.Relations.Relation_Definitions. -(** We allow to unfold the [relation] definition while doing morphism search. *) - -Notation inverse R := (flip (R:relation _) : relation _). - -Definition complement {A} (R : relation A) : relation A := fun x y => R x y -> False. - -(** Opaque for proof-search. *) -Typeclasses Opaque complement. - -(** These are convertible. *) - -Lemma complement_inverse : forall A (R : relation A), complement (inverse R) = inverse (complement R). -Proof. reflexivity. Qed. +Generalizable Variables A B C D R S T U l eqA eqB eqC eqD. -(** We rebind relations in separate classes to be able to overload each proof. *) +(** We allow to unfold the [relation] definition while doing morphism search. *) -Set Implicit Arguments. -Unset Strict Implicit. +Section Defs. + Context {A : Type}. + + (** We rebind relational properties in separate classes to be able to overload each proof. *) + + Class Reflexive (R : relation A) := + reflexivity : forall x : A, R x x. + + Definition complement (R : relation A) : relation A := fun x y => R x y -> False. + + (** Opaque for proof-search. *) + Typeclasses Opaque complement. + + (** These are convertible. *) + Lemma complement_inverse R : complement (flip R) = flip (complement R). + Proof. reflexivity. Qed. + + Class Irreflexive (R : relation A) := + irreflexivity : Reflexive (complement R). + + Class Symmetric (R : relation A) := + symmetry : forall {x y}, R x y -> R y x. + + Class Asymmetric (R : relation A) := + asymmetry : forall {x y}, R x y -> R y x -> False. + + Class Transitive (R : relation A) := + transitivity : forall {x y z}, R x y -> R y z -> R x z. + + (** Various combinations of reflexivity, symmetry and transitivity. *) + + (** A [PreOrder] is both Reflexive and Transitive. *) + + Class PreOrder (R : relation A) : Prop := { + PreOrder_Reflexive :> Reflexive R | 2 ; + PreOrder_Transitive :> Transitive R | 2 }. + + (** A [StrictOrder] is both Irreflexive and Transitive. *) + + Class StrictOrder (R : relation A) : Prop := { + StrictOrder_Irreflexive :> Irreflexive R ; + StrictOrder_Transitive :> Transitive R }. + + (** By definition, a strict order is also asymmetric *) + Global Instance StrictOrder_Asymmetric `(StrictOrder R) : Asymmetric R. + Proof. firstorder. Qed. + + (** A partial equivalence relation is Symmetric and Transitive. *) + + Class PER (R : relation A) : Prop := { + PER_Symmetric :> Symmetric R | 3 ; + PER_Transitive :> Transitive R | 3 }. + + (** Equivalence relations. *) + + Class Equivalence (R : relation A) : Prop := { + Equivalence_Reflexive :> Reflexive R ; + Equivalence_Symmetric :> Symmetric R ; + Equivalence_Transitive :> Transitive R }. + + (** An Equivalence is a PER plus reflexivity. *) + + Global Instance Equivalence_PER {R} `(E:Equivalence R) : PER R | 10 := + { }. + + (** We can now define antisymmetry w.r.t. an equivalence relation on the carrier. *) + + Class Antisymmetric eqA `{equ : Equivalence eqA} (R : relation A) := + antisymmetry : forall {x y}, R x y -> R y x -> eqA x y. + + Class subrelation (R R' : relation A) : Prop := + is_subrelation : forall {x y}, R x y -> R' x y. + + (** Any symmetric relation is equal to its inverse. *) + + Lemma subrelation_symmetric R `(Symmetric R) : subrelation (flip R) R. + Proof. hnf. intros. red in H0. apply symmetry. assumption. Qed. + + Section flip. + + Lemma flip_Reflexive `{Reflexive R} : Reflexive (flip R). + Proof. tauto. Qed. + + Program Definition flip_Irreflexive `(Irreflexive R) : Irreflexive (flip R) := + irreflexivity (R:=R). + + Program Definition flip_Symmetric `(Symmetric R) : Symmetric (flip R) := + fun x y H => symmetry (R:=R) H. + + Program Definition flip_Asymmetric `(Asymmetric R) : Asymmetric (flip R) := + fun x y H H' => asymmetry (R:=R) H H'. + + Program Definition flip_Transitive `(Transitive R) : Transitive (flip R) := + fun x y z H H' => transitivity (R:=R) H' H. + + Program Definition flip_Antisymmetric `(Antisymmetric eqA R) : + Antisymmetric eqA (flip R). + Proof. firstorder. Qed. + + (** Inversing the larger structures *) + + Lemma flip_PreOrder `(PreOrder R) : PreOrder (flip R). + Proof. firstorder. Qed. + + Lemma flip_StrictOrder `(StrictOrder R) : StrictOrder (flip R). + Proof. firstorder. Qed. + + Lemma flip_PER `(PER R) : PER (flip R). + Proof. firstorder. Qed. + + Lemma flip_Equivalence `(Equivalence R) : Equivalence (flip R). + Proof. firstorder. Qed. + + End flip. + + Section complement. + + Definition complement_Irreflexive `(Reflexive R) + : Irreflexive (complement R). + Proof. firstorder. Qed. + + Definition complement_Symmetric `(Symmetric R) : Symmetric (complement R). + Proof. firstorder. Qed. + End complement. + + + (** Rewrite relation on a given support: declares a relation as a rewrite + relation for use by the generalized rewriting tactic. + It helps choosing if a rewrite should be handled + by the generalized or the regular rewriting tactic using leibniz equality. + Users can declare an [RewriteRelation A RA] anywhere to declare default + relations. This is also done automatically by the [Declare Relation A RA] + commands. *) -Class Reflexive {A} (R : relation A) := - reflexivity : forall x, R x x. + Class RewriteRelation (RA : relation A). -Class Irreflexive {A} (R : relation A) := - irreflexivity : Reflexive (complement R). + (** Any [Equivalence] declared in the context is automatically considered + a rewrite relation. *) + + Global Instance equivalence_rewrite_relation `(Equivalence eqA) : RewriteRelation eqA. + + (** Leibniz equality. *) + Section Leibniz. + Global Instance eq_Reflexive : Reflexive (@eq A) := @eq_refl A. + Global Instance eq_Symmetric : Symmetric (@eq A) := @eq_sym A. + Global Instance eq_Transitive : Transitive (@eq A) := @eq_trans A. + + (** Leibinz equality [eq] is an equivalence relation. + The instance has low priority as it is always applicable + if only the type is constrained. *) + + Global Program Instance eq_equivalence : Equivalence (@eq A) | 10. + End Leibniz. + +End Defs. + +(** Default rewrite relations handled by [setoid_rewrite]. *) +Instance: RewriteRelation impl. +Instance: RewriteRelation iff. +(** Hints to drive the typeclass resolution avoiding loops + due to the use of full unification. *) Hint Extern 1 (Reflexive (complement _)) => class_apply @irreflexivity : typeclass_instances. +Hint Extern 3 (Symmetric (complement _)) => class_apply complement_Symmetric : typeclass_instances. +Hint Extern 3 (Irreflexive (complement _)) => class_apply complement_Irreflexive : typeclass_instances. -Class Symmetric {A} (R : relation A) := - symmetry : forall x y, R x y -> R y x. - -Class Asymmetric {A} (R : relation A) := - asymmetry : forall x y, R x y -> R y x -> False. +Hint Extern 3 (Reflexive (flip _)) => apply flip_Reflexive : typeclass_instances. +Hint Extern 3 (Irreflexive (flip _)) => class_apply flip_Irreflexive : typeclass_instances. +Hint Extern 3 (Symmetric (flip _)) => class_apply flip_Symmetric : typeclass_instances. +Hint Extern 3 (Asymmetric (flip _)) => class_apply flip_Asymmetric : typeclass_instances. +Hint Extern 3 (Antisymmetric (flip _)) => class_apply flip_Antisymmetric : typeclass_instances. +Hint Extern 3 (Transitive (flip _)) => class_apply flip_Transitive : typeclass_instances. +Hint Extern 3 (StrictOrder (flip _)) => class_apply flip_StrictOrder : typeclass_instances. +Hint Extern 3 (PreOrder (flip _)) => class_apply flip_PreOrder : typeclass_instances. -Class Transitive {A} (R : relation A) := - transitivity : forall x y z, R x y -> R y z -> R x z. +Hint Extern 4 (subrelation (flip _) _) => + class_apply @subrelation_symmetric : typeclass_instances. Hint Resolve irreflexivity : ord. @@ -72,40 +218,6 @@ Hint Extern 4 => solve_relation : relations. (** We can already dualize all these properties. *) -Generalizable Variables A B C D R S T U l eqA eqB eqC eqD. - -Lemma flip_Reflexive `{Reflexive A R} : Reflexive (flip R). -Proof. tauto. Qed. - -Hint Extern 3 (Reflexive (flip _)) => apply flip_Reflexive : typeclass_instances. - -Program Definition flip_Irreflexive `(Irreflexive A R) : Irreflexive (flip R) := - irreflexivity (R:=R). - -Program Definition flip_Symmetric `(Symmetric A R) : Symmetric (flip R) := - fun x y H => symmetry (R:=R) H. - -Program Definition flip_Asymmetric `(Asymmetric A R) : Asymmetric (flip R) := - fun x y H H' => asymmetry (R:=R) H H'. - -Program Definition flip_Transitive `(Transitive A R) : Transitive (flip R) := - fun x y z H H' => transitivity (R:=R) H' H. - -Hint Extern 3 (Irreflexive (flip _)) => class_apply flip_Irreflexive : typeclass_instances. -Hint Extern 3 (Symmetric (flip _)) => class_apply flip_Symmetric : typeclass_instances. -Hint Extern 3 (Asymmetric (flip _)) => class_apply flip_Asymmetric : typeclass_instances. -Hint Extern 3 (Transitive (flip _)) => class_apply flip_Transitive : typeclass_instances. - -Definition Reflexive_complement_Irreflexive `(Reflexive A (R : relation A)) - : Irreflexive (complement R). -Proof. firstorder. Qed. - -Definition complement_Symmetric `(Symmetric A (R : relation A)) : Symmetric (complement R). -Proof. firstorder. Qed. - -Hint Extern 3 (Symmetric (complement _)) => class_apply complement_Symmetric : typeclass_instances. -Hint Extern 3 (Irreflexive (complement _)) => class_apply Reflexive_complement_Irreflexive : typeclass_instances. - (** * Standard instances. *) Ltac reduce_hyp H := @@ -145,54 +257,6 @@ Instance iff_Reflexive : Reflexive iff := iff_refl. Instance iff_Symmetric : Symmetric iff := iff_sym. Instance iff_Transitive : Transitive iff := iff_trans. -(** Leibniz equality. *) - -Instance eq_Reflexive {A} : Reflexive (@eq A) := @eq_refl A. -Instance eq_Symmetric {A} : Symmetric (@eq A) := @eq_sym A. -Instance eq_Transitive {A} : Transitive (@eq A) := @eq_trans A. - -(** Various combinations of reflexivity, symmetry and transitivity. *) - -(** A [PreOrder] is both Reflexive and Transitive. *) - -Class PreOrder {A} (R : relation A) : Prop := { - PreOrder_Reflexive :> Reflexive R | 2 ; - PreOrder_Transitive :> Transitive R | 2 }. - -(** A partial equivalence relation is Symmetric and Transitive. *) - -Class PER {A} (R : relation A) : Prop := { - PER_Symmetric :> Symmetric R | 3 ; - PER_Transitive :> Transitive R | 3 }. - -(** Equivalence relations. *) - -Class Equivalence {A} (R : relation A) : Prop := { - Equivalence_Reflexive :> Reflexive R ; - Equivalence_Symmetric :> Symmetric R ; - Equivalence_Transitive :> Transitive R }. - -(** An Equivalence is a PER plus reflexivity. *) - -Instance Equivalence_PER `(Equivalence A R) : PER R | 10 := - { PER_Symmetric := Equivalence_Symmetric ; - PER_Transitive := Equivalence_Transitive }. - -(** We can now define antisymmetry w.r.t. an equivalence relation on the carrier. *) - -Class Antisymmetric A eqA `{equ : Equivalence A eqA} (R : relation A) := - antisymmetry : forall {x y}, R x y -> R y x -> eqA x y. - -Program Definition flip_antiSymmetric `(Antisymmetric A eqA R) : - Antisymmetric A eqA (flip R). -Proof. firstorder. Qed. - -(** Leibinz equality [eq] is an equivalence relation. - The instance has low priority as it is always applicable - if only the type is constrained. *) - -Program Instance eq_equivalence : Equivalence (@eq A) | 10. - (** Logical equivalence [iff] is an equivalence relation. *) Program Instance iff_equivalence : Equivalence iff. @@ -203,9 +267,6 @@ Program Instance iff_equivalence : Equivalence iff. Local Open Scope list_scope. -(* Notation " [ ] " := nil : list_scope. *) -(* Notation " [ x ; .. ; y ] " := (cons x .. (cons y nil) ..) (at level 1) : list_scope. *) - (** A compact representation of non-dependent arities, with the codomain singled-out. *) (* Note, we do not use [list Type] because it imposes unnecessary universe constraints *) @@ -346,106 +407,66 @@ Program Instance predicate_implication_preorder : (** We define the various operations which define the algebra on binary relations, from the general ones. *) -Definition relation_equivalence {A : Type} : relation (relation A) := - @predicate_equivalence (_::_::Tnil). - -Class subrelation {A:Type} (R R' : relation A) : Prop := - is_subrelation : @predicate_implication (A::A::Tnil) R R'. - -Arguments subrelation {A} R R'. - -Definition relation_conjunction {A} (R : relation A) (R' : relation A) : relation A := - @predicate_intersection (A::A::Tnil) R R'. - -Definition relation_disjunction {A} (R : relation A) (R' : relation A) : relation A := - @predicate_union (A::A::Tnil) R R'. - -(** Relation equivalence is an equivalence, and subrelation defines a partial order. *) - -Set Automatic Introduction. - -Instance relation_equivalence_equivalence (A : Type) : - Equivalence (@relation_equivalence A). -Proof. exact (@predicate_equivalence_equivalence (A::A::Tnil)). Qed. - -Instance relation_implication_preorder A : PreOrder (@subrelation A). -Proof. exact (@predicate_implication_preorder (A::A::Tnil)). Qed. - -(** *** Partial Order. +Section Binary. + Context {A : Type}. + + Definition relation_equivalence : relation (relation A) := + @predicate_equivalence (_::_::Tnil). + + Global Instance: RewriteRelation relation_equivalence. + + Definition relation_conjunction (R : relation A) (R' : relation A) : relation A := + @predicate_intersection (A::A::Tnil) R R'. + + Definition relation_disjunction (R : relation A) (R' : relation A) : relation A := + @predicate_union (A::A::Tnil) R R'. + + (** Relation equivalence is an equivalence, and subrelation defines a partial order. *) + + Set Automatic Introduction. + + Global Instance relation_equivalence_equivalence : + Equivalence relation_equivalence. + Proof. exact (@predicate_equivalence_equivalence (A::A::Tnil)). Qed. + + Global Instance relation_implication_preorder : PreOrder (@subrelation A). + Proof. exact (@predicate_implication_preorder (A::A::Tnil)). Qed. + + (** *** Partial Order. A partial order is a preorder which is additionally antisymmetric. We give an equivalent definition, up-to an equivalence relation on the carrier. *) -Class PartialOrder {A} eqA `{equ : Equivalence A eqA} R `{preo : PreOrder A R} := - partial_order_equivalence : relation_equivalence eqA (relation_conjunction R (inverse R)). + Class PartialOrder eqA `{equ : Equivalence A eqA} R `{preo : PreOrder A R} := + partial_order_equivalence : relation_equivalence eqA (relation_conjunction R (flip R)). + + (** The equivalence proof is sufficient for proving that [R] must be a + morphism for equivalence (see Morphisms). It is also sufficient to + show that [R] is antisymmetric w.r.t. [eqA] *) + + Global Instance partial_order_antisym `(PartialOrder eqA R) : ! Antisymmetric A eqA R. + Proof with auto. + reduce_goal. + pose proof partial_order_equivalence as poe. do 3 red in poe. + apply <- poe. firstorder. + Qed. -(** The equivalence proof is sufficient for proving that [R] must be a morphism - for equivalence (see Morphisms). - It is also sufficient to show that [R] is antisymmetric w.r.t. [eqA] *) -Instance partial_order_antisym `(PartialOrder A eqA R) : ! Antisymmetric A eqA R. -Proof with auto. - reduce_goal. - pose proof partial_order_equivalence as poe. do 3 red in poe. - apply <- poe. firstorder. -Qed. + Lemma PartialOrder_inverse `(PartialOrder eqA R) : PartialOrder eqA (flip R). + Proof. firstorder. Qed. +End Binary. + +Hint Extern 3 (PartialOrder (flip _)) => class_apply PartialOrder_inverse : typeclass_instances. (** The partial order defined by subrelation and relation equivalence. *) Program Instance subrelation_partial_order : ! PartialOrder (relation A) relation_equivalence subrelation. - Next Obligation. - Proof. - unfold relation_equivalence in *. compute; firstorder. - Qed. +Next Obligation. +Proof. + unfold relation_equivalence in *. compute; firstorder. +Qed. Typeclasses Opaque arrows predicate_implication predicate_equivalence - relation_equivalence pointwise_lifting. - -(** Rewrite relation on a given support: declares a relation as a rewrite - relation for use by the generalized rewriting tactic. - It helps choosing if a rewrite should be handled - by the generalized or the regular rewriting tactic using leibniz equality. - Users can declare an [RewriteRelation A RA] anywhere to declare default - relations. This is also done automatically by the [Declare Relation A RA] - commands. *) - -Class RewriteRelation {A : Type} (RA : relation A). - -Instance: RewriteRelation impl. -Instance: RewriteRelation iff. -Instance: RewriteRelation (@relation_equivalence A). - -(** Any [Equivalence] declared in the context is automatically considered - a rewrite relation. *) - -Instance equivalence_rewrite_relation `(Equivalence A eqA) : RewriteRelation eqA. - -(** Strict Order *) - -Class StrictOrder {A : Type} (R : relation A) : Prop := { - StrictOrder_Irreflexive :> Irreflexive R ; - StrictOrder_Transitive :> Transitive R -}. - -Instance StrictOrder_Asymmetric `(StrictOrder A R) : Asymmetric R. -Proof. firstorder. Qed. - -(** Inversing a [StrictOrder] gives another [StrictOrder] *) - -Lemma StrictOrder_inverse `(StrictOrder A R) : StrictOrder (inverse R). -Proof. firstorder. Qed. - -(** Same for [PartialOrder]. *) - -Lemma PreOrder_inverse `(PreOrder A R) : PreOrder (inverse R). -Proof. firstorder. Qed. - -Hint Extern 3 (StrictOrder (inverse _)) => class_apply StrictOrder_inverse : typeclass_instances. -Hint Extern 3 (PreOrder (inverse _)) => class_apply PreOrder_inverse : typeclass_instances. - -Lemma PartialOrder_inverse `(PartialOrder A eqA R) : PartialOrder eqA (inverse R). -Proof. firstorder. Qed. - -Hint Extern 3 (PartialOrder (inverse _)) => class_apply PartialOrder_inverse : typeclass_instances. + relation_equivalence pointwise_lifting. diff --git a/theories/Classes/RelationPairs.v b/theories/Classes/RelationPairs.v index 2b010206c..73be830a4 100644 --- a/theories/Classes/RelationPairs.v +++ b/theories/Classes/RelationPairs.v @@ -9,8 +9,8 @@ (** * Relations over pairs *) +Require Import SetoidList. Require Import Relations Morphisms. - (* NB: This should be system-wide someday, but for that we need to fix the simpl tactic, since "simpl fst" would be refused for the moment. @@ -40,7 +40,7 @@ Generalizable Variables A B RA RB Ri Ro f. (** Any function from [A] to [B] allow to obtain a relation over [A] out of a relation over [B]. *) -Definition RelCompFun {A B}(R:relation B)(f:A->B) : relation A := +Definition RelCompFun {A} {B : Type}(R:relation B)(f:A->B) : relation A := fun a a' => R (f a) (f a'). Infix "@@" := RelCompFun (at level 30, right associativity) : signature_scope. @@ -62,13 +62,13 @@ Instance snd_measure : @Measure (A * B) B Snd. (** We define a product relation over [A*B]: each components should satisfy the corresponding initial relation. *) -Definition RelProd {A B}(RA:relation A)(RB:relation B) : relation (A*B) := - relation_conjunction (RA @@1) (RB @@2). +Polymorphic Definition RelProd {A : Type} {B : Type} (RA:relation A)(RB:relation B) : relation (A*B) := + relation_conjunction (@RelCompFun (A * B) A RA fst) (RB @@2). Infix "*" := RelProd : signature_scope. Section RelCompFun_Instances. - Context {A B : Type} (R : relation B). + Context {A : Type} {B : Type} (R : relation B). Global Instance RelCompFun_Reflexive `(Measure A B f, Reflexive _ R) : Reflexive (R@@f). @@ -94,57 +94,61 @@ Section RelCompFun_Instances. End RelCompFun_Instances. -Instance RelProd_Reflexive {A B}(RA:relation A)(RB:relation B) - `(Reflexive _ RA, Reflexive _ RB) : Reflexive (RA*RB). -Proof. firstorder. Qed. - -Instance RelProd_Symmetric {A B}(RA:relation A)(RB:relation B) - `(Symmetric _ RA, Symmetric _ RB) : Symmetric (RA*RB). -Proof. firstorder. Qed. - -Instance RelProd_Transitive {A B}(RA:relation A)(RB:relation B) - `(Transitive _ RA, Transitive _ RB) : Transitive (RA*RB). -Proof. firstorder. Qed. - -Program Instance RelProd_Equivalence {A B}(RA:relation A)(RB:relation B) - `(Equivalence _ RA, Equivalence _ RB) : Equivalence (RA*RB). - -Lemma FstRel_ProdRel {A B}(RA:relation A) : - relation_equivalence (RA @@1) (RA*(fun _ _ : B => True)). -Proof. firstorder. Qed. - -Lemma SndRel_ProdRel {A B}(RB:relation B) : - relation_equivalence (RB @@2) ((fun _ _ : A =>True) * RB). -Proof. firstorder. Qed. - -Instance FstRel_sub {A B} (RA:relation A)(RB:relation B): - subrelation (RA*RB) (RA @@1). -Proof. firstorder. Qed. - -Instance SndRel_sub {A B} (RA:relation A)(RB:relation B): - subrelation (RA*RB) (RB @@2). -Proof. firstorder. Qed. - -Instance pair_compat { A B } (RA:relation A)(RB:relation B) : - Proper (RA==>RB==> RA*RB) (@pair _ _). -Proof. firstorder. Qed. - -Instance fst_compat { A B } (RA:relation A)(RB:relation B) : - Proper (RA*RB ==> RA) Fst. -Proof. -intros (x,y) (x',y') (Hx,Hy); compute in *; auto. -Qed. - -Instance snd_compat { A B } (RA:relation A)(RB:relation B) : - Proper (RA*RB ==> RB) Snd. -Proof. -intros (x,y) (x',y') (Hx,Hy); compute in *; auto. -Qed. - -Instance RelCompFun_compat {A B}(f:A->B)(R : relation B) - `(Proper _ (Ri==>Ri==>Ro) R) : - Proper (Ri@@f==>Ri@@f==>Ro) (R@@f)%signature. -Proof. unfold RelCompFun; firstorder. Qed. +Section RelProd_Instances. + + Context {A : Type} {B : Type} (RA : relation A) (RB : relation B). + + Global Instance RelProd_Reflexive `(Reflexive _ RA, Reflexive _ RB) : Reflexive (RA*RB). + Proof. firstorder. Qed. + + Global Instance RelProd_Symmetric `(Symmetric _ RA, Symmetric _ RB) + : Symmetric (RA*RB). + Proof. firstorder. Qed. + + Global Instance RelProd_Transitive + `(Transitive _ RA, Transitive _ RB) : Transitive (RA*RB). + Proof. firstorder. Qed. + + Global Program Instance RelProd_Equivalence + `(Equivalence _ RA, Equivalence _ RB) : Equivalence (RA*RB). + + Lemma FstRel_ProdRel : + relation_equivalence (RA @@1) (RA*(fun _ _ : B => True)). + Proof. firstorder. Qed. + + Lemma SndRel_ProdRel : + relation_equivalence (RB @@2) ((fun _ _ : A =>True) * RB). + Proof. firstorder. Qed. + + Global Instance FstRel_sub : + subrelation (RA*RB) (RA @@1). + Proof. firstorder. Qed. + + Global Instance SndRel_sub : + subrelation (RA*RB) (RB @@2). + Proof. firstorder. Qed. + + Global Instance pair_compat : + Proper (RA==>RB==> RA*RB) (@pair _ _). + Proof. firstorder. Qed. + + Global Instance fst_compat : + Proper (RA*RB ==> RA) Fst. + Proof. + intros (x,y) (x',y') (Hx,Hy); compute in *; auto. + Qed. + + Global Instance snd_compat : + Proper (RA*RB ==> RB) Snd. + Proof. + intros (x,y) (x',y') (Hx,Hy); compute in *; auto. + Qed. + + Global Instance RelCompFun_compat (f:A->B) + `(Proper _ (Ri==>Ri==>Ro) RB) : + Proper (Ri@@f==>Ri@@f==>Ro) (RB@@f)%signature. + Proof. unfold RelCompFun; firstorder. Qed. +End RelProd_Instances. Hint Unfold RelProd RelCompFun. Hint Extern 2 (RelProd _ _ _ _) => split. diff --git a/theories/Classes/SetoidDec.v b/theories/Classes/SetoidDec.v index 7bc208c45..3ea8fe10e 100644 --- a/theories/Classes/SetoidDec.v +++ b/theories/Classes/SetoidDec.v @@ -121,7 +121,7 @@ Program Instance bool_function_eqdec `(! EqDec (eq_setoid A)) else in_right else in_right. - Solve Obligations with try red ; unfold equiv, complement ; program_simpl. + Solve Obligations with try red ; unfold complement ; program_simpl. Next Obligation. Proof. diff --git a/theories/FSets/FMapAVL.v b/theories/FSets/FMapAVL.v index 5d34a4bf5..bee922c6f 100644 --- a/theories/FSets/FMapAVL.v +++ b/theories/FSets/FMapAVL.v @@ -1247,11 +1247,11 @@ Proof. intros m1 m2; functional induction (concat m1 m2); intros; auto; try factornode _x _x0 _x1 _x2 _x3 as m1. apply join_bst; auto. - change (bst (m2',xd)#1); rewrite <-e1; eauto. + change (bst (m2',xd)#1). rewrite <-e1; eauto. intros y Hy. apply H1; auto. rewrite remove_min_in, e1; simpl; auto. - change (gt_tree (m2',xd)#2#1 (m2',xd)#1); rewrite <-e1; eauto. + change (gt_tree (m2',xd)#2#1 (m2',xd)#1). rewrite <-e1; eauto. Qed. Hint Resolve concat_bst. @@ -1930,7 +1930,7 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Lemma Equivb_Equivb : forall cmp m m', Equivb cmp m m' <-> Raw.Proofs.Equivb cmp m m'. Proof. - intros; unfold Equivb, Equiv, Raw.Proofs.Equivb, In; intuition. + intros; unfold Equivb, Equiv, Raw.Proofs.Equivb, In. intuition. generalize (H0 k); do 2 rewrite In_alt; intuition. generalize (H0 k); do 2 rewrite In_alt; intuition. generalize (H0 k); do 2 rewrite <- In_alt; intuition. diff --git a/theories/FSets/FMapFacts.v b/theories/FSets/FMapFacts.v index 85b7242b5..0e3b5cef1 100644 --- a/theories/FSets/FMapFacts.v +++ b/theories/FSets/FMapFacts.v @@ -437,12 +437,6 @@ intros; do 2 rewrite mem_find_b; rewrite remove_o; unfold eqb. destruct (eq_dec x y); auto. Qed. -Definition option_map (A B:Type)(f:A->B)(o:option A) : option B := - match o with - | Some a => Some (f a) - | None => None - end. - Lemma map_o : forall m x (f:elt->elt'), find x (map f m) = option_map f (find x m). Proof. @@ -678,7 +672,7 @@ Qed. Add Parametric Morphism elt : (@Empty elt) with signature Equal ==> iff as Empty_m. Proof. -unfold Empty; intros m m' Hm; intuition. +unfold Empty; intros m m' Hm. split; intros; intro. rewrite <-Hm in H0; eapply H, H0. rewrite Hm in H0; eapply H, H0. Qed. diff --git a/theories/FSets/FMapList.v b/theories/FSets/FMapList.v index f15ab222c..64d5b1c9a 100644 --- a/theories/FSets/FMapList.v +++ b/theories/FSets/FMapList.v @@ -527,7 +527,7 @@ Fixpoint mapi (f: key -> elt -> elt') (m:t elt) : t elt' := | nil => nil | (k,e)::m' => (k,f k e) :: mapi f m' end. - + End Elt. Section Elt2. (* A new section is necessary for previous definitions to work @@ -543,14 +543,13 @@ Proof. intros m x e f. (* functional induction map elt elt' f m. *) (* Marche pas ??? *) induction m. - inversion 1. + inversion 1. destruct a as (x',e'). simpl. - inversion_clear 1. + inversion_clear 1. constructor 1. unfold eqke in *; simpl in *; intuition congruence. - constructor 2. unfold MapsTo in *; auto. Qed. diff --git a/theories/FSets/FMapPositive.v b/theories/FSets/FMapPositive.v index 792b88717..253800a45 100644 --- a/theories/FSets/FMapPositive.v +++ b/theories/FSets/FMapPositive.v @@ -8,7 +8,7 @@ (** * FMapPositive : an implementation of FMapInterface for [positive] keys. *) -Require Import Bool ZArith OrderedType OrderedTypeEx FMapInterface. +Require Import Bool OrderedType ZArith OrderedType OrderedTypeEx FMapInterface. Set Implicit Arguments. Local Open Scope positive_scope. @@ -69,7 +69,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Module E:=PositiveOrderedTypeBits. Module ME:=KeyOrderedType E. - Definition key := positive. + Definition key := positive : Type. Inductive tree (A : Type) := | Leaf : tree A @@ -93,7 +93,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. | _ => false end. - Fixpoint find (i : positive) (m : t A) : option A := + Fixpoint find (i : key) (m : t A) : option A := match m with | Leaf => None | Node l o r => @@ -104,7 +104,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. end end. - Fixpoint mem (i : positive) (m : t A) : bool := + Fixpoint mem (i : key) (m : t A) : bool := match m with | Leaf => false | Node l o r => @@ -115,7 +115,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. end end. - Fixpoint add (i : positive) (v : A) (m : t A) : t A := + Fixpoint add (i : key) (v : A) (m : t A) : t A := match m with | Leaf => match i with @@ -131,7 +131,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. end end. - Fixpoint remove (i : positive) (m : t A) : t A := + Fixpoint remove (i : key) (m : t A) : t A := match i with | xH => match m with @@ -163,7 +163,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. (** [elements] *) - Fixpoint xelements (m : t A) (i : positive) : list (positive * A) := + Fixpoint xelements (m : t A) (i : key) : list (key * A) := match m with | Leaf => nil | Node l None r => @@ -190,33 +190,33 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Section CompcertSpec. Theorem gempty: - forall (i: positive), find i empty = None. + forall (i: key), find i empty = None. Proof. destruct i; simpl; auto. Qed. Theorem gss: - forall (i: positive) (x: A) (m: t A), find i (add i x m) = Some x. + forall (i: key) (x: A) (m: t A), find i (add i x m) = Some x. Proof. induction i; destruct m; simpl; auto. Qed. - Lemma gleaf : forall (i : positive), find i (Leaf : t A) = None. + Lemma gleaf : forall (i : key), find i (Leaf : t A) = None. Proof. exact gempty. Qed. Theorem gso: - forall (i j: positive) (x: A) (m: t A), + forall (i j: key) (x: A) (m: t A), i <> j -> find i (add j x m) = find i m. Proof. induction i; intros; destruct j; destruct m; simpl; try rewrite <- (gleaf i); auto; try apply IHi; congruence. Qed. - Lemma rleaf : forall (i : positive), remove i (Leaf : t A) = Leaf. + Lemma rleaf : forall (i : key), remove i (Leaf : t A) = Leaf. Proof. destruct i; simpl; auto. Qed. Theorem grs: - forall (i: positive) (m: t A), find i (remove i m) = None. + forall (i: key) (m: t A), find i (remove i m) = None. Proof. induction i; destruct m. simpl; auto. @@ -236,7 +236,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Qed. Theorem gro: - forall (i j: positive) (m: t A), + forall (i j: key) (m: t A), i <> j -> find i (remove j m) = find i m. Proof. induction i; intros; destruct j; destruct m; @@ -265,11 +265,11 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Qed. Lemma xelements_correct: - forall (m: t A) (i j : positive) (v: A), + forall (m: t A) (i j : key) (v: A), find i m = Some v -> List.In (append j i, v) (xelements m j). Proof. induction m; intros. - rewrite (gleaf i) in H; congruence. + rewrite (gleaf i) in H; discriminate. destruct o; destruct i; simpl; simpl in H. rewrite append_assoc_1; apply in_or_app; right; apply in_cons; apply IHm2; auto. @@ -282,14 +282,14 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Qed. Theorem elements_correct: - forall (m: t A) (i: positive) (v: A), + forall (m: t A) (i: key) (v: A), find i m = Some v -> List.In (i, v) (elements m). Proof. intros m i v H. exact (xelements_correct m i xH H). Qed. - Fixpoint xfind (i j : positive) (m : t A) : option A := + Fixpoint xfind (i j : key) (m : t A) : option A := match i, j with | _, xH => find i m | xO ii, xO jj => xfind ii jj m @@ -298,7 +298,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. end. Lemma xfind_left : - forall (j i : positive) (m1 m2 : t A) (o : option A) (v : A), + forall (j i : key) (m1 m2 : t A) (o : option A) (v : A), xfind i (append j (xO xH)) m1 = Some v -> xfind i j (Node m1 o m2) = Some v. Proof. induction j; intros; destruct i; simpl; simpl in H; auto; try congruence. @@ -306,7 +306,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Qed. Lemma xelements_ii : - forall (m: t A) (i j : positive) (v: A), + forall (m: t A) (i j : key) (v: A), List.In (xI i, v) (xelements m (xI j)) -> List.In (i, v) (xelements m j). Proof. induction m. @@ -322,7 +322,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Qed. Lemma xelements_io : - forall (m: t A) (i j : positive) (v: A), + forall (m: t A) (i j : key) (v: A), ~List.In (xI i, v) (xelements m (xO j)). Proof. induction m. @@ -337,7 +337,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Qed. Lemma xelements_oo : - forall (m: t A) (i j : positive) (v: A), + forall (m: t A) (i j : key) (v: A), List.In (xO i, v) (xelements m (xO j)) -> List.In (i, v) (xelements m j). Proof. induction m. @@ -353,7 +353,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Qed. Lemma xelements_oi : - forall (m: t A) (i j : positive) (v: A), + forall (m: t A) (i j : key) (v: A), ~List.In (xO i, v) (xelements m (xI j)). Proof. induction m. @@ -368,7 +368,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Qed. Lemma xelements_ih : - forall (m1 m2: t A) (o: option A) (i : positive) (v: A), + forall (m1 m2: t A) (o: option A) (i : key) (v: A), List.In (xI i, v) (xelements (Node m1 o m2) xH) -> List.In (i, v) (xelements m2 xH). Proof. destruct o; simpl; intros; destruct (in_app_or _ _ _ H). @@ -381,7 +381,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Qed. Lemma xelements_oh : - forall (m1 m2: t A) (o: option A) (i : positive) (v: A), + forall (m1 m2: t A) (o: option A) (i : key) (v: A), List.In (xO i, v) (xelements (Node m1 o m2) xH) -> List.In (i, v) (xelements m1 xH). Proof. destruct o; simpl; intros; destruct (in_app_or _ _ _ H). @@ -394,7 +394,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Qed. Lemma xelements_hi : - forall (m: t A) (i : positive) (v: A), + forall (m: t A) (i : key) (v: A), ~List.In (xH, v) (xelements m (xI i)). Proof. induction m; intros. @@ -409,7 +409,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Qed. Lemma xelements_ho : - forall (m: t A) (i : positive) (v: A), + forall (m: t A) (i : key) (v: A), ~List.In (xH, v) (xelements m (xO i)). Proof. induction m; intros. @@ -424,13 +424,13 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Qed. Lemma find_xfind_h : - forall (m: t A) (i: positive), find i m = xfind i xH m. + forall (m: t A) (i: key), find i m = xfind i xH m. Proof. destruct i; simpl; auto. Qed. Lemma xelements_complete: - forall (i j : positive) (m: t A) (v: A), + forall (i j : key) (m: t A) (v: A), List.In (i, v) (xelements m j) -> xfind i j m = Some v. Proof. induction i; simpl; intros; destruct j; simpl. @@ -458,7 +458,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Qed. Theorem elements_complete: - forall (m: t A) (i: positive) (v: A), + forall (m: t A) (i: key) (v: A), List.In (i, v) (elements m) -> find i m = Some v. Proof. intros m i v H. @@ -479,18 +479,18 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. End CompcertSpec. - Definition MapsTo (i:positive)(v:A)(m:t A) := find i m = Some v. + Definition MapsTo (i:key)(v:A)(m:t A) := find i m = Some v. - Definition In (i:positive)(m:t A) := exists e:A, MapsTo i e m. + Definition In (i:key)(m:t A) := exists e:A, MapsTo i e m. - Definition Empty m := forall (a : positive)(e:A) , ~ MapsTo a e m. + Definition Empty m := forall (a : key)(e:A) , ~ MapsTo a e m. - Definition eq_key (p p':positive*A) := E.eq (fst p) (fst p'). + Definition eq_key (p p':key*A) := E.eq (fst p) (fst p'). - Definition eq_key_elt (p p':positive*A) := + Definition eq_key_elt (p p':key*A) := E.eq (fst p) (fst p') /\ (snd p) = (snd p'). - Definition lt_key (p p':positive*A) := E.lt (fst p) (fst p'). + Definition lt_key (p p':key*A) := E.lt (fst p) (fst p'). Global Instance eqk_equiv : Equivalence eq_key := _. Global Instance eqke_equiv : Equivalence eq_key_elt := _. @@ -715,8 +715,8 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Lemma elements_3w : NoDupA eq_key (elements m). Proof. - change eq_key with (@ME.eqk A). - apply ME.Sort_NoDupA; apply elements_3; auto. + apply ME.Sort_NoDupA. + apply elements_3. Qed. End FMapSpec. @@ -727,9 +727,9 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Section Mapi. - Variable f : positive -> A -> B. + Variable f : key -> A -> B. - Fixpoint xmapi (m : t A) (i : positive) : t B := + Fixpoint xmapi (m : t A) (i : key) : t B := match m with | Leaf => @Leaf B | Node l o r => Node (xmapi l (append i (xO xH))) @@ -746,7 +746,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. End A. Lemma xgmapi: - forall (A B: Type) (f: positive -> A -> B) (i j : positive) (m: t A), + forall (A B: Type) (f: key -> A -> B) (i j : key) (m: t A), find i (xmapi f m j) = option_map (f (append j i)) (find i m). Proof. induction i; intros; destruct m; simpl; auto. @@ -756,7 +756,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Qed. Theorem gmapi: - forall (A B: Type) (f: positive -> A -> B) (i: positive) (m: t A), + forall (A B: Type) (f: key -> A -> B) (i: key) (m: t A), find i (mapi f m) = option_map (f i) (find i m). Proof. intros. @@ -820,7 +820,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. | Node l o r => Node (xmap2_l l) (f o None) (xmap2_l r) end. - Lemma xgmap2_l : forall (i : positive) (m : t A), + Lemma xgmap2_l : forall (i : key) (m : t A), f None None = None -> find i (xmap2_l m) = f (find i m) None. Proof. induction i; intros; destruct m; simpl; auto. @@ -832,7 +832,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. | Node l o r => Node (xmap2_r l) (f None o) (xmap2_r r) end. - Lemma xgmap2_r : forall (i : positive) (m : t B), + Lemma xgmap2_r : forall (i : key) (m : t B), f None None = None -> find i (xmap2_r m) = f None (find i m). Proof. induction i; intros; destruct m; simpl; auto. @@ -848,7 +848,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. end end. - Lemma gmap2: forall (i: positive)(m1:t A)(m2: t B), + Lemma gmap2: forall (i: key)(m1:t A)(m2: t B), f None None = None -> find i (_map2 m1 m2) = f (find i m1) (find i m2). Proof. @@ -896,9 +896,9 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Section Fold. Variables A B : Type. - Variable f : positive -> A -> B -> B. + Variable f : key -> A -> B -> B. - Fixpoint xfoldi (m : t A) (v : B) (i : positive) := + Fixpoint xfoldi (m : t A) (v : B) (i : key) := match m with | Leaf _ => v | Node l (Some x) r => @@ -1070,7 +1070,7 @@ Module PositiveMapAdditionalFacts. (* Derivable from the Map interface *) Theorem gsspec: - forall (A:Type)(i j: positive) (x: A) (m: t A), + forall (A:Type)(i j: key) (x: A) (m: t A), find i (add j x m) = if E.eq_dec i j then Some x else find i m. Proof. intros. @@ -1079,7 +1079,7 @@ Module PositiveMapAdditionalFacts. (* Not derivable from the Map interface *) Theorem gsident: - forall (A:Type)(i: positive) (m: t A) (v: A), + forall (A:Type)(i: key) (m: t A) (v: A), find i m = Some v -> add i v m = m. Proof. induction i; intros; destruct m; simpl; simpl in H; try congruence. @@ -1118,4 +1118,3 @@ Module PositiveMapAdditionalFacts. Qed. End PositiveMapAdditionalFacts. - diff --git a/theories/FSets/FSetPositive.v b/theories/FSets/FSetPositive.v index 670d09154..efd49f54e 100644 --- a/theories/FSets/FSetPositive.v +++ b/theories/FSets/FSetPositive.v @@ -27,7 +27,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. Module E:=PositiveOrderedTypeBits. - Definition elt := positive. + Definition elt := positive : Type. Inductive tree := | Leaf : tree @@ -35,9 +35,9 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. Scheme tree_ind := Induction for tree Sort Prop. - Definition t := tree. + Definition t := tree : Type. - Definition empty := Leaf. + Definition empty : t := Leaf. Fixpoint is_empty (m : t) : bool := match m with @@ -45,7 +45,11 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. | Node l b r => negb b &&& is_empty l &&& is_empty r end. +<<<<<<< HEAD Fixpoint mem (i : positive) (m : t) {struct m} : bool := +======= + Fixpoint mem (i : elt) (m : t) : bool := +>>>>>>> This commit adds full universe polymorphism and fast projections to Coq. match m with | Leaf => false | Node l o r => @@ -56,7 +60,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. end end. - Fixpoint add (i : positive) (m : t) : t := + Fixpoint add (i : elt) (m : t) : t := match m with | Leaf => match i with @@ -76,13 +80,17 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. (** helper function to avoid creating empty trees that are not leaves *) - Definition node l (b: bool) r := + Definition node (l : t) (b: bool) (r : t) : t := if b then Node l b r else match l,r with | Leaf,Leaf => Leaf | _,_ => Node l false r end. +<<<<<<< HEAD Fixpoint remove (i : positive) (m : t) {struct m} : t := +======= + Fixpoint remove (i : elt) (m : t) : t := +>>>>>>> This commit adds full universe polymorphism and fast projections to Coq. match m with | Leaf => Leaf | Node l o r => @@ -93,7 +101,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. end end. - Fixpoint union (m m': t) := + Fixpoint union (m m': t) : t := match m with | Leaf => m' | Node l o r => @@ -103,7 +111,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. end end. - Fixpoint inter (m m': t) := + Fixpoint inter (m m': t) : t := match m with | Leaf => Leaf | Node l o r => @@ -113,7 +121,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. end end. - Fixpoint diff (m m': t) := + Fixpoint diff (m m': t) : t := match m with | Leaf => Leaf | Node l o r => @@ -145,7 +153,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. (** reverses [y] and concatenate it with [x] *) - Fixpoint rev_append y x := + Fixpoint rev_append (y x : elt) : elt := match y with | 1 => x | y~1 => rev_append y x~1 @@ -156,8 +164,8 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. Section Fold. - Variables B : Type. - Variable f : positive -> B -> B. + Variable B : Type. + Variable f : elt -> B -> B. (** the additional argument, [i], records the current path, in reverse order (this should be more efficient: we reverse this argument @@ -165,7 +173,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. we also use this convention in all functions below *) - Fixpoint xfold (m : t) (v : B) (i : positive) := + Fixpoint xfold (m : t) (v : B) (i : elt) := match m with | Leaf => v | Node l true r => @@ -179,9 +187,9 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. Section Quantifiers. - Variable f : positive -> bool. + Variable f : elt -> bool. - Fixpoint xforall (m : t) (i : positive) := + Fixpoint xforall (m : t) (i : elt) := match m with | Leaf => true | Node l o r => @@ -189,21 +197,21 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. end. Definition for_all m := xforall m 1. - Fixpoint xexists (m : t) (i : positive) := + Fixpoint xexists (m : t) (i : elt) := match m with | Leaf => false | Node l o r => (o &&& f (rev i)) ||| xexists r i~1 ||| xexists l i~0 end. Definition exists_ m := xexists m 1. - Fixpoint xfilter (m : t) (i : positive) := + Fixpoint xfilter (m : t) (i : elt) : t := match m with | Leaf => Leaf | Node l o r => node (xfilter l i~0) (o &&& f (rev i)) (xfilter r i~1) end. Definition filter m := xfilter m 1. - Fixpoint xpartition (m : t) (i : positive) := + Fixpoint xpartition (m : t) (i : elt) : t * t := match m with | Leaf => (Leaf,Leaf) | Node l o r => @@ -221,7 +229,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. (** uses [a] to accumulate values rather than doing a lot of concatenations *) - Fixpoint xelements (m : t) (i : positive) (a: list positive) := + Fixpoint xelements (m : t) (i : elt) (a: list elt) := match m with | Leaf => a | Node l false r => xelements l i~0 (xelements r i~1 a) @@ -245,7 +253,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. (** would it be more efficient to use a path like in the above functions ? *) - Fixpoint choose (m: t) := + Fixpoint choose (m: t) : option elt := match m with | Leaf => None | Node l o r => if o then Some 1 else @@ -255,7 +263,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. end end. - Fixpoint min_elt (m: t) := + Fixpoint min_elt (m: t) : option elt := match m with | Leaf => None | Node l o r => @@ -265,7 +273,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. end end. - Fixpoint max_elt (m: t) := + Fixpoint max_elt (m: t) : option elt := match m with | Leaf => None | Node l o r => @@ -750,7 +758,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. Proof. intros. rewrite diff_spec. split; assumption. Qed. (** Specification of [fold] *) - + Lemma fold_1: forall s (A : Type) (i : A) (f : elt -> A -> A), fold f s i = fold_left (fun a e => f e a) (elements s) i. Proof. @@ -798,15 +806,15 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. rewrite <- andb_lazy_alt. apply andb_true_iff. Qed. - Lemma filter_1 : forall s x f, compat_bool E.eq f -> + Lemma filter_1 : forall s x f, @compat_bool elt E.eq f -> In x (filter f s) -> In x s. Proof. unfold filter. intros s x f _. rewrite xfilter_spec. tauto. Qed. - Lemma filter_2 : forall s x f, compat_bool E.eq f -> + Lemma filter_2 : forall s x f, @compat_bool elt E.eq f -> In x (filter f s) -> f x = true. Proof. unfold filter. intros s x f _. rewrite xfilter_spec. tauto. Qed. - Lemma filter_3 : forall s x f, compat_bool E.eq f -> In x s -> + Lemma filter_3 : forall s x f, @compat_bool elt E.eq f -> In x s -> f x = true -> In x (filter f s). Proof. unfold filter. intros s x f _. rewrite xfilter_spec. tauto. Qed. @@ -831,11 +839,11 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. apply H. assumption. Qed. - Lemma for_all_1 : forall s f, compat_bool E.eq f -> + Lemma for_all_1 : forall s f, @compat_bool elt E.eq f -> For_all (fun x => f x = true) s -> for_all f s = true. Proof. intros s f _. unfold for_all. rewrite xforall_spec. trivial. Qed. - Lemma for_all_2 : forall s f, compat_bool E.eq f -> + Lemma for_all_2 : forall s f, @compat_bool elt E.eq f -> for_all f s = true -> For_all (fun x => f x = true) s. Proof. intros s f _. unfold for_all. rewrite xforall_spec. trivial. Qed. @@ -858,11 +866,11 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. intros [[x|x|] H]; eauto. Qed. - Lemma exists_1 : forall s f, compat_bool E.eq f -> + Lemma exists_1 : forall s f, @compat_bool elt E.eq f -> Exists (fun x => f x = true) s -> exists_ f s = true. Proof. intros s f _. unfold exists_. rewrite xexists_spec. trivial. Qed. - Lemma exists_2 : forall s f, compat_bool E.eq f -> + Lemma exists_2 : forall s f, @compat_bool elt E.eq f -> exists_ f s = true -> Exists (fun x => f x = true) s. Proof. intros s f _. unfold exists_. rewrite xexists_spec. trivial. Qed. @@ -878,11 +886,11 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. destruct o; simpl; rewrite IHl, IHr; reflexivity. Qed. - Lemma partition_1 : forall s f, compat_bool E.eq f -> + Lemma partition_1 : forall s f, @compat_bool elt E.eq f -> Equal (fst (partition f s)) (filter f s). Proof. intros. rewrite partition_filter. apply eq_refl. Qed. - Lemma partition_2 : forall s f, compat_bool E.eq f -> + Lemma partition_2 : forall s f, @compat_bool elt E.eq f -> Equal (snd (partition f s)) (filter (fun x => negb (f x)) s). Proof. intros. rewrite partition_filter. apply eq_refl. Qed. @@ -990,7 +998,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. constructor. intros x H. apply E.lt_not_eq in H. apply H. reflexivity. intro. apply E.lt_trans. - intros ? ? <- ? ? <-. reflexivity. + solve_proper. apply elements_3. Qed. @@ -1101,7 +1109,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. destruct (min_elt r). injection H. intros <-. clear H. destruct y as [z|z|]. - apply (IHr p z); trivial. + apply (IHr e z); trivial. elim (Hp _ H'). discriminate. discriminate. @@ -1155,7 +1163,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. injection H. intros <-. clear H. destruct y as [z|z|]. elim (Hp _ H'). - apply (IHl p z); trivial. + apply (IHl e z); trivial. discriminate. discriminate. Qed. diff --git a/theories/Init/Datatypes.v b/theories/Init/Datatypes.v index a95695454..cc46fe617 100644 --- a/theories/Init/Datatypes.v +++ b/theories/Init/Datatypes.v @@ -143,6 +143,8 @@ Arguments S _%nat. (********************************************************************) (** * Container datatypes *) +Set Universe Polymorphism. + (** [option A] is the extension of [A] with an extra element [None] *) Inductive option (A:Type) : Type := @@ -182,7 +184,8 @@ Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope. Arguments pair {A B} _ _. Section projections. - Variables A B : Type. + Context {A : Type} {B : Type}. + Definition fst (p:A * B) := match p with | (x, y) => x end. @@ -244,8 +247,10 @@ Definition app (A : Type) : list A -> list A -> list A := | a :: l1 => a :: app l1 m end. + Infix "++" := app (right associativity, at level 60) : list_scope. +Unset Universe Polymorphism. (********************************************************************) (** * The comparison datatype *) @@ -310,6 +315,7 @@ Defined. Definition CompSpec {A} (eq lt : A->A->Prop)(x y:A) : comparison -> Prop := CompareSpec (eq x y) (lt x y) (lt y x). + Definition CompSpecT {A} (eq lt : A->A->Prop)(x y:A) : comparison -> Type := CompareSpecT (eq x y) (lt x y) (lt y x). Hint Unfold CompSpec CompSpecT. @@ -336,8 +342,11 @@ Arguments identity_rect [A] a P f y i. (** Identity type *) -Definition ID := forall A:Type, A -> A. -Definition id : ID := fun A x => x. +Polymorphic Definition ID := forall A:Type, A -> A. +Polymorphic Definition id : ID := fun A x => x. + +Definition IDProp := forall A:Prop, A -> A. +Definition idProp : IDProp := fun A x => x. (* begin hide *) diff --git a/theories/Init/Logic.v b/theories/Init/Logic.v index 9251d00ff..f994b4ca6 100644 --- a/theories/Init/Logic.v +++ b/theories/Init/Logic.v @@ -15,6 +15,7 @@ Notation "A -> B" := (forall (_ : A), B) : type_scope. (** * Propositional connectives *) (** [True] is the always true proposition *) + Inductive True : Prop := I : True. @@ -232,7 +233,6 @@ Notation "'IF' c1 'then' c2 'else' c3" := (IF_then_else c1 c2 c3) P x] is in fact equivalent to [ex (fun x => P x)] which may be not convertible to [ex P] if [P] is not itself an abstraction *) - Inductive ex (A:Type) (P:A -> Prop) : Prop := ex_intro : forall x:A, P x -> ex (A:=A) P. @@ -301,7 +301,8 @@ Arguments eq_ind [A] x P _ y _. Arguments eq_rec [A] x P _ y _. Arguments eq_rect [A] x P _ y _. -Hint Resolve I conj or_introl or_intror eq_refl: core. +Hint Resolve I conj or_introl or_intror : core. +Hint Resolve eq_refl: core. Hint Resolve ex_intro ex_intro2: core. Section Logic_lemmas. @@ -341,7 +342,7 @@ Section Logic_lemmas. Definition eq_ind_r : forall (A:Type) (x:A) (P:A -> Prop), P x -> forall y:A, y = x -> P y. - intros A x P H y H0; elim eq_sym with (1 := H0); assumption. + intros A x P H y H0. elim eq_sym with (1 := H0); assumption. Defined. Definition eq_rec_r : diff --git a/theories/Init/Specif.v b/theories/Init/Specif.v index f58c21f48..f534dd6c6 100644 --- a/theories/Init/Specif.v +++ b/theories/Init/Specif.v @@ -21,19 +21,19 @@ Require Import Logic. Similarly [(sig2 A P Q)], or [{x:A | P x & Q x}], denotes the subset of elements of the type [A] which satisfy both [P] and [Q]. *) -Inductive sig (A:Type) (P:A -> Prop) : Type := +Polymorphic Inductive sig (A:Type) (P:A -> Prop) : Type := exist : forall x:A, P x -> sig P. -Inductive sig2 (A:Type) (P Q:A -> Prop) : Type := +Polymorphic Inductive sig2 (A:Type) (P Q:A -> Prop) : Type := exist2 : forall x:A, P x -> Q x -> sig2 P Q. (** [(sigT A P)], or more suggestively [{x:A & (P x)}] is a Sigma-type. Similarly for [(sigT2 A P Q)], also written [{x:A & (P x) & (Q x)}]. *) -Inductive sigT (A:Type) (P:A -> Type) : Type := +Polymorphic Inductive sigT (A:Type) (P:A -> Type) : Type := existT : forall x:A, P x -> sigT P. -Inductive sigT2 (A:Type) (P Q:A -> Type) : Type := +Polymorphic Inductive sigT2 (A:Type) (P Q:A -> Type) : Type := existT2 : forall x:A, P x -> Q x -> sigT2 P Q. (* Notations *) @@ -65,7 +65,7 @@ Add Printing Let sigT2. [(proj1_sig y)] is the witness [a] and [(proj2_sig y)] is the proof of [(P a)] *) - +Set Universe Polymorphism. Section Subset_projections. Variable A : Type. @@ -123,6 +123,8 @@ End Subset_projections2. [(projT1 x)] is the first projection and [(projT2 x)] is the second projection, the type of which depends on the [projT1]. *) + + Section Projections. Variable A : Type. @@ -131,6 +133,7 @@ Section Projections. Definition projT1 (x:sigT P) : A := match x with | existT _ a _ => a end. + Definition projT2 (x:sigT P) : P (projT1 x) := match x return P (projT1 x) with | existT _ _ h => h @@ -212,6 +215,8 @@ Add Printing If sumor. Arguments inleft {A B} _ , [A] B _. Arguments inright {A B} _ , A [B] _. +Unset Universe Polymorphism. + (** Various forms of the axiom of choice for specifications *) Section Choice_lemmas. @@ -257,10 +262,10 @@ Section Dependent_choice_lemmas. (forall x:X, {y | R x y}) -> forall x0, {f : nat -> X | f O = x0 /\ forall n, R (f n) (f (S n))}. Proof. - intros H x0. + intros H x0. set (f:=fix f n := match n with O => x0 | S n' => proj1_sig (H (f n')) end). exists f. - split. reflexivity. + split. reflexivity. induction n; simpl; apply proj2_sig. Defined. @@ -273,11 +278,13 @@ End Dependent_choice_lemmas. [Inductive Exc [A:Type] : Type := value : A->(Exc A) | error : (Exc A)]. It is implemented using the option type. *) +Section Exc. + Variable A : Type. -Definition Exc := option. -Definition value := Some. -Definition error := @None. - + Definition Exc := option A. + Definition value := @Some A. + Definition error := @None A. +End Exc. Arguments error [A]. Definition except := False_rec. (* for compatibility with previous versions *) diff --git a/theories/Lists/List.v b/theories/Lists/List.v index d282fe8c3..f6a0382c2 100644 --- a/theories/Lists/List.v +++ b/theories/Lists/List.v @@ -10,7 +10,7 @@ Require Import Le Gt Minus Bool. Require Setoid. Set Implicit Arguments. - +Set Universe Polymorphism. (******************************************************************) (** * Basics: definition of polymorphic lists and some operations *) @@ -65,8 +65,6 @@ End ListNotations. Import ListNotations. -(** ** Facts about lists *) - Section Facts. Variable A : Type. @@ -131,7 +129,7 @@ Section Facts. subst a; auto. exists [], l; auto. destruct (IHl H) as (l1,(l2,H0)). - exists (a::l1), l2; simpl; f_equal; auto. + exists (a::l1), l2; simpl. apply f_equal. auto. Qed. (** Inversion *) @@ -174,7 +172,7 @@ Section Facts. Qed. Theorem app_nil_r : forall l:list A, l ++ [] = l. - Proof. + Proof. induction l; simpl; f_equal; auto. Qed. @@ -654,8 +652,6 @@ Section Elts. End Elts. - - (*******************************) (** * Manipulating whole lists *) (*******************************) @@ -858,7 +854,7 @@ End ListOps. (************) Section Map. - Variables A B : Type. + Variables (A : Type) (B : Type). Variable f : A -> B. Fixpoint map (l:list A) : list B := @@ -983,7 +979,7 @@ Qed. (************************************) Section Fold_Left_Recursor. - Variables A B : Type. + Variables (A : Type) (B : Type). Variable f : A -> B -> A. Fixpoint fold_left (l:list B) (a0:A) : A := @@ -1021,7 +1017,7 @@ Qed. (************************************) Section Fold_Right_Recursor. - Variables A B : Type. + Variables (A : Type) (B : Type). Variable f : B -> A -> A. Variable a0 : A. @@ -1211,7 +1207,7 @@ End Fold_Right_Recursor. (******************************************************) Section ListPairs. - Variables A B : Type. + Variables (A : Type) (B : Type). (** [split] derives two lists from a list of pairs *) @@ -2039,3 +2035,5 @@ Notation AllS := Forall (only parsing). (* was formerly in TheoryList *) Hint Resolve app_nil_end : datatypes v62. (* end hide *) + +Unset Universe Polymorphism. diff --git a/theories/Lists/SetoidList.v b/theories/Lists/SetoidList.v index 8fd229917..d75eb384f 100644 --- a/theories/Lists/SetoidList.v +++ b/theories/Lists/SetoidList.v @@ -11,7 +11,7 @@ Require Export Sorted. Require Export Setoid Basics Morphisms. Set Implicit Arguments. Unset Strict Implicit. - +Set Universe Polymorphism. (** * Logical relations over lists with respect to a setoid equality or ordering. *) @@ -34,7 +34,7 @@ Hint Constructors InA. of the previous one. Having [InA = Exists eqA] raises too many compatibility issues. For now, we only state the equivalence: *) -Lemma InA_altdef : forall x l, InA x l <-> Exists (eqA x) l. +Lemma InA_altdef : forall x l, InA x l <-> Exists (eqA x) l. Proof. split; induction 1; auto. Qed. Lemma InA_cons : forall x y l, InA x (y::l) <-> eqA x y \/ InA x l. @@ -104,7 +104,7 @@ Hypothesis eqA_equiv : Equivalence eqA. Definition eqarefl := (@Equivalence_Reflexive _ _ eqA_equiv). Definition eqatrans := (@Equivalence_Transitive _ _ eqA_equiv). Definition eqasym := (@Equivalence_Symmetric _ _ eqA_equiv). - + Hint Resolve eqarefl eqatrans. Hint Immediate eqasym. @@ -151,7 +151,7 @@ Qed. Lemma InA_eqA : forall l x y, eqA x y -> InA x l -> InA y l. Proof. - intros l x y H H'. rewrite <- H; auto. + intros l x y H H'. rewrite <- H. auto. Qed. Hint Immediate InA_eqA. @@ -498,7 +498,7 @@ Proof. apply Hrec; auto. inv; auto. eapply NoDupA_split; eauto. - invlist ForallOrdPairs; auto. + invlist ForallOrdPairs; auto. eapply equivlistA_NoDupA_split; eauto. transitivity (f y (fold_right f i (s1++s2))). apply Comp; auto. reflexivity. @@ -819,7 +819,6 @@ intros. rewrite filter_In in H; destruct H. eapply SortA_InfA_InA; eauto. Qed. - Arguments eq {A} x _. Lemma filter_InA : forall f, Proper (eqA==>eq) f -> diff --git a/theories/Lists/SetoidPermutation.v b/theories/Lists/SetoidPermutation.v index b0657b63a..05f03ea56 100644 --- a/theories/Lists/SetoidPermutation.v +++ b/theories/Lists/SetoidPermutation.v @@ -7,6 +7,7 @@ (***********************************************************************) Require Import SetoidList. +Set Universe Polymorphism. Set Implicit Arguments. Unset Strict Implicit. @@ -88,7 +89,7 @@ Lemma PermutationA_cons_app l lâ‚ lâ‚‚ x : PermutationA l (lâ‚ ++ lâ‚‚) -> PermutationA (x :: l) (lâ‚ ++ x :: lâ‚‚). Proof. intros E. rewrite E. - now rewrite app_comm_cons, PermutationA_cons_append, <-app_assoc. + now rewrite app_comm_cons, (PermutationA_cons_append lâ‚ x), <- app_assoc. Qed. Lemma PermutationA_middle lâ‚ lâ‚‚ x : diff --git a/theories/Logic/Berardi.v b/theories/Logic/Berardi.v index 383775735..cb61e8f00 100644 --- a/theories/Logic/Berardi.v +++ b/theories/Logic/Berardi.v @@ -67,18 +67,13 @@ Variables A B : Prop. Record retract : Prop := {i : A -> B; j : B -> A; inv : forall a:A, j (i a) = a}. - Record retract_cond : Prop := {i2 : A -> B; j2 : B -> A; inv2 : retract -> forall a:A, j2 (i2 a) = a}. - (** The dependent elimination above implies the axiom of choice: *) -Lemma AC : forall r:retract_cond, retract -> forall a:A, j2 r (i2 r a) = a. -Proof. -intros r. -case r; simpl. -trivial. -Qed. + +Lemma AC : forall r:retract_cond, retract -> forall a:A, r.(j2) (r.(i2) a) = a. +Proof. intros r. exact r.(inv2). Qed. End Retracts. @@ -114,7 +109,7 @@ Proof. exists g f. intro a. unfold f, g; simpl. -apply AC. +apply AC. exists (fun x:pow U => x) (fun x:pow U => x). trivial. Qed. @@ -132,9 +127,10 @@ Lemma not_has_fixpoint : R R = Not_b (R R). Proof. unfold R at 1. unfold g. -rewrite AC with (r := L1 U U) (a := fun u:U => Not_b (u U u)). +rewrite AC. +trivial. +exists (fun x:pow U => x) (fun x:pow U => x). trivial. -exists (fun x:pow U => x) (fun x:pow U => x); trivial. Qed. diff --git a/theories/Logic/ChoiceFacts.v b/theories/Logic/ChoiceFacts.v index b22f58dad..57a82161d 100644 --- a/theories/Logic/ChoiceFacts.v +++ b/theories/Logic/ChoiceFacts.v @@ -96,6 +96,12 @@ Local Unset Intuition Negation Unfolding. (** Choice, reification and description schemes *) +(** We make them all polymorphic. most of them have existentials as conclusion + so they require polymorphism otherwise their first application (e.g. to an + existential in [Set]) will fix the level of [A]. +*) +Set Universe Polymorphism. + Section ChoiceSchemes. Variables A B :Type. @@ -217,39 +223,39 @@ End ChoiceSchemes. (** Generalized schemes *) Notation RelationalChoice := - (forall A B, RelationalChoice_on A B). + (forall A B : Type, RelationalChoice_on A B). Notation FunctionalChoice := - (forall A B, FunctionalChoice_on A B). + (forall A B : Type, FunctionalChoice_on A B). Definition FunctionalDependentChoice := - (forall A, FunctionalDependentChoice_on A). + (forall A : Type, FunctionalDependentChoice_on A). Definition FunctionalCountableChoice := - (forall A, FunctionalCountableChoice_on A). + (forall A : Type, FunctionalCountableChoice_on A). Notation FunctionalChoiceOnInhabitedSet := - (forall A B, inhabited B -> FunctionalChoice_on A B). + (forall A B : Type, inhabited B -> FunctionalChoice_on A B). Notation FunctionalRelReification := - (forall A B, FunctionalRelReification_on A B). + (forall A B : Type, FunctionalRelReification_on A B). Notation GuardedRelationalChoice := - (forall A B, GuardedRelationalChoice_on A B). + (forall A B : Type, GuardedRelationalChoice_on A B). Notation GuardedFunctionalChoice := - (forall A B, GuardedFunctionalChoice_on A B). + (forall A B : Type, GuardedFunctionalChoice_on A B). Notation GuardedFunctionalRelReification := - (forall A B, GuardedFunctionalRelReification_on A B). + (forall A B : Type, GuardedFunctionalRelReification_on A B). Notation OmniscientRelationalChoice := - (forall A B, OmniscientRelationalChoice_on A B). + (forall A B : Type, OmniscientRelationalChoice_on A B). Notation OmniscientFunctionalChoice := - (forall A B, OmniscientFunctionalChoice_on A B). + (forall A B : Type, OmniscientFunctionalChoice_on A B). Notation ConstructiveDefiniteDescription := - (forall A, ConstructiveDefiniteDescription_on A). + (forall A : Type, ConstructiveDefiniteDescription_on A). Notation ConstructiveIndefiniteDescription := - (forall A, ConstructiveIndefiniteDescription_on A). + (forall A : Type, ConstructiveIndefiniteDescription_on A). Notation IotaStatement := - (forall A, IotaStatement_on A). + (forall A : Type, IotaStatement_on A). Notation EpsilonStatement := - (forall A, EpsilonStatement_on A). + (forall A : Type, EpsilonStatement_on A). (** Subclassical schemes *) @@ -293,7 +299,7 @@ Proof. Qed. Lemma funct_choice_imp_rel_choice : - forall A B, FunctionalChoice_on A B -> RelationalChoice_on A B. + forall A B : Type, FunctionalChoice_on A B -> RelationalChoice_on A B. Proof. intros A B FunCh R H. destruct (FunCh R H) as (f,H0). @@ -306,7 +312,7 @@ Proof. Qed. Lemma funct_choice_imp_description : - forall A B, FunctionalChoice_on A B -> FunctionalRelReification_on A B. + forall A B : Type, FunctionalChoice_on A B -> FunctionalRelReification_on A B. Proof. intros A B FunCh R H. destruct (FunCh R) as [f H0]. @@ -319,10 +325,10 @@ Proof. Qed. Corollary FunChoice_Equiv_RelChoice_and_ParamDefinDescr : - forall A B, FunctionalChoice_on A B <-> + forall A B : Type, FunctionalChoice_on A B <-> RelationalChoice_on A B /\ FunctionalRelReification_on A B. Proof. - intros A B; split. + intros A B. split. intro H; split; [ exact (funct_choice_imp_rel_choice H) | exact (funct_choice_imp_description H) ]. @@ -363,7 +369,7 @@ Proof. Qed. Lemma rel_choice_indep_of_general_premises_imp_guarded_rel_choice : - forall A B, inhabited B -> RelationalChoice_on A B -> + forall A B : Type, inhabited B -> RelationalChoice_on A B -> IndependenceOfGeneralPremises -> GuardedRelationalChoice_on A B. Proof. intros A B Inh AC_rel IndPrem P R H. @@ -375,7 +381,7 @@ Proof. Qed. Lemma guarded_rel_choice_imp_rel_choice : - forall A B, GuardedRelationalChoice_on A B -> RelationalChoice_on A B. + forall A B : Type, GuardedRelationalChoice_on A B -> RelationalChoice_on A B. Proof. intros A B GAC_rel R H. destruct (GAC_rel (fun _ => True) R) as (R',(HR'R,H0)). @@ -794,12 +800,13 @@ be applied on the same Type universes on both sides of the first Require Import Setoid. Theorem constructive_definite_descr_excluded_middle : - ConstructiveDefiniteDescription -> + (forall A : Type, ConstructiveDefiniteDescription_on A) -> (forall P:Prop, P \/ ~ P) -> (forall P:Prop, {P} + {~ P}). Proof. intros Descr EM P. pose (select := fun b:bool => if b then P else ~P). assert { b:bool | select b } as ([|],HP). + red in Descr. apply Descr. rewrite <- unique_existence; split. destruct (EM P). @@ -815,14 +822,13 @@ Corollary fun_reification_descr_computational_excluded_middle_in_prop_context : (forall P:Prop, P \/ ~ P) -> forall C:Prop, ((forall P:Prop, {P} + {~ P}) -> C) -> C. Proof. - intros FunReify EM C; intuition auto using + intros FunReify EM C H. intuition auto using constructive_definite_descr_excluded_middle, (relative_non_contradiction_of_definite_descr (C:=C)). Qed. (**********************************************************************) (** * Choice => Dependent choice => Countable choice *) - (* The implications below are standard *) Require Import Arith. diff --git a/theories/Logic/Diaconescu.v b/theories/Logic/Diaconescu.v index 87b279877..0eba49a7e 100644 --- a/theories/Logic/Diaconescu.v +++ b/theories/Logic/Diaconescu.v @@ -99,7 +99,7 @@ Lemma AC_bool_subset_to_bool : Proof. destruct (guarded_rel_choice _ _ (fun Q:bool -> Prop => exists y : _, Q y) - (fun (Q:bool -> Prop) (y:bool) => Q y)) as (R,(HRsub,HR)). + (fun (Q:bool -> Prop) (y:bool) => Q y)) as (R,(HRsub,HR)). exact (fun _ H => H). exists R; intros P HP. destruct (HR P HP) as (y,(Hy,Huni)). @@ -172,7 +172,7 @@ Variables a1 a2 : A. (** We build the subset [A'] of [A] made of [a1] and [a2] *) -Definition A' := sigT (fun x => x=a1 \/ x=a2). +Definition A' := @sigT A (fun x => x=a1 \/ x=a2). Definition a1':A'. exists a1 ; auto. diff --git a/theories/Logic/EqdepFacts.v b/theories/Logic/EqdepFacts.v index 0e9f39f6b..2c971ec24 100644 --- a/theories/Logic/EqdepFacts.v +++ b/theories/Logic/EqdepFacts.v @@ -52,6 +52,8 @@ Table of contents: Import EqNotations. +Set Universe Polymorphism. + Section Dependent_Equality. Variable U : Type. @@ -117,7 +119,7 @@ Lemma eq_sigT_eq_dep : existT P p x = existT P q y -> eq_dep p x q y. Proof. intros. - dependent rewrite H. + dependent rewrite H. apply eq_dep_intro. Qed. @@ -162,11 +164,12 @@ Proof. split; auto using eq_sig_eq_dep, eq_dep_eq_sig. Qed. -(** Dependent equality is equivalent to a dependent pair of equalities *) +(** Dependent equality is equivalent tco a dependent pair of equalities *) Set Implicit Arguments. -Lemma eq_sigT_sig_eq : forall X P (x1 x2:X) H1 H2, existT P x1 H1 = existT P x2 H2 <-> {H:x1=x2 | rew H in H1 = H2}. +Lemma eq_sigT_sig_eq : forall X P (x1 x2:X) H1 H2, existT P x1 H1 = existT P x2 H2 <-> + {H:x1=x2 | rew H in H1 = H2}. Proof. intros; split; intro H. - change x2 with (projT1 (existT P x2 H2)). @@ -191,7 +194,7 @@ Lemma eq_sigT_snd : forall X P (x1 x2:X) H1 H2 (H:existT P x1 H1 = existT P x2 H2), rew (eq_sigT_fst H) in H1 = H2. Proof. intros. - unfold eq_sigT_fst. + unfold eq_sigT_fst. change x2 with (projT1 (existT P x2 H2)). change H2 with (projT2 (existT P x2 H2)) at 3. destruct H. @@ -271,8 +274,8 @@ Section Equivalences. Lemma eq_rect_eq__eq_dep_eq : Eq_rect_eq -> Eq_dep_eq. Proof. intros eq_rect_eq; red; intros. - apply (eq_rect_eq__eq_dep1_eq eq_rect_eq); apply eq_dep_dep1; trivial. - Qed. + apply (eq_rect_eq__eq_dep1_eq eq_rect_eq). apply eq_dep_dep1; trivial. + Qed. (** Uniqueness of Identity Proofs (UIP) is a consequence of *) (** Injectivity of Dependent Equality *) diff --git a/theories/Logic/Eqdep_dec.v b/theories/Logic/Eqdep_dec.v index 53b25d4a8..e4db81faf 100644 --- a/theories/Logic/Eqdep_dec.v +++ b/theories/Logic/Eqdep_dec.v @@ -35,6 +35,7 @@ Table of contents: (** * Streicher's K and injectivity of dependent pair hold on decidable types *) Set Implicit Arguments. +Set Universe Polymorphism. Section EqdepDec. @@ -203,7 +204,7 @@ Unset Implicit Arguments. Module Type DecidableType. - Parameter U:Type. + Monomorphic Parameter U:Type. Axiom eq_dec : forall x y:U, {x = y} + {x <> y}. End DecidableType. @@ -271,7 +272,7 @@ End DecidableEqDep. Module Type DecidableSet. - Parameter U:Type. + Parameter U:Set. Axiom eq_dec : forall x y:U, {x = y} + {x <> y}. End DecidableSet. @@ -294,23 +295,23 @@ Module DecidableEqDepSet (M:DecidableSet). Theorem eq_dep_eq : forall (P:U->Type) (p:U) (x y:P p), eq_dep U P p x p y -> x = y. - Proof N.eq_dep_eq. + Proof (eq_rect_eq__eq_dep_eq U eq_rect_eq). (** Uniqueness of Identity Proofs (UIP) *) Lemma UIP : forall (x y:U) (p1 p2:x = y), p1 = p2. - Proof N.UIP. + Proof (eq_dep_eq__UIP U eq_dep_eq). (** Uniqueness of Reflexive Identity Proofs *) Lemma UIP_refl : forall (x:U) (p:x = x), p = eq_refl x. - Proof N.UIP_refl. + Proof (UIP__UIP_refl U UIP). (** Streicher's axiom K *) Lemma Streicher_K : forall (x:U) (P:x = x -> Prop), P (eq_refl x) -> forall p:x = x, P p. - Proof N.Streicher_K. + Proof (K_dec_type eq_dec). (** Proof-irrelevance on subsets of decidable sets *) @@ -350,7 +351,7 @@ Qed. Lemma UIP_refl_unit (x : tt = tt) : x = eq_refl tt. Proof. - change (match tt as b return tt = b -> Type with + change (match tt as b return tt = b -> Prop with | tt => fun x => x = eq_refl tt end x). destruct x; reflexivity. diff --git a/theories/Logic/JMeq.v b/theories/Logic/JMeq.v index 530e05559..b557a7867 100644 --- a/theories/Logic/JMeq.v +++ b/theories/Logic/JMeq.v @@ -28,9 +28,11 @@ Arguments JMeq_refl {A x} , [A] x. Hint Resolve JMeq_refl. +Definition JMeq_hom {A : Type} (x y : A) := JMeq x y. + Lemma JMeq_sym : forall (A B:Type) (x:A) (y:B), JMeq x y -> JMeq y x. -Proof. -destruct 1; trivial. +Proof. +intros; destruct H; trivial. Qed. Hint Immediate JMeq_sym. diff --git a/theories/MSets/MSetEqProperties.v b/theories/MSets/MSetEqProperties.v index 4f0d93fb9..843b9aaa7 100644 --- a/theories/MSets/MSetEqProperties.v +++ b/theories/MSets/MSetEqProperties.v @@ -856,7 +856,7 @@ intros. rewrite <- (fold_equal _ _ _ _ fc ft 0 _ _ H). rewrite <- (fold_equal _ _ _ _ gc gt 0 _ _ H). rewrite <- (fold_equal _ _ _ _ fgc fgt 0 _ _ H); auto. -intros; do 3 (rewrite fold_add; auto with *). +intros. do 3 (rewrite fold_add; auto with *). do 3 rewrite fold_empty;auto. Qed. diff --git a/theories/MSets/MSetInterface.v b/theories/MSets/MSetInterface.v index bd8811689..a61ef8bcd 100644 --- a/theories/MSets/MSetInterface.v +++ b/theories/MSets/MSetInterface.v @@ -595,7 +595,7 @@ Module Raw2SetsOn (O:OrderedType)(M:RawSets O) <: SetsOn O. (** Specification of [lt] *) Instance lt_strorder : StrictOrder lt. Proof. constructor ; unfold lt; red. - unfold complement. red. intros. apply (irreflexivity H). + unfold complement. red. intros. apply (irreflexivity _ H). intros. transitivity y; auto. Qed. diff --git a/theories/MSets/MSetList.v b/theories/MSets/MSetList.v index b0e09b719..5c232f340 100644 --- a/theories/MSets/MSetList.v +++ b/theories/MSets/MSetList.v @@ -472,7 +472,7 @@ Module MakeRaw (X: OrderedType) <: RawSets X. equal s s' = true <-> Equal s s'. Proof. induction s as [ | x s IH]; intros [ | x' s'] Hs Hs'; simpl. - intuition. + intuition reflexivity. split; intros H. discriminate. assert (In x' nil) by (rewrite H; auto). inv. split; intros H. discriminate. assert (In x nil) by (rewrite <-H; auto). inv. inv. @@ -820,7 +820,7 @@ Module MakeRaw (X: OrderedType) <: RawSets X. Lemma compare_spec_aux : forall s s', CompSpec eq L.lt s s' (compare s s'). Proof. - induction s as [|x s IH]; intros [|x' s']; simpl; intuition. + induction s as [|x s IH]; intros [|x' s']; simpl; intuition. elim_compare x x'; auto. Qed. diff --git a/theories/MSets/MSetPositive.v b/theories/MSets/MSetPositive.v index f3a1d39c9..25a8c1629 100644 --- a/theories/MSets/MSetPositive.v +++ b/theories/MSets/MSetPositive.v @@ -93,7 +93,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. Module E:=PositiveOrderedTypeBits. - Definition elt := positive. + Definition elt := positive : Type. Inductive tree := | Leaf : tree @@ -101,9 +101,9 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. Scheme tree_ind := Induction for tree Sort Prop. - Definition t := tree. + Definition t := tree : Type. - Definition empty := Leaf. + Definition empty : t := Leaf. Fixpoint is_empty (m : t) : bool := match m with @@ -142,7 +142,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. (** helper function to avoid creating empty trees that are not leaves *) - Definition node l (b: bool) r := + Definition node (l : t) (b: bool) (r : t) : t := if b then Node l b r else match l,r with | Leaf,Leaf => Leaf @@ -159,7 +159,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. end end. - Fixpoint union (m m': t) := + Fixpoint union (m m': t) : t := match m with | Leaf => m' | Node l o r => @@ -169,7 +169,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. end end. - Fixpoint inter (m m': t) := + Fixpoint inter (m m': t) : t := match m with | Leaf => Leaf | Node l o r => @@ -179,7 +179,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. end end. - Fixpoint diff (m m': t) := + Fixpoint diff (m m': t) : t := match m with | Leaf => Leaf | Node l o r => @@ -211,7 +211,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. (** reverses [y] and concatenate it with [x] *) - Fixpoint rev_append y x := + Fixpoint rev_append (y x : elt) : elt := match y with | 1 => x | y~1 => rev_append y x~1 @@ -262,14 +262,14 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. end. Definition exists_ m := xexists m 1. - Fixpoint xfilter (m : t) (i : positive) := + Fixpoint xfilter (m : t) (i : positive) : t := match m with | Leaf => Leaf | Node l o r => node (xfilter l i~0) (o &&& f (rev i)) (xfilter r i~1) end. Definition filter m := xfilter m 1. - Fixpoint xpartition (m : t) (i : positive) := + Fixpoint xpartition (m : t) (i : positive) : t * t := match m with | Leaf => (Leaf,Leaf) | Node l o r => @@ -311,7 +311,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. (** would it be more efficient to use a path like in the above functions ? *) - Fixpoint choose (m: t) := + Fixpoint choose (m: t) : option elt := match m with | Leaf => None | Node l o r => if o then Some 1 else @@ -321,7 +321,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. end end. - Fixpoint min_elt (m: t) := + Fixpoint min_elt (m: t) : option elt := match m with | Leaf => None | Node l o r => @@ -331,7 +331,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. end end. - Fixpoint max_elt (m: t) := + Fixpoint max_elt (m: t) : option elt := match m with | Leaf => None | Node l o r => @@ -805,7 +805,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. rewrite <- andb_lazy_alt. apply andb_true_iff. Qed. - Lemma filter_spec: forall s x f, compat_bool E.eq f -> + Lemma filter_spec: forall s x f, @compat_bool elt E.eq f -> (In x (filter f s) <-> In x s /\ f x = true). Proof. intros. apply xfilter_spec. Qed. @@ -830,7 +830,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. apply H. assumption. Qed. - Lemma for_all_spec: forall s f, compat_bool E.eq f -> + Lemma for_all_spec: forall s f, @compat_bool elt E.eq f -> (for_all f s = true <-> For_all (fun x => f x = true) s). Proof. intros. apply xforall_spec. Qed. @@ -852,7 +852,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. intros [[x|x|] H]; eauto. Qed. - Lemma exists_spec : forall s f, compat_bool E.eq f -> + Lemma exists_spec : forall s f, @compat_bool elt E.eq f -> (exists_ f s = true <-> Exists (fun x => f x = true) s). Proof. intros. apply xexists_spec. Qed. @@ -868,11 +868,11 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. destruct o; simpl; rewrite IHl, IHr; reflexivity. Qed. - Lemma partition_spec1 : forall s f, compat_bool E.eq f -> + Lemma partition_spec1 : forall s f, @compat_bool elt E.eq f -> Equal (fst (partition f s)) (filter f s). Proof. intros. rewrite partition_filter. reflexivity. Qed. - Lemma partition_spec2 : forall s f, compat_bool E.eq f -> + Lemma partition_spec2 : forall s f, @compat_bool elt E.eq f -> Equal (snd (partition f s)) (filter (fun x => negb (f x)) s). Proof. intros. rewrite partition_filter. reflexivity. Qed. @@ -1079,7 +1079,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. destruct (min_elt r). injection H. intros <-. clear H. destruct y as [z|z|]. - apply (IHr p z); trivial. + apply (IHr e z); trivial. elim (Hp _ H'). discriminate. discriminate. @@ -1133,7 +1133,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. injection H. intros <-. clear H. destruct y as [z|z|]. elim (Hp _ H'). - apply (IHl p z); trivial. + apply (IHl e z); trivial. discriminate. discriminate. Qed. diff --git a/theories/MSets/MSetRBT.v b/theories/MSets/MSetRBT.v index f0cddcc38..d8f675ade 100644 --- a/theories/MSets/MSetRBT.v +++ b/theories/MSets/MSetRBT.v @@ -1047,7 +1047,7 @@ Qed. (** ** Filter *) -Lemma filter_app A f (l l':list A) : +Polymorphic Lemma filter_app A f (l l':list A) : List.filter f (l ++ l') = List.filter f l ++ List.filter f l'. Proof. induction l as [|x l IH]; simpl; trivial. @@ -1196,7 +1196,7 @@ Lemma INV_rev l1 l2 acc : Proof. intros. rewrite rev_append_rev. apply SortA_app with X.eq; eauto with *. - intros x y. inA. eapply l1_lt_acc; eauto. + intros x y. inA. eapply @l1_lt_acc; eauto. Qed. (** ** union *) diff --git a/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v b/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v index 39e086c31..17c69d226 100644 --- a/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v +++ b/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v @@ -93,7 +93,7 @@ Module ZnZ. lor : t -> t -> t; land : t -> t -> t; lxor : t -> t -> t }. - + Section Specs. Context {t : Type}{ops : Ops t}. diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v index 809169a4d..a6bc44682 100644 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v @@ -809,7 +809,7 @@ refine refine (@spec_ww_sqrt t w_is_even w_0 w_1 w_Bm1 w_sub w_add_mul_div w_digits w_zdigits _ww_zdigits w_sqrt2 pred add_mul_div head0 compare - _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _); wwauto. + _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _); wwauto. exact ZnZ.spec_zdigits. exact ZnZ.spec_more_than_1_digit. exact ZnZ.spec_is_even. @@ -846,7 +846,7 @@ refine intros (Hn,Hn'). assert (E : ZnZ.to_Z y = [|WW x y|] mod wB). { simpl; symmetry. - rewrite Z.add_comm, Z.mod_add; auto with zarith. + rewrite Z.add_comm, Z.mod_add; auto with zarith nocore. apply Z.mod_small; eauto with ZnZ zarith. } rewrite E. unfold wB, base. symmetry. apply Z.mod_pow2_bits_low; auto. @@ -923,6 +923,7 @@ refine End Z_2nZ. + Section MulAdd. Context {t : Type}{ops : ZnZ.Ops t}{specs : ZnZ.Specs ops}. diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v index 8525b0e13..dddae7db5 100644 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v @@ -211,8 +211,7 @@ Section DoubleDiv32. Variable w_div21 : w -> w -> w -> w*w. Variable ww_sub_c : zn2z w -> zn2z w -> carry (zn2z w). - Definition w_div32 a1 a2 a3 b1 b2 := - Eval lazy beta iota delta [ww_add_c_cont ww_add] in + Definition w_div32_body a1 a2 a3 b1 b2 := match w_compare a1 b1 with | Lt => let (q,r) := w_div21 a1 a2 b1 in @@ -233,6 +232,10 @@ Section DoubleDiv32. | Gt => (w_0, W0) (* cas absurde *) end. + Definition w_div32 a1 a2 a3 b1 b2 := + Eval lazy beta iota delta [ww_add_c_cont ww_add w_div32_body] in + w_div32_body a1 a2 a3 b1 b2. + (* Proof *) Variable w_digits : positive. @@ -312,26 +315,8 @@ Section DoubleDiv32. assert (U:= lt_0_wB w_digits); assert (U1:= lt_0_wwB w_digits). Spec_w_to_Z a1;Spec_w_to_Z a2;Spec_w_to_Z a3;Spec_w_to_Z b1;Spec_w_to_Z b2. rewrite wwB_wBwB; rewrite Z.pow_2_r; rewrite Z.mul_assoc;rewrite <- Z.mul_add_distr_r. - change (w_div32 a1 a2 a3 b1 b2) with - match w_compare a1 b1 with - | Lt => - let (q,r) := w_div21 a1 a2 b1 in - match ww_sub_c (w_WW r a3) (w_mul_c q b2) with - | C0 r1 => (q,r1) - | C1 r1 => - let q := w_pred q in - ww_add_c_cont w_WW w_add_c w_add_carry_c - (fun r2=>(w_pred q, ww_add w_add_c w_add w_add_carry r2 (WW b1 b2))) - (fun r2 => (q,r2)) - r1 (WW b1 b2) - end - | Eq => - ww_add_c_cont w_WW w_add_c w_add_carry_c - (fun r => (w_Bm2, ww_add w_add_c w_add w_add_carry r (WW b1 b2))) - (fun r => (w_Bm1,r)) - (WW (w_sub a2 b2) a3) (WW b1 b2) - | Gt => (w_0, W0) (* cas absurde *) - end. + change (w_div32 a1 a2 a3 b1 b2) with (w_div32_body a1 a2 a3 b1 b2). + unfold w_div32_body. rewrite spec_compare. case Z.compare_spec; intro Hcmp. simpl in Hlt. rewrite Hcmp in Hlt;assert ([|a2|] < [|b2|]). omega. diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v index df5d42bbc..789436334 100644 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v @@ -692,7 +692,7 @@ intros x; case x; simpl ww_is_even. intros x y H; unfold ww_sqrt2. repeat match goal with |- context[split ?x] => generalize (spec_split x); case (split x) - end; simpl fst; simpl snd. + end; simpl @fst; simpl @snd. intros w0 w1 Hw0 w2 w3 Hw1. assert (U: wB/4 <= [|w2|]). case (Z.le_gt_cases (wB / 4) [|w2|]); auto; intros H1. @@ -1193,7 +1193,7 @@ Qed. rewrite <- wwB_4_wB_4; auto. generalize (@spec_w_sqrt2 w0 w1 V);auto with zarith. case (w_sqrt2 w0 w1); intros w2 c. - simpl ww_to_Z; simpl fst. + simpl ww_to_Z; simpl @fst. case c; unfold interp_carry; autorewrite with rm10. intros w3 (H6, H7); rewrite H6. assert (V1 := spec_to_Z w3);auto with zarith. @@ -1256,7 +1256,7 @@ Qed. generalize (@spec_w_sqrt2 w0 w1 V);auto with zarith. case (w_sqrt2 w0 w1); intros w2 c. case (spec_to_Z w2); intros HH1 HH2. - simpl ww_to_Z; simpl fst. + simpl ww_to_Z; simpl @fst. assert (Hv3: [[ww_pred ww_zdigits]] = Zpos (xO w_digits) - 1). rewrite spec_ww_pred; rewrite spec_ww_zdigits. diff --git a/theories/Numbers/Cyclic/Int31/Cyclic31.v b/theories/Numbers/Cyclic/Int31/Cyclic31.v index 03fc58c55..634ff7d63 100644 --- a/theories/Numbers/Cyclic/Int31/Cyclic31.v +++ b/theories/Numbers/Cyclic/Int31/Cyclic31.v @@ -623,7 +623,7 @@ Section Basics. rewrite i2l_length; omega. generalize (firstn_length (size-n) (i2l x)). rewrite i2l_length. - intros H0 H1; rewrite H1 in H0. + intros H0 H1. rewrite H1 in H0. rewrite min_l in H0 by omega. simpl length in H0. omega. @@ -882,16 +882,16 @@ Section Basics. destruct p; simpl snd. specialize IHn with p. - destruct (p2ibis n p). simpl snd in *. -rewrite nshiftr_S_tail. + destruct (p2ibis n p). simpl @snd in *. + rewrite nshiftr_S_tail. destruct (le_lt_dec size n). rewrite nshiftr_above_size; auto. assert (H:=nshiftr_0_firstl _ _ l IHn). replace (shiftr (twice_plus_one i)) with i; auto. - destruct i; simpl in *; rewrite H; auto. + destruct i; simpl in *. rewrite H; auto. specialize IHn with p. - destruct (p2ibis n p); simpl snd in *. + destruct (p2ibis n p); simpl @snd in *. rewrite nshiftr_S_tail. destruct (le_lt_dec size n). rewrite nshiftr_above_size; auto. @@ -945,7 +945,7 @@ rewrite nshiftr_S_tail. intros. simpl p2ibis; destruct p; [ | | red; auto]; specialize IHn with p; - destruct (p2ibis n p); simpl snd in *; simpl phi_inv_positive; + destruct (p2ibis n p); simpl @snd in *; simpl phi_inv_positive; rewrite ?EqShiftL_twice_plus_one, ?EqShiftL_twice; replace (S (size - S n))%nat with (size - n)%nat by omega; apply IHn; omega. @@ -1629,7 +1629,7 @@ Section Int31_Specs. Lemma spec_pos_mod : forall w p, [|ZnZ.pos_mod p w|] = [|w|] mod (2 ^ [|p|]). Proof. - unfold ZnZ.pos_mod, int31_ops, compare31. + unfold int31_ops, ZnZ.pos_mod, compare31. change [|31|] with 31%Z. assert (forall w p, 31<=p -> [|w|] = [|w|] mod 2^p). intros. @@ -1959,7 +1959,7 @@ Section Int31_Specs. Lemma div31_phi i j: 0 < [|j|] -> [|fst (i/j)%int31|] = [|i|]/[|j|]. intros Hj; generalize (spec_div i j Hj). - case div31; intros q r; simpl fst. + case div31; intros q r; simpl @fst. intros (H1,H2); apply Zdiv_unique with [|r|]; auto with zarith. rewrite H1; ring. Qed. @@ -2094,7 +2094,7 @@ Section Int31_Specs. generalize (spec_div21 ih il j Hj Hj1). case div3121; intros q r (Hq, Hr). apply Zdiv_unique with (phi r); auto with zarith. - simpl fst; apply eq_trans with (1 := Hq); ring. + simpl @fst; apply eq_trans with (1 := Hq); ring. Qed. Lemma sqrt312_step_correct rec ih il j: @@ -2215,6 +2215,9 @@ Section Int31_Specs. apply Nat2Z.is_nonneg. Qed. + (* Avoid expanding [iter312_sqrt] before variables in the context. *) + Strategy 1 [iter312_sqrt]. + Lemma spec_sqrt2 : forall x y, wB/ 4 <= [|x|] -> let (s,r) := sqrt312 x y in diff --git a/theories/Numbers/NatInt/NZParity.v b/theories/Numbers/NatInt/NZParity.v index 0e9323789..1e6593b10 100644 --- a/theories/Numbers/NatInt/NZParity.v +++ b/theories/Numbers/NatInt/NZParity.v @@ -95,7 +95,7 @@ Proof. intros. generalize (Even_or_Odd n) (Even_Odd_False n). rewrite <- even_spec, <- odd_spec. - destruct (odd n), (even n); simpl; intuition. + destruct (odd n), (even n) ; simpl; intuition. Qed. Lemma negb_even : forall n, negb (even n) = odd n. diff --git a/theories/Numbers/NatInt/NZSqrt.v b/theories/Numbers/NatInt/NZSqrt.v index 8146fd014..6b6c85310 100644 --- a/theories/Numbers/NatInt/NZSqrt.v +++ b/theories/Numbers/NatInt/NZSqrt.v @@ -438,7 +438,7 @@ Instance sqrt_up_wd : Proper (eq==>eq) sqrt_up. Proof. assert (Proper (eq==>eq==>Logic.eq) compare). intros x x' Hx y y' Hy. do 2 case compare_spec; trivial; order. - intros x x' Hx. unfold sqrt_up. rewrite Hx. case compare; now rewrite ?Hx. + intros x x' Hx; unfold sqrt_up; rewrite Hx; case compare; now rewrite ?Hx. Qed. (** The spec of [sqrt_up] indeed determines it *) diff --git a/theories/Numbers/Natural/Abstract/NDefOps.v b/theories/Numbers/Natural/Abstract/NDefOps.v index 621a2ed9c..adbbc5ea0 100644 --- a/theories/Numbers/Natural/Abstract/NDefOps.v +++ b/theories/Numbers/Natural/Abstract/NDefOps.v @@ -133,7 +133,6 @@ Proof. intros m n; unfold ltb at 1. f_equiv. rewrite recursion_succ; f_equiv'. -reflexivity. Qed. (* Above, we rewrite applications of function. Is it possible to rewrite diff --git a/theories/Numbers/Natural/Abstract/NStrongRec.v b/theories/Numbers/Natural/Abstract/NStrongRec.v index 67cab5507..f98e8da9a 100644 --- a/theories/Numbers/Natural/Abstract/NStrongRec.v +++ b/theories/Numbers/Natural/Abstract/NStrongRec.v @@ -13,7 +13,7 @@ and proves its properties *) Require Export NSub. -Ltac f_equiv' := repeat (f_equiv; try intros ? ? ?; auto). +Ltac f_equiv' := repeat (repeat f_equiv; try intros ? ? ?; auto). Module NStrongRecProp (Import N : NAxiomsRecSig'). Include NSubProp N. @@ -82,7 +82,6 @@ Proof. intros. unfold strong_rec0. f_equiv. rewrite recursion_succ; f_equiv'. -reflexivity. Qed. Lemma strong_rec_0 : forall a, diff --git a/theories/Numbers/Natural/BigN/NMake.v b/theories/Numbers/Natural/BigN/NMake.v index 93ae858d8..bfbcb9465 100644 --- a/theories/Numbers/Natural/BigN/NMake.v +++ b/theories/Numbers/Natural/BigN/NMake.v @@ -242,8 +242,8 @@ Module Make (W0:CyclicType) <: NType. Definition comparen_m n : forall m, word (dom_t n) (S m) -> dom_t n -> comparison := let op := dom_op n in - let zero := @ZnZ.zero _ op in - let compare := @ZnZ.compare _ op in + let zero := ZnZ.zero (Ops:=op) in + let compare := ZnZ.compare (Ops:=op) in let compare0 := compare zero in fun m => compare_mn_1 (dom_t n) (dom_t n) zero compare compare0 compare (S m). @@ -273,7 +273,7 @@ Module Make (W0:CyclicType) <: NType. Local Notation compare_folded := (iter_sym _ - (fun n => @ZnZ.compare _ (dom_op n)) + (fun n => ZnZ.compare (Ops:=dom_op n)) comparen_m comparenm CompOpp). @@ -358,13 +358,13 @@ Module Make (W0:CyclicType) <: NType. Definition wn_mul n : forall m, word (dom_t n) (S m) -> dom_t n -> t := let op := dom_op n in - let zero := @ZnZ.zero _ op in - let succ := @ZnZ.succ _ op in - let add_c := @ZnZ.add_c _ op in - let mul_c := @ZnZ.mul_c _ op in + let zero := ZnZ.zero in + let succ := ZnZ.succ (Ops:=op) in + let add_c := ZnZ.add_c (Ops:=op) in + let mul_c := ZnZ.mul_c (Ops:=op) in let ww := @ZnZ.WW _ op in let ow := @ZnZ.OW _ op in - let eq0 := @ZnZ.eq0 _ op in + let eq0 := ZnZ.eq0 in let mul_add := @DoubleMul.w_mul_add _ zero succ add_c mul_c in let mul_add_n1 := @DoubleMul.double_mul_add_n1 _ zero ww ow mul_add in fun m x y => @@ -464,13 +464,13 @@ Module Make (W0:CyclicType) <: NType. Definition wn_divn1 n := let op := dom_op n in let zd := ZnZ.zdigits op in - let zero := @ZnZ.zero _ op in - let ww := @ZnZ.WW _ op in - let head0 := @ZnZ.head0 _ op in - let add_mul_div := @ZnZ.add_mul_div _ op in - let div21 := @ZnZ.div21 _ op in - let compare := @ZnZ.compare _ op in - let sub := @ZnZ.sub _ op in + let zero := ZnZ.zero in + let ww := ZnZ.WW in + let head0 := ZnZ.head0 in + let add_mul_div := ZnZ.add_mul_div in + let div21 := ZnZ.div21 in + let compare := ZnZ.compare in + let sub := ZnZ.sub in let ddivn1 := DoubleDivn1.double_divn1 zd zero ww head0 add_mul_div div21 compare sub in fun m x y => let (u,v) := ddivn1 (S m) x y in (mk_t_w' n m u, mk_t n v). @@ -633,12 +633,12 @@ Module Make (W0:CyclicType) <: NType. Definition wn_modn1 n := let op := dom_op n in let zd := ZnZ.zdigits op in - let zero := @ZnZ.zero _ op in - let head0 := @ZnZ.head0 _ op in - let add_mul_div := @ZnZ.add_mul_div _ op in - let div21 := @ZnZ.div21 _ op in - let compare := @ZnZ.compare _ op in - let sub := @ZnZ.sub _ op in + let zero := ZnZ.zero in + let head0 := ZnZ.head0 in + let add_mul_div := ZnZ.add_mul_div in + let div21 := ZnZ.div21 in + let compare := ZnZ.compare in + let sub := ZnZ.sub in let dmodn1 := DoubleDivn1.double_modn1 zd zero head0 add_mul_div div21 compare sub in fun m x y => reduce n (dmodn1 (S m) x y). diff --git a/theories/Numbers/Natural/BigN/NMake_gen.ml b/theories/Numbers/Natural/BigN/NMake_gen.ml index b28ce15b9..8df4b7c64 100644 --- a/theories/Numbers/Natural/BigN/NMake_gen.ml +++ b/theories/Numbers/Natural/BigN/NMake_gen.ml @@ -324,8 +324,13 @@ pr " Lemma spec_zeron : forall n, ZnZ.to_Z (zeron n) = 0%%Z. Proof. - do_size (destruct n; [exact ZnZ.spec_0|]). - destruct n; auto. simpl. rewrite make_op_S. exact ZnZ.spec_0. + do_size (destruct n; + [match goal with + |- @eq Z (_ (zeron ?n)) _ => + apply (ZnZ.spec_0 (Specs:=dom_spec n)) + end|]). + destruct n; auto. simpl. rewrite make_op_S. fold word. + apply (ZnZ.spec_0 (Specs:=wn_spec (SizePlus 0))). Qed. (** * Digits *) diff --git a/theories/Numbers/Rational/BigQ/QMake.v b/theories/Numbers/Rational/BigQ/QMake.v index 167be6d70..d9f4b0429 100644 --- a/theories/Numbers/Rational/BigQ/QMake.v +++ b/theories/Numbers/Rational/BigQ/QMake.v @@ -627,7 +627,7 @@ Module Make (NN:NType)(ZZ:ZType)(Import NZ:NType_ZType NN ZZ) <: QType. assert (Hz := spec_irred_zero nx dy). assert (Hz':= spec_irred_zero ny dx). destruct irred as (n1,d1); destruct irred as (n2,d2). - simpl snd in *; destruct Hg as [Hg1 Hg2]; destruct Hg' as [Hg1' Hg2']. + simpl @snd in *; destruct Hg as [Hg1 Hg2]; destruct Hg' as [Hg1' Hg2']. rewrite spec_norm_denum. qsimpl. @@ -665,7 +665,7 @@ Module Make (NN:NType)(ZZ:ZType)(Import NZ:NType_ZType NN ZZ) <: QType. assert (Hgc := strong_spec_irred nx dy). assert (Hgc' := strong_spec_irred ny dx). destruct irred as (n1,d1); destruct irred as (n2,d2). - simpl snd in *; destruct Hg as [Hg1 Hg2]; destruct Hg' as [Hg1' Hg2']. + simpl @snd in *; destruct Hg as [Hg1 Hg2]; destruct Hg' as [Hg1' Hg2']. unfold norm_denum; qsimpl. diff --git a/theories/PArith/BinPosDef.v b/theories/PArith/BinPosDef.v index aed4fef05..22f3dcd64 100644 --- a/theories/PArith/BinPosDef.v +++ b/theories/PArith/BinPosDef.v @@ -375,7 +375,7 @@ Fixpoint gcdn (n : nat) (a b : positive) : positive := Definition gcd (a b : positive) := gcdn (size_nat a + size_nat b)%nat a b. (** Generalized Gcd, also computing the division of a and b by the gcd *) - +Set Printing Universes. Fixpoint ggcdn (n : nat) (a b : positive) : (positive*(positive*positive)) := match n with | O => (1,(a,b)) diff --git a/theories/Program/Basics.v b/theories/Program/Basics.v index 22436de69..ab1eccee2 100644 --- a/theories/Program/Basics.v +++ b/theories/Program/Basics.v @@ -15,6 +15,8 @@ Institution: LRI, CNRS UMR 8623 - University Paris Sud *) +Set Universe Polymorphism. + (** The polymorphic identity function is defined in [Datatypes]. *) Arguments id {A} x. @@ -45,7 +47,7 @@ Definition const {A B} (a : A) := fun _ : B => a. (** The [flip] combinator reverses the first two arguments of a function. *) -Definition flip {A B C} (f : A -> B -> C) x y := f y x. +Monomorphic Definition flip {A B C} (f : A -> B -> C) x y := f y x. (** Application as a combinator. *) diff --git a/theories/Program/Equality.v b/theories/Program/Equality.v index 323e80cc3..96345e154 100644 --- a/theories/Program/Equality.v +++ b/theories/Program/Equality.v @@ -263,7 +263,7 @@ Class DependentEliminationPackage (A : Type) := Ltac elim_tac tac p := let ty := type of p in - let eliminator := eval simpl in (elim (A:=ty)) in + let eliminator := eval simpl in (@elim (_ : DependentEliminationPackage ty)) in tac p eliminator. (** Specialization to do case analysis or induction. diff --git a/theories/Program/Wf.v b/theories/Program/Wf.v index f6d795b94..d82fa602a 100644 --- a/theories/Program/Wf.v +++ b/theories/Program/Wf.v @@ -153,7 +153,7 @@ Section Fix_rects. Hypothesis equiv_lowers: forall x0 (g h: forall x: {y: A | R y x0}, P (proj1_sig x)), - (forall x p p', g (exist (fun y: A => R y x0) x p) = h (exist _ x p')) -> + (forall x p p', g (exist (fun y: A => R y x0) x p) = h (exist (*FIXME shouldn't be needed *) (fun y => R y x0) x p')) -> f g = f h. (* From equiv_lowers, it follows that @@ -231,10 +231,10 @@ Module WfExtensionality. Program Lemma fix_sub_eq_ext : forall (A : Type) (R : A -> A -> Prop) (Rwf : well_founded R) (P : A -> Type) - (F_sub : forall x : A, (forall y:{y : A | R y x}, P y) -> P x), + (F_sub : forall x : A, (forall y:{y : A | R y x}, P (` y)) -> P x), forall x : A, Fix_sub A R Rwf P F_sub x = - F_sub x (fun y:{y : A | R y x} => Fix_sub A R Rwf P F_sub y). + F_sub x (fun y:{y : A | R y x} => Fix_sub A R Rwf P F_sub (` y)). Proof. intros ; apply Fix_eq ; auto. intros. diff --git a/theories/QArith/Qcanon.v b/theories/QArith/Qcanon.v index e395e4d03..e777c74d3 100644 --- a/theories/QArith/Qcanon.v +++ b/theories/QArith/Qcanon.v @@ -460,13 +460,13 @@ Proof. induction n; simpl; auto with qarith. rewrite IHn; auto with qarith. Qed. - +Transparent Qred. Lemma Qcpower_0 : forall n, n<>O -> 0^n = 0. Proof. destruct n; simpl. destruct 1; auto. intros. - now apply Qc_is_canon. + now apply Qc_is_canon. Qed. Lemma Qcpower_pos : forall p n, 0 <= p -> 0 <= p^n. diff --git a/theories/QArith/Qreals.v b/theories/QArith/Qreals.v index 4a826f691..f363fd7c2 100644 --- a/theories/QArith/Qreals.v +++ b/theories/QArith/Qreals.v @@ -167,14 +167,13 @@ Qed. Lemma Q2R_inv : forall x : Q, ~ x==0 -> Q2R (/x) = (/ Q2R x)%R. Proof. -unfold Qinv, Q2R, Qeq; intros (x1, x2); unfold Qden, Qnum. -case x1. +unfold Qinv, Q2R, Qeq; intros (x1, x2). case x1; unfold Qnum, Qden. simpl; intros; elim H; trivial. -intros; field; auto. +intros; field; auto. intros; change (IZR (Zneg x2)) with (- IZR (' x2))%R; change (IZR (Zneg p)) with (- IZR (' p))%R; - field; (*auto 8 with real.*) + simpl; field; (*auto 8 with real.*) repeat split; auto; auto with real. Qed. diff --git a/theories/Reals/Ranalysis2.v b/theories/Reals/Ranalysis2.v index 3c15a3053..b2d9c749f 100644 --- a/theories/Reals/Ranalysis2.v +++ b/theories/Reals/Ranalysis2.v @@ -442,7 +442,7 @@ Proof. apply (Rabs_pos_lt _ H0). ring. assert (H6 := Req_dec x0 (x0 + h)); elim H6; intro. - intro; rewrite <- H7; unfold dist, R_met; unfold R_dist; + intro; rewrite <- H7. unfold R_met, dist; unfold R_dist; unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0; apply Rabs_pos_lt. unfold Rdiv; apply prod_neq_R0; diff --git a/theories/Reals/Ranalysis5.v b/theories/Reals/Ranalysis5.v index d876b5d8e..0614f3998 100644 --- a/theories/Reals/Ranalysis5.v +++ b/theories/Reals/Ranalysis5.v @@ -695,7 +695,7 @@ intros f g lb ub x Prf g_cont_pur lb_lt_ub x_encad Prg_incr f_eq_g df_neq. exists deltatemp ; exact Htemp. elim (Hf_deriv eps eps_pos). intros deltatemp Htemp. - red in Hlinv ; red in Hlinv ; simpl dist in Hlinv ; unfold R_dist in Hlinv. + red in Hlinv ; red in Hlinv ; unfold dist in Hlinv ; unfold R_dist in Hlinv. assert (Hlinv' := Hlinv (fun h => (f (y+h) - f y)/h) (fun h => h <>0) l 0). unfold limit1_in, limit_in, dist in Hlinv' ; simpl in Hlinv'. unfold R_dist in Hlinv'. assert (Premisse : (forall eps : R, diff --git a/theories/Reals/Rlimit.v b/theories/Reals/Rlimit.v index 658ffd12f..3d52a98cd 100644 --- a/theories/Reals/Rlimit.v +++ b/theories/Reals/Rlimit.v @@ -164,7 +164,7 @@ Definition limit_in (X X':Metric_Space) (f:Base X -> Base X') eps > 0 -> exists alp : R, alp > 0 /\ - (forall x:Base X, D x /\ dist X x x0 < alp -> dist X' (f x) l < eps). + (forall x:Base X, D x /\ X.(dist) x x0 < alp -> X'.(dist) (f x) l < eps). (*******************************) (** ** R is a metric space *) @@ -191,9 +191,9 @@ Lemma tech_limit : Proof. intros f D l x0 H H0. case (Rabs_pos (f x0 - l)); intros H1. - absurd (dist R_met (f x0) l < dist R_met (f x0) l). + absurd (R_met.(@dist) (f x0) l < R_met.(@dist) (f x0) l). apply Rlt_irrefl. - case (H0 (dist R_met (f x0) l)); auto. + case (H0 (R_met.(@dist) (f x0) l)); auto. intros alpha1 [H2 H3]; apply H3; auto; split; auto. case (dist_refl R_met x0 x0); intros Hr1 Hr2; rewrite Hr2; auto. case (dist_refl R_met (f x0) l); intros Hr1 Hr2; symmetry; auto. @@ -345,8 +345,9 @@ Lemma single_limit : adhDa D x0 -> limit1_in f D l x0 -> limit1_in f D l' x0 -> l = l'. Proof. unfold limit1_in; unfold limit_in; intros. + simpl in *. cut (forall eps:R, eps > 0 -> dist R_met l l' < 2 * eps). - clear H0 H1; unfold dist; unfold R_met; unfold R_dist; + clear H0 H1; simpl @dist; unfold R_met; unfold R_dist, dist; unfold Rabs; case (Rcase_abs (l - l')); intros. cut (forall eps:R, eps > 0 -> - (l - l') < eps). intro; generalize (prop_eps (- (l - l')) H1); intro; @@ -356,7 +357,7 @@ Proof. intros; cut (eps * / 2 > 0). intro; generalize (H0 (eps * / 2) H2); rewrite (Rmult_comm eps (/ 2)); rewrite <- (Rmult_assoc 2 (/ 2) eps); rewrite (Rinv_r 2). - elim (Rmult_ne eps); intros a b; rewrite b; clear a b; trivial. + elim (Rmult_ne eps); intros a b; rewrite b; clear a b; trivial. apply (Rlt_dichotomy_converse 2 0); right; generalize Rlt_0_1; intro; unfold Rgt; generalize (Rplus_lt_compat_l 1 0 1 H3); intro; elim (Rplus_ne 1); intros a b; rewrite a in H4; diff --git a/theories/Reals/Rtopology.v b/theories/Reals/Rtopology.v index f05539379..7e020dd41 100644 --- a/theories/Reals/Rtopology.v +++ b/theories/Reals/Rtopology.v @@ -339,7 +339,7 @@ Proof. unfold neighbourhood in H4; elim H4; intros del H5. exists (pos del); split. apply (cond_pos del). - intros; unfold included in H5; apply H5; elim H6; intros; apply H8. + intros. unfold included in H5; apply H5; elim H6; intros; apply H8. unfold disc; unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0; apply H0. apply disc_P1. diff --git a/theories/Reals/SeqSeries.v b/theories/Reals/SeqSeries.v index 5140c29c1..6ff3fa8b8 100644 --- a/theories/Reals/SeqSeries.v +++ b/theories/Reals/SeqSeries.v @@ -361,7 +361,7 @@ Proof with trivial. replace (sum_f_R0 (fun k:nat => An k * (Bn k - l)) n) with (sum_f_R0 (fun k:nat => An k * Bn k) n + sum_f_R0 (fun k:nat => An k * - l) n)... - rewrite <- (scal_sum An n (- l)); field... + rewrite <- (scal_sum An n (- l)); field... rewrite <- plus_sum; apply sum_eq; intros; ring... Qed. diff --git a/theories/Sets/Cpo.v b/theories/Sets/Cpo.v index 058eec3da..5ab6f3824 100644 --- a/theories/Sets/Cpo.v +++ b/theories/Sets/Cpo.v @@ -32,9 +32,9 @@ Section Bounds. Variable U : Type. Variable D : PO U. - Let C := Carrier_of U D. + Let C := @Carrier_of U D. - Let R := Rel_of U D. + Let R := @Rel_of U D. Inductive Upper_Bound (B:Ensemble U) (x:U) : Prop := Upper_Bound_definition : @@ -103,6 +103,6 @@ Section Specific_orders. Record Chain : Type := Definition_of_chain {PO_of_chain : PO U; - Chain_cond : Totally_ordered U PO_of_chain (Carrier_of U PO_of_chain)}. + Chain_cond : Totally_ordered U PO_of_chain (@Carrier_of _ PO_of_chain)}. End Specific_orders. diff --git a/theories/Sets/Partial_Order.v b/theories/Sets/Partial_Order.v index 054164da5..8d97e3208 100644 --- a/theories/Sets/Partial_Order.v +++ b/theories/Sets/Partial_Order.v @@ -61,7 +61,7 @@ Section Partial_order_facts. Lemma Strict_Rel_Transitive_with_Rel : forall x y z:U, - Strict_Rel_of U D x y -> Rel_of U D y z -> Strict_Rel_of U D x z. + Strict_Rel_of U D x y -> @Rel_of U D y z -> Strict_Rel_of U D x z. Proof. unfold Strict_Rel_of at 1. red. @@ -77,7 +77,7 @@ Section Partial_order_facts. Lemma Strict_Rel_Transitive_with_Rel_left : forall x y z:U, - Rel_of U D x y -> Strict_Rel_of U D y z -> Strict_Rel_of U D x z. + @Rel_of U D x y -> Strict_Rel_of U D y z -> Strict_Rel_of U D x z. Proof. unfold Strict_Rel_of at 1. red. diff --git a/theories/Sorting/Permutation.v b/theories/Sorting/Permutation.v index acad98e5f..899acfc64 100644 --- a/theories/Sorting/Permutation.v +++ b/theories/Sorting/Permutation.v @@ -16,6 +16,7 @@ Require Import List Setoid Compare_dec Morphisms FinFun. Import ListNotations. (* For notations [] and [a;b;c] *) Set Implicit Arguments. +Set Universe Polymorphism. Section Permutation. diff --git a/theories/Sorting/Sorted.v b/theories/Sorting/Sorted.v index 03952c95a..a89b90238 100644 --- a/theories/Sorting/Sorted.v +++ b/theories/Sorting/Sorted.v @@ -20,6 +20,8 @@ Require Import List Relations Relations_1. +Set Universe Polymorphism. + (** Preambule *) Set Implicit Arguments. diff --git a/theories/Structures/DecidableType.v b/theories/Structures/DecidableType.v index 79e817717..f85222dfb 100644 --- a/theories/Structures/DecidableType.v +++ b/theories/Structures/DecidableType.v @@ -80,13 +80,13 @@ Module KeyDecidableType(D:DecidableType). Lemma InA_eqke_eqk : forall x m, InA eqke x m -> InA eqk x m. Proof. - unfold eqke; induction 1; intuition. + unfold eqke; induction 1; intuition. Qed. Hint Resolve InA_eqke_eqk. Lemma InA_eqk : forall p q m, eqk p q -> InA eqk p m -> InA eqk q m. Proof. - intros; apply InA_eqA with p; auto with *. + intros; apply InA_eqA with p; auto with *. Qed. Definition MapsTo (k:key)(e:elt):= InA eqke (k,e). diff --git a/theories/Structures/Equalities.v b/theories/Structures/Equalities.v index eb5373859..747d03f8a 100644 --- a/theories/Structures/Equalities.v +++ b/theories/Structures/Equalities.v @@ -126,14 +126,14 @@ Module Type DecidableTypeFull' := DecidableTypeFull <+ EqNotation. [EqualityType] and [DecidableType] *) Module BackportEq (E:Eq)(F:IsEq E) <: IsEqOrig E. - Definition eq_refl := @Equivalence_Reflexive _ _ F.eq_equiv. - Definition eq_sym := @Equivalence_Symmetric _ _ F.eq_equiv. - Definition eq_trans := @Equivalence_Transitive _ _ F.eq_equiv. + Definition eq_refl := F.eq_equiv.(@Equivalence_Reflexive _ _). + Definition eq_sym := F.eq_equiv.(@Equivalence_Symmetric _ _). + Definition eq_trans := F.eq_equiv.(@Equivalence_Transitive _ _). End BackportEq. Module UpdateEq (E:Eq)(F:IsEqOrig E) <: IsEq E. Instance eq_equiv : Equivalence E.eq. - Proof. exact (Build_Equivalence _ _ F.eq_refl F.eq_sym F.eq_trans). Qed. + Proof. exact (Build_Equivalence _ F.eq_refl F.eq_sym F.eq_trans). Qed. End UpdateEq. Module Backport_ET (E:EqualityType) <: EqualityTypeBoth diff --git a/theories/Structures/GenericMinMax.v b/theories/Structures/GenericMinMax.v index ffd0649af..a0ee4caaa 100644 --- a/theories/Structures/GenericMinMax.v +++ b/theories/Structures/GenericMinMax.v @@ -440,7 +440,7 @@ Qed. Lemma max_min_antimono f : Proper (eq==>eq) f -> - Proper (le==>inverse le) f -> + Proper (le==>flip le) f -> forall x y, max (f x) (f y) == f (min x y). Proof. intros Eqf Lef x y. @@ -452,7 +452,7 @@ Qed. Lemma min_max_antimono f : Proper (eq==>eq) f -> - Proper (le==>inverse le) f -> + Proper (le==>flip le) f -> forall x y, min (f x) (f y) == f (max x y). Proof. intros Eqf Lef x y. @@ -557,11 +557,11 @@ Module UsualMinMaxLogicalProperties forall x y, min (f x) (f y) = f (min x y). Proof. intros; apply min_mono; auto. congruence. Qed. - Lemma min_max_antimonotone f : Proper (le ==> inverse le) f -> + Lemma min_max_antimonotone f : Proper (le ==> flip le) f -> forall x y, min (f x) (f y) = f (max x y). Proof. intros; apply min_max_antimono; auto. congruence. Qed. - Lemma max_min_antimonotone f : Proper (le ==> inverse le) f -> + Lemma max_min_antimonotone f : Proper (le ==> flip le) f -> forall x y, max (f x) (f y) = f (min x y). Proof. intros; apply max_min_antimono; auto. congruence. Qed. diff --git a/theories/Structures/OrderedType.v b/theories/Structures/OrderedType.v index fa08f9366..fb28e0cfc 100644 --- a/theories/Structures/OrderedType.v +++ b/theories/Structures/OrderedType.v @@ -328,7 +328,7 @@ Module KeyOrderedType(O:OrderedType). Proof. split; eauto. Qed. Global Instance ltk_strorder : StrictOrder ltk. - Proof. constructor; eauto. intros x; apply (irreflexivity (x:=fst x)). Qed. + Proof. constructor; eauto. intros x; apply (irreflexivity (fst x)). Qed. Global Instance ltk_compat : Proper (eqk==>eqk==>iff) ltk. Proof. diff --git a/theories/Structures/OrdersFacts.v b/theories/Structures/OrdersFacts.v index 2e9c0cf56..88fbd8c11 100644 --- a/theories/Structures/OrdersFacts.v +++ b/theories/Structures/OrdersFacts.v @@ -31,7 +31,7 @@ Module Type CompareFacts (Import O:DecStrOrder'). Lemma compare_lt_iff x y : (x ?= y) = Lt <-> x<y. Proof. - case compare_spec; intro H; split; try easy; intro LT; + case compare_spec; intro H; split; try easy; intro LT; contradict LT; rewrite H; apply irreflexivity. Qed. @@ -90,7 +90,7 @@ Module Type OrderedTypeFullFacts (Import O:OrderedTypeFull'). Instance le_order : PartialOrder eq le. Proof. compute; iorder. Qed. - Instance le_antisym : Antisymmetric _ eq le. + Instance le_antisym : Antisymmetric eq le. Proof. apply partial_order_antisym; auto with *. Qed. Lemma le_not_gt_iff : forall x y, x<=y <-> ~y<x. diff --git a/theories/Structures/OrdersTac.v b/theories/Structures/OrdersTac.v index 68ffc379d..475a25a41 100644 --- a/theories/Structures/OrdersTac.v +++ b/theories/Structures/OrdersTac.v @@ -29,7 +29,7 @@ Set Implicit Arguments. [le x y -> le y z -> le x z]. *) -Inductive ord := OEQ | OLT | OLE. +Inductive ord : Set := OEQ | OLT | OLE. Definition trans_ord o o' := match o, o' with | OEQ, _ => o' @@ -70,7 +70,7 @@ Lemma le_refl : forall x, x<=x. Proof. intros; rewrite P.le_lteq; right; reflexivity. Qed. Lemma lt_irrefl : forall x, ~ x<x. -Proof. intros; apply StrictOrder_Irreflexive. Qed. +Proof. intros. apply StrictOrder_Irreflexive. Qed. (** Symmetry rules *) @@ -100,8 +100,9 @@ Local Notation "#" := interp_ord. Lemma trans : forall o o' x y z, #o x y -> #o' y z -> #(o+o') x z. Proof. -destruct o, o'; simpl; intros x y z; rewrite ?P.le_lteq; intuition; - subst_eqns; eauto using (StrictOrder_Transitive x y z) with *. +destruct o, o'; simpl; intros x y z; +rewrite ?P.le_lteq; intuition auto; +subst_eqns; eauto using (StrictOrder_Transitive x y z) with *. Qed. Definition eq_trans x y z : x==y -> y==z -> x==z := @trans OEQ OEQ x y z. diff --git a/theories/Vectors/Fin.v b/theories/Vectors/Fin.v index f57726bea..1c4c16cc1 100644 --- a/theories/Vectors/Fin.v +++ b/theories/Vectors/Fin.v @@ -24,7 +24,7 @@ Inductive t : nat -> Set := Section SCHEMES. Definition case0 P (p: t 0): P p := - match p with | F1 | FS _ => fun devil => False_rect (@ID) devil (* subterm !!! *) end. + match p with | F1 | FS _ => fun devil => False_rect (@IDProp) devil (* subterm !!! *) end. Definition caseS (P: forall {n}, t (S n) -> Type) (P1: forall n, @P n F1) (PS : forall {n} (p: t n), P (FS p)) diff --git a/theories/Vectors/VectorDef.v b/theories/Vectors/VectorDef.v index 8f672deda..f12aa0b87 100644 --- a/theories/Vectors/VectorDef.v +++ b/theories/Vectors/VectorDef.v @@ -21,6 +21,8 @@ Require Vectors.Fin. Import EqNotations. Local Open Scope nat_scope. +Set Universe Polymorphism. + (** A vector is a list of size n whose elements belong to a set A. *) @@ -43,10 +45,10 @@ Definition rectS {A} (P:forall {n}, t A (S n) -> Type) |@cons _ a 0 v => match v with |nil _ => bas a - |_ => fun devil => False_rect (@ID) devil (* subterm !!! *) + |_ => fun devil => False_ind (@IDProp) devil (* subterm !!! *) end |@cons _ a (S nn') v => rect a v (rectS_fix v) - |_ => fun devil => False_rect (@ID) devil (* subterm !!! *) + |_ => fun devil => False_ind (@IDProp) devil (* subterm !!! *) end. (** An induction scheme for 2 vectors of same length *) @@ -60,13 +62,13 @@ match v1 as v1' in t _ n1 |[] => fun v2 => match v2 with |[] => bas - |_ => fun devil => False_rect (@ID) devil (* subterm !!! *) + |_ => fun devil => False_ind (@IDProp) devil (* subterm !!! *) end |h1 :: t1 => fun v2 => match v2 with |h2 :: t2 => fun t1' => rect (rect2_fix t1' t2) h1 h2 - |_ => fun devil => False_rect (@ID) devil (* subterm !!! *) + |_ => fun devil => False_ind (@IDProp) devil (* subterm !!! *) end t1 end. @@ -74,7 +76,7 @@ end. Definition case0 {A} (P:t A 0 -> Type) (H:P (nil A)) v:P v := match v with |[] => H - |_ => fun devil => False_rect (@ID) devil (* subterm !!! *) + |_ => fun devil => False_ind (@IDProp) devil (* subterm !!! *) end. (** A vector of length [S _] is [cons] *) @@ -82,7 +84,7 @@ Definition caseS {A} (P : forall {n}, t A (S n) -> Type) (H : forall h {n} t, @P n (h :: t)) {n} (v: t A (S n)) : P v := match v with |h :: t => H h t - |_ => fun devil => False_rect (@ID) devil (* subterm !!! *) + |_ => fun devil => False_ind (@IDProp) devil (* subterm !!! *) end. End SCHEMES. @@ -245,11 +247,11 @@ fix fold_left2_fix (a : A) {n} (v : t B n) : t C n -> A := match v in t _ n0 return t C n0 -> A with |[] => fun w => match w with |[] => a - |_ => fun devil => False_rect (@ID) devil (* subterm !!! *) + |_ => fun devil => False_ind (@IDProp) devil (* subterm !!! *) end |@cons _ vh vn vt => fun w => match w with |wh :: wt => fun vt' => fold_left2_fix (f a vh wh) vt' wt - |_ => fun devil => False_rect (@ID) devil (* subterm !!! *) + |_ => fun devil => False_ind (@IDProp) devil (* subterm !!! *) end vt end. diff --git a/theories/Vectors/VectorSpec.v b/theories/Vectors/VectorSpec.v index ed2b56d1f..3e8c1175f 100644 --- a/theories/Vectors/VectorSpec.v +++ b/theories/Vectors/VectorSpec.v @@ -105,7 +105,7 @@ Proof. assert (forall n h (v: t B n) a, fold_left f (f a h) v = f (fold_left f a v) h). induction v0. now simpl. - intros; simpl. rewrite<- IHv0. now f_equal. + intros; simpl. rewrite<- IHv0, assoc. now f_equal. induction v. reflexivity. simpl. intros; now rewrite<- (IHv). diff --git a/theories/Wellfounded/Lexicographic_Exponentiation.v b/theories/Wellfounded/Lexicographic_Exponentiation.v index 24f5d308a..28288c0cb 100644 --- a/theories/Wellfounded/Lexicographic_Exponentiation.v +++ b/theories/Wellfounded/Lexicographic_Exponentiation.v @@ -130,7 +130,7 @@ Section Wf_Lexicographic_Exponentiation. match goal with [ |- clos_refl_trans ?A ?R ?x ?y ] => cut (clos_refl A R x y) end. intros; inversion H8; subst; [apply rt_step|apply rt_refl]; assumption. generalize H1. - rewrite H4; intro. + setoid_rewrite H4; intro. generalize (app_inj_tail _ _ _ _ H8); simple induction 1. intros. @@ -182,7 +182,8 @@ Section Wf_Lexicographic_Exponentiation. Descl x0 /\ Descl y0). intro. - generalize (app_nil_end x1); simple induction 1; simple induction 1. + generalize (app_nil_end x1). + simple induction 1; simple induction 1. split. apply d_conc; auto with sets. apply d_nil. diff --git a/theories/ZArith/Wf_Z.v b/theories/ZArith/Wf_Z.v index 3935e1248..f1bfb027f 100644 --- a/theories/ZArith/Wf_Z.v +++ b/theories/ZArith/Wf_Z.v @@ -151,9 +151,7 @@ Section Efficient_Rec. forall P:Z -> Prop, (forall x:Z, (forall y:Z, 0 <= y < x -> P y) -> 0 <= x -> P x) -> forall x:Z, 0 <= x -> P x. - Proof. - exact Zlt_0_rec. - Qed. + Proof. intros; now apply Zlt_0_rec. Qed. (** Obsolete version of [Z.lt] induction principle on non-negative numbers *) @@ -170,7 +168,7 @@ Section Efficient_Rec. (forall x:Z, (forall y:Z, 0 <= y < x -> P y) -> P x) -> forall x:Z, 0 <= x -> P x. Proof. - exact Z_lt_rec. + intros; now apply Z_lt_rec. Qed. (** An even more general induction principle using [Z.lt]. *) @@ -196,7 +194,7 @@ Section Efficient_Rec. (forall x:Z, (forall y:Z, z <= y < x -> P y) -> z <= x -> P x) -> forall x:Z, z <= x -> P x. Proof. - exact Zlt_lower_bound_rec. + intros; now apply Zlt_lower_bound_rec with z. Qed. End Efficient_Rec. diff --git a/theories/ZArith/Zcomplements.v b/theories/ZArith/Zcomplements.v index b4163ef99..a5e710504 100644 --- a/theories/ZArith/Zcomplements.v +++ b/theories/ZArith/Zcomplements.v @@ -53,10 +53,11 @@ Theorem Z_lt_abs_rec : forall n:Z, P n. Proof. intros P HP p. - set (Q := fun z => 0 <= z -> P z * P (- z)) in *. - cut (Q (Z.abs p)); [ intros | apply (Z_lt_rec Q); auto with zarith ]. - elim (Zabs_dec p); intro eq; rewrite eq; elim H; auto with zarith. - unfold Q; clear Q; intros. + set (Q := fun z => 0 <= z -> P z * P (- z)). + cut (Q (Z.abs p)); [ intros H | apply (Z_lt_rec Q); auto with zarith ]. + elim (Zabs_dec p); intro eq; rewrite eq; + elim H; auto with zarith. + intros x H; subst Q. split; apply HP. rewrite Z.abs_eq; auto; intros. elim (H (Z.abs m)); intros; auto with zarith. diff --git a/tools/coqc.ml b/tools/coqc.ml index e835091ea..d7f1bebdf 100644 --- a/tools/coqc.ml +++ b/tools/coqc.ml @@ -120,7 +120,7 @@ let parse_args () = |"-dont-load-proofs"|"-load-proofs"|"-force-load-proofs" |"-impredicative-set"|"-vm"|"-no-native-compiler" |"-verbose-compat-notations"|"-no-compat-notations" - |"-quick" + |"-indices-matter"|"-quick" as o) :: rem -> parse (cfiles,o::args) rem @@ -158,8 +158,6 @@ let parse_args () = extra_arg_needed := false; parse (cfiles, List.rev nodash @ s :: o :: args) rem -(* Anything else is interpreted as a file *) - | f :: rem -> if Sys.file_exists f then parse (f::cfiles,args) rem diff --git a/toplevel/auto_ind_decl.ml b/toplevel/auto_ind_decl.ml index 04d0f3de4..1a1a4dfe7 100644 --- a/toplevel/auto_ind_decl.ml +++ b/toplevel/auto_ind_decl.ml @@ -25,6 +25,8 @@ open Ind_tables open Misctypes open Proofview.Notations +let out_punivs = Univ.out_punivs + (**********************************************************************) (* Generic synthesis of boolean equality *) @@ -55,6 +57,8 @@ exception NonSingletonProp of inductive let dl = Loc.ghost +let constr_of_global g = lazy (Universes.constr_of_global g) + (* Some pre declaration of constant we are going to use *) let bb = constr_of_global Coqlib.glob_bool @@ -93,7 +97,7 @@ let destruct_on c = None (None,None) None (* reconstruct the inductive with the correct deBruijn indexes *) -let mkFullInd ind n = +let mkFullInd (ind,u) n = let mib = Global.lookup_mind (fst ind) in let nparams = mib.mind_nparams in let nparrec = mib.mind_nparams_rec in @@ -101,12 +105,12 @@ let mkFullInd ind n = let lnonparrec,lnamesparrec = context_chop (nparams-nparrec) mib.mind_params_ctxt in if nparrec > 0 - then mkApp (mkInd ind, + then mkApp (mkIndU (ind,u), Array.of_list(extended_rel_list (nparrec+n) lnamesparrec)) - else mkInd ind + else mkIndU (ind,u) let check_bool_is_defined () = - try let _ = Global.type_of_global Coqlib.glob_bool in () + try let _ = Global.type_of_global_unsafe Coqlib.glob_bool in () with e when Errors.noncritical e -> raise (UndefinedCst "bool") let beq_scheme_kind_aux = ref (fun _ -> failwith "Undefined") @@ -142,7 +146,7 @@ let build_beq_scheme kn = let eqs_typ = List.map (fun aa -> let a = lift !lift_cnt aa in incr lift_cnt; - myArrow a (myArrow a bb) + myArrow a (myArrow a (Lazy.force bb)) ) ext_rel_list in let eq_input = List.fold_left2 @@ -159,11 +163,12 @@ let build_beq_scheme kn = t a) eq_input lnamesparrec in let make_one_eq cur = - let ind = kn,cur in + let u = Univ.Instance.empty in + let ind = (kn,cur),u (* FIXME *) in (* current inductive we are working on *) - let cur_packet = mib.mind_packets.(snd ind) in + let cur_packet = mib.mind_packets.(snd (fst ind)) in (* Inductive toto : [rettyp] := *) - let rettyp = Inductive.type_of_inductive env (mib,cur_packet) in + let rettyp = Inductive.type_of_inductive env ((mib,cur_packet),u) in (* split rettyp in a list without the non rec params and the last -> e.g. Inductive vec (A:Set) : nat -> Set := ... will do [nat] *) let rettyp_l = quick_chop nparrec (deconstruct_type rettyp) in @@ -182,7 +187,7 @@ let build_beq_scheme kn = | Var x -> mkVar (id_of_string ("eq_"^(string_of_id x))), Declareops.no_seff | Cast (x,_,_) -> aux (applist (x,a)) | App _ -> assert false - | Ind (kn',i as ind') -> + | Ind ((kn',i as ind'),u) (*FIXME: universes *) -> if eq_mind kn kn' then mkRel(eqA-nlist-i+nb_ind-1), Declareops.no_seff else begin try @@ -200,16 +205,17 @@ let build_beq_scheme kn = (Array.of_list (List.map (fun x -> lift lifti x) a)) eqa in if Int.equal (Array.length args) 0 then eq, eff else mkApp (eq, args), eff - with Not_found -> raise(EqNotFound (ind',ind)) + with Not_found -> raise(EqNotFound (ind', fst ind)) end | Sort _ -> raise InductiveWithSort | Prod _ -> raise InductiveWithProduct | Lambda _-> raise (EqUnknown "Lambda") | LetIn _ -> raise (EqUnknown "LetIn") | Const kn -> - (match Environ.constant_opt_value env kn with - | None -> raise (ParameterWithoutEquality kn) + (match Environ.constant_opt_value_in env kn with + | None -> raise (ParameterWithoutEquality (fst kn)) | Some c -> aux (applist (c,a))) + | Proj _ -> raise (EqUnknown "Proj") | Construct _ -> raise (EqUnknown "Construct") | Case _ -> raise (EqUnknown "Case") | CoFix _ -> raise (EqUnknown "CoFix") @@ -224,28 +230,28 @@ let build_beq_scheme kn = List.fold_left (fun a b -> mkLambda(Anonymous,b,a)) (mkLambda (Anonymous, mkFullInd ind (n+3+(List.length rettyp_l)+nb_ind-1), - bb)) + (Lazy.force bb))) (List.rev rettyp_l) in (* make_one_eq *) (* do the [| C1 ... => match Y with ... end ... Cn => match Y with ... end |] part *) - let ci = make_case_info env ind MatchStyle in + let ci = make_case_info env (fst ind) MatchStyle in let constrs n = get_constructors env (make_ind_family (ind, extended_rel_list (n+nb_ind-1) mib.mind_params_ctxt)) in let constrsi = constrs (3+nparrec) in let n = Array.length constrsi in - let ar = Array.make n ff in - let eff = ref Declareops.no_seff in + let ar = Array.make n (Lazy.force ff) in + let eff = ref Declareops.no_seff in for i=0 to n-1 do let nb_cstr_args = List.length constrsi.(i).cs_args in - let ar2 = Array.make n ff in + let ar2 = Array.make n (Lazy.force ff) in let constrsj = constrs (3+nparrec+nb_cstr_args) in for j=0 to n-1 do if Int.equal i j then ar2.(j) <- let cc = (match nb_cstr_args with - | 0 -> tt - | _ -> let eqs = Array.make nb_cstr_args tt in + | 0 -> Lazy.force tt + | _ -> let eqs = Array.make nb_cstr_args (Lazy.force tt) in for ndx = 0 to nb_cstr_args-1 do let _,_,cc = List.nth constrsi.(i).cs_args ndx in let eqA, eff' = compute_A_equality rel_list @@ -270,7 +276,7 @@ let build_beq_scheme kn = (constrsj.(j).cs_args) ) else ar2.(j) <- (List.fold_left (fun a (p,q,r) -> - mkLambda (p,r,a)) ff (constrsj.(j).cs_args) ) + mkLambda (p,r,a)) (Lazy.force ff) (constrsj.(j).cs_args) ) done; ar.(i) <- (List.fold_left (fun a (p,q,r) -> mkLambda (p,r,a)) @@ -287,21 +293,23 @@ let build_beq_scheme kn = types = Array.make nb_ind mkSet and cores = Array.make nb_ind mkSet in let eff = ref Declareops.no_seff in + let u = Univ.Instance.empty in for i=0 to (nb_ind-1) do names.(i) <- Name (Id.of_string (rec_name i)); - types.(i) <- mkArrow (mkFullInd (kn,i) 0) - (mkArrow (mkFullInd (kn,i) 1) bb); + types.(i) <- mkArrow (mkFullInd ((kn,i),u) 0) + (mkArrow (mkFullInd ((kn,i),u) 1) (Lazy.force bb)); let c, eff' = make_one_eq i in cores.(i) <- c; eff := Declareops.union_side_effects eff' !eff done; - Array.init nb_ind (fun i -> + (Array.init nb_ind (fun i -> let kelim = Inductive.elim_sorts (mib,mib.mind_packets.(i)) in - if not (Sorts.List.mem InSet kelim) then - raise (NonSingletonProp (kn,i)); - let fix = mkFix (((Array.make nb_ind 0),i),(names,types,cores)) in - create_input fix), - !eff + if not (Sorts.List.mem InSet kelim) then + raise (NonSingletonProp (kn,i)); + let fix = mkFix (((Array.make nb_ind 0),i),(names,types,cores)) in + create_input fix), + Evd.empty_evar_universe_context (* FIXME *)), + !eff let beq_scheme_kind = declare_mutual_scheme_object "_beq" build_beq_scheme @@ -343,8 +351,8 @@ let do_replace_lb lb_scheme_key aavoid narg p q = (* if this happen then the args have to be already declared as a Parameter*) ( - let mp,dir,lbl = repr_con (destConst v) in - mkConst (make_con mp dir (Label.make ( + let mp,dir,lbl = repr_con (fst (destConst v)) in + mkConst (make_con mp dir (mk_label ( if Int.equal offset 1 then ("eq_"^(Label.to_string lbl)) else ((Label.to_string lbl)^"_lb") ))) @@ -355,7 +363,7 @@ let do_replace_lb lb_scheme_key aavoid narg p q = let u,v = destruct_ind type_of_pq in let lb_type_of_p = try - let c, eff = find_scheme lb_scheme_key u in + let c, eff = find_scheme lb_scheme_key (out_punivs u) (*FIXME*) in Proofview.tclUNIT (mkConst c, eff) with Not_found -> (* spiwack: the format of this error message should probably @@ -383,7 +391,7 @@ let do_replace_lb lb_scheme_key aavoid narg p q = end (* used in the bool -> leib side *) -let do_replace_bl bl_scheme_key ind aavoid narg lft rgt = +let do_replace_bl bl_scheme_key (ind,u as indu) aavoid narg lft rgt = let avoid = Array.of_list aavoid in let do_arg v offset = try @@ -400,8 +408,8 @@ let do_replace_bl bl_scheme_key ind aavoid narg lft rgt = (* if this happen then the args have to be already declared as a Parameter*) ( - let mp,dir,lbl = repr_con (destConst v) in - mkConst (make_con mp dir (Label.make ( + let mp,dir,lbl = repr_con (fst (destConst v)) in + mkConst (make_con mp dir (mk_label ( if Int.equal offset 1 then ("eq_"^(Label.to_string lbl)) else ((Label.to_string lbl)^"_bl") ))) @@ -417,13 +425,13 @@ let do_replace_bl bl_scheme_key ind aavoid narg lft rgt = else ( let u,v = try destruct_ind tt1 (* trick so that the good sequence is returned*) - with e when Errors.noncritical e -> ind,[||] - in if eq_ind u ind + with e when Errors.noncritical e -> indu,[||] + in if eq_ind (fst u) ind then Tacticals.New.tclTHENLIST [Equality.replace t1 t2; Auto.default_auto ; aux q1 q2 ] else ( let bl_t1, eff = try - let c, eff = find_scheme bl_scheme_key u in + let c, eff = find_scheme bl_scheme_key (out_punivs u) (*FIXME*) in mkConst c, eff with Not_found -> (* spiwack: the format of this error message should probably @@ -462,15 +470,15 @@ let do_replace_bl bl_scheme_key ind aavoid narg lft rgt = begin try Proofview.tclUNIT (destApp rgt) with DestKO -> Proofview.tclZERO (UserError ("" , str"replace failed.")) end >>= fun (ind2,ca2) -> - begin try Proofview.tclUNIT (destInd ind1) + begin try Proofview.tclUNIT (out_punivs (destInd ind1)) with DestKO -> - begin try Proofview.tclUNIT (fst (destConstruct ind1)) + begin try Proofview.tclUNIT (fst (fst (destConstruct ind1))) with DestKO -> Proofview.tclZERO (UserError ("" , str"The expected type is an inductive one.")) end end >>= fun (sp1,i1) -> - begin try Proofview.tclUNIT (destInd ind2) + begin try Proofview.tclUNIT (out_punivs (destInd ind2)) with DestKO -> - begin try Proofview.tclUNIT (fst (destConstruct ind2)) + begin try Proofview.tclUNIT (fst (fst (destConstruct ind2))) with DestKO -> Proofview.tclZERO (UserError ("" , str"The expected type is an inductive one.")) end end >>= fun (sp2,i2) -> @@ -517,15 +525,15 @@ let compute_bl_goal ind lnamesparrec nparrec = mkNamedProd x (mkVar s) ( mkNamedProd y (mkVar s) ( mkArrow - ( mkApp(eq,[|bb;mkApp(mkVar seq,[|mkVar x;mkVar y|]);tt|])) - ( mkApp(eq,[|mkVar s;mkVar x;mkVar y|])) + ( mkApp(Lazy.force eq,[|(Lazy.force bb);mkApp(mkVar seq,[|mkVar x;mkVar y|]);(Lazy.force tt)|])) + ( mkApp(Lazy.force eq,[|mkVar s;mkVar x;mkVar y|])) )) ) list_id in let bl_input = List.fold_left2 ( fun a (s,_,sbl,_) b -> mkNamedProd sbl b a ) c (List.rev list_id) (List.rev bl_typ) in let eqs_typ = List.map (fun (s,_,_,_) -> - mkProd(Anonymous,mkVar s,mkProd(Anonymous,mkVar s,bb)) + mkProd(Anonymous,mkVar s,mkProd(Anonymous,mkVar s,(Lazy.force bb))) ) list_id in let eq_input = List.fold_left2 ( fun a (s,seq,_,_) b -> mkNamedProd seq b a @@ -536,12 +544,13 @@ let compute_bl_goal ind lnamesparrec nparrec = in let n = Id.of_string "x" and m = Id.of_string "y" in + let u = Univ.Instance.empty in create_input ( - mkNamedProd n (mkFullInd ind nparrec) ( - mkNamedProd m (mkFullInd ind (nparrec+1)) ( + mkNamedProd n (mkFullInd (ind,u) nparrec) ( + mkNamedProd m (mkFullInd (ind,u) (nparrec+1)) ( mkArrow - (mkApp(eq,[|bb;mkApp(eqI,[|mkVar n;mkVar m|]);tt|])) - (mkApp(eq,[|mkFullInd ind (nparrec+3);mkVar n;mkVar m|])) + (mkApp(Lazy.force eq,[|(Lazy.force bb);mkApp(eqI,[|mkVar n;mkVar m|]);(Lazy.force tt)|])) + (mkApp(Lazy.force eq,[|mkFullInd (ind,u) (nparrec+3);mkVar n;mkVar m|])) ))), eff let compute_bl_tact bl_scheme_key ind lnamesparrec nparrec = @@ -600,7 +609,7 @@ repeat ( apply andb_prop in z;let z1:= fresh "Z" in destruct z as [z1 z]). match (kind_of_term gl) with | App (c,ca) -> ( match (kind_of_term c) with - | Ind indeq -> + | Ind (indeq, u) -> if eq_gr (IndRef indeq) Coqlib.glob_eq then Tacticals.New.tclTHEN @@ -629,12 +638,14 @@ let make_bl_scheme mind = let ind = (mind,0) in let nparams = mib.mind_nparams in let nparrec = mib.mind_nparams_rec in - let lnonparrec,lnamesparrec = + let lnonparrec,lnamesparrec = (* TODO subst *) context_chop (nparams-nparrec) mib.mind_params_ctxt in let bl_goal, eff = compute_bl_goal ind lnamesparrec nparrec in - [|fst (Pfedit.build_by_tactic (Global.env()) bl_goal - (compute_bl_tact (!bl_scheme_kind_aux()) ind lnamesparrec nparrec))|], - eff + let ctx = Univ.ContextSet.empty (*FIXME univs *) in + let (ans, _, _) = Pfedit.build_by_tactic (Global.env()) (bl_goal, ctx) + (compute_bl_tact (!bl_scheme_kind_aux()) (ind, Univ.Instance.empty) lnamesparrec nparrec) + in + ([|ans|], Evd.empty_evar_universe_context), eff let bl_scheme_kind = declare_mutual_scheme_object "_dec_bl" make_bl_scheme @@ -645,6 +656,7 @@ let _ = bl_scheme_kind_aux := fun () -> bl_scheme_kind let compute_lb_goal ind lnamesparrec nparrec = let list_id = list_id lnamesparrec in + let eq = Lazy.force eq and tt = Lazy.force tt and bb = Lazy.force bb in let eqI, eff = eqI ind lnamesparrec in let create_input c = let x = Id.of_string "x" and @@ -672,11 +684,12 @@ let compute_lb_goal ind lnamesparrec nparrec = in let n = Id.of_string "x" and m = Id.of_string "y" in + let u = Univ.Instance.empty in create_input ( - mkNamedProd n (mkFullInd ind nparrec) ( - mkNamedProd m (mkFullInd ind (nparrec+1)) ( + mkNamedProd n (mkFullInd (ind,u) nparrec) ( + mkNamedProd m (mkFullInd (ind,u) (nparrec+1)) ( mkArrow - (mkApp(eq,[|mkFullInd ind (nparrec+2);mkVar n;mkVar m|])) + (mkApp(eq,[|mkFullInd (ind,u) (nparrec+2);mkVar n;mkVar m|])) (mkApp(eq,[|bb;mkApp(eqI,[|mkVar n;mkVar m|]);tt|])) ))), eff @@ -750,9 +763,10 @@ let make_lb_scheme mind = let lnonparrec,lnamesparrec = context_chop (nparams-nparrec) mib.mind_params_ctxt in let lb_goal, eff = compute_lb_goal ind lnamesparrec nparrec in - [|fst (Pfedit.build_by_tactic (Global.env()) lb_goal - (compute_lb_tact (!lb_scheme_kind_aux()) ind lnamesparrec nparrec))|], - eff + let (ans, _, _) = Pfedit.build_by_tactic (Global.env()) (lb_goal,Univ.ContextSet.empty) + (compute_lb_tact (!lb_scheme_kind_aux()) ind lnamesparrec nparrec) + in + ([|ans|], Evd.empty_evar_universe_context (* FIXME *)), eff let lb_scheme_kind = declare_mutual_scheme_object "_dec_lb" make_lb_scheme @@ -768,6 +782,7 @@ let check_not_is_defined () = (* {n=m}+{n<>m} part *) let compute_dec_goal ind lnamesparrec nparrec = check_not_is_defined (); + let eq = Lazy.force eq and tt = Lazy.force tt and bb = Lazy.force bb in let list_id = list_id lnamesparrec in let create_input c = let x = Id.of_string "x" and @@ -818,6 +833,8 @@ let compute_dec_goal ind lnamesparrec nparrec = ) let compute_dec_tact ind lnamesparrec nparrec = + let eq = Lazy.force eq and tt = Lazy.force tt + and ff = Lazy.force ff and bb = Lazy.force bb in let list_id = list_id lnamesparrec in let eqI, eff = eqI ind lnamesparrec in let avoid = ref [] in @@ -915,11 +932,14 @@ let make_eq_decidability mind = let ind = (mind,0) in let nparams = mib.mind_nparams in let nparrec = mib.mind_nparams_rec in + let u = Univ.Instance.empty in let lnonparrec,lnamesparrec = context_chop (nparams-nparrec) mib.mind_params_ctxt in - [|fst (Pfedit.build_by_tactic (Global.env()) - (compute_dec_goal ind lnamesparrec nparrec) - (compute_dec_tact ind lnamesparrec nparrec))|], Declareops.no_seff + let (ans, _, _) = Pfedit.build_by_tactic (Global.env()) + (compute_dec_goal (ind,u) lnamesparrec nparrec, Univ.ContextSet.empty) + (compute_dec_tact ind lnamesparrec nparrec) + in + ([|ans|], Evd.empty_evar_universe_context (* FIXME *)), Declareops.no_seff let eq_dec_scheme_kind = declare_mutual_scheme_object "_eq_dec" make_eq_decidability diff --git a/toplevel/auto_ind_decl.mli b/toplevel/auto_ind_decl.mli index 6509a7d3b..21362c973 100644 --- a/toplevel/auto_ind_decl.mli +++ b/toplevel/auto_ind_decl.mli @@ -26,17 +26,16 @@ exception ParameterWithoutEquality of constant exception NonSingletonProp of inductive val beq_scheme_kind : mutual scheme_kind -val build_beq_scheme : mutual_inductive -> constr array * Declareops.side_effects +val build_beq_scheme : mutual_scheme_object_function (** {6 Build equivalence between boolean equality and Leibniz equality } *) val lb_scheme_kind : mutual scheme_kind -val make_lb_scheme : mutual_inductive -> constr array * Declareops.side_effects - +val make_lb_scheme : mutual_scheme_object_function val bl_scheme_kind : mutual scheme_kind -val make_bl_scheme : mutual_inductive -> constr array * Declareops.side_effects +val make_bl_scheme : mutual_scheme_object_function (** {6 Build decidability of equality } *) val eq_dec_scheme_kind : mutual scheme_kind -val make_eq_decidability : mutual_inductive -> constr array * Declareops.side_effects +val make_eq_decidability : mutual_scheme_object_function diff --git a/toplevel/cerrors.ml b/toplevel/cerrors.ml index 0186b08ac..f5cc2015b 100644 --- a/toplevel/cerrors.ml +++ b/toplevel/cerrors.ml @@ -58,22 +58,10 @@ let wrap_vernac_error exn strm = Exninfo.copy exn e let process_vernac_interp_error exn = match exn with - | Univ.UniverseInconsistency (o,u,v,p) -> - let pr_rel r = - match r with - Univ.Eq -> str"=" | Univ.Lt -> str"<" | Univ.Le -> str"<=" in - let reason = match p with - [] -> mt() - | _::_ -> - str " because" ++ spc() ++ Univ.pr_uni v ++ - prlist (fun (r,v) -> spc() ++ pr_rel r ++ str" " ++ Univ.pr_uni v) - p ++ - (if Univ.Universe.equal (snd (List.last p)) u then mt() else - (spc() ++ str "= " ++ Univ.pr_uni u)) in + | Univ.UniverseInconsistency i -> let msg = if !Constrextern.print_universes then - spc() ++ str "(cannot enforce" ++ spc() ++ Univ.pr_uni u ++ spc() ++ - pr_rel o ++ spc() ++ Univ.pr_uni v ++ reason ++ str")" + str "." ++ spc() ++ Univ.explain_universe_inconsistency i else mt() in wrap_vernac_error exn (str "Universe inconsistency" ++ msg ++ str ".") diff --git a/toplevel/class.ml b/toplevel/class.ml index a9cb6ca5e..d54efb632 100644 --- a/toplevel/class.ml +++ b/toplevel/class.ml @@ -66,7 +66,7 @@ let explain_coercion_error g = function (* Verifications pour l'ajout d'une classe *) let check_reference_arity ref = - if not (Reductionops.is_arity (Global.env()) Evd.empty (Global.type_of_global ref)) then + if not (Reductionops.is_arity (Global.env()) Evd.empty (Global.type_of_global_unsafe ref)) then raise (CoercionError (NotAClass ref)) let check_arity = function @@ -118,19 +118,19 @@ l'indice de la classe source dans la liste lp let get_source lp source = match source with | None -> - let (cl1,lv1) = + let (cl1,u1,lv1) = match lp with | [] -> raise Not_found | t1::_ -> find_class_type Evd.empty t1 in - (cl1,lv1,1) + (cl1,u1,lv1,1) | Some cl -> let rec aux = function | [] -> raise Not_found | t1::lt -> try - let cl1,lv1 = find_class_type Evd.empty t1 in - if cl_typ_eq cl cl1 then cl1,lv1,(List.length lt+1) + let cl1,u1,lv1 = find_class_type Evd.empty t1 in + if cl_typ_eq cl cl1 then cl1,u1,lv1,(List.length lt+1) else raise Not_found with Not_found -> aux lt in aux (List.rev lp) @@ -139,7 +139,7 @@ let get_target t ind = if (ind > 1) then CL_FUN else - fst (find_class_type Evd.empty t) + pi1 (find_class_type Evd.empty t) let prods_of t = let rec aux acc d = match kind_of_term d with @@ -177,12 +177,12 @@ let error_not_transparent source = errorlabstrm "build_id_coercion" (pr_class source ++ str " must be a transparent constant.") -let build_id_coercion idf_opt source = +let build_id_coercion idf_opt source poly = let env = Global.env () in - let vs = match source with - | CL_CONST sp -> mkConst sp + let vs, ctx = match source with + | CL_CONST sp -> Universes.fresh_global_instance env (ConstRef sp) | _ -> error_not_transparent source in - let c = match constant_opt_value env (destConst vs) with + let c = match constant_opt_value_in env (destConst vs) with | Some c -> c | None -> error_not_transparent source in let lams,t = decompose_lam_assum c in @@ -211,7 +211,7 @@ let build_id_coercion idf_opt source = match idf_opt with | Some idf -> idf | None -> - let cl,_ = find_class_type Evd.empty t in + let cl,u,_ = find_class_type Evd.empty t in Id.of_string ("Id_"^(ident_key_of_class source)^"_"^ (ident_key_of_class cl)) in @@ -221,6 +221,9 @@ let build_id_coercion idf_opt source = (mkCast (val_f, DEFAULTcast, typ_f),Declareops.no_seff); const_entry_secctx = None; const_entry_type = Some typ_f; + const_entry_proj = None; + const_entry_polymorphic = poly; + const_entry_universes = Univ.ContextSet.to_context ctx; const_entry_opaque = false; const_entry_inline_code = true; const_entry_feedback = None; @@ -244,14 +247,14 @@ booleen "coercion identite'?" lorque source est None alors target est None aussi. *) -let add_new_coercion_core coef stre source target isid = +let add_new_coercion_core coef stre poly source target isid = check_source source; - let t = Global.type_of_global coef in + let t = Global.type_of_global_unsafe coef in if coercion_exists coef then raise (CoercionError AlreadyExists); let tg,lp = prods_of t in let llp = List.length lp in if Int.equal llp 0 then raise (CoercionError NotAFunction); - let (cls,lvs,ind) = + let (cls,us,lvs,ind) = try get_source lp source with Not_found -> @@ -275,44 +278,45 @@ let add_new_coercion_core coef stre source target isid = in declare_coercion coef ~local ~isid ~src:cls ~target:clt ~params:(List.length lvs) -let try_add_new_coercion_core ref ~local c d e = - try add_new_coercion_core ref (loc_of_bool local) c d e + +let try_add_new_coercion_core ref ~local c d e f = + try add_new_coercion_core ref (loc_of_bool local) c d e f with CoercionError e -> errorlabstrm "try_add_new_coercion_core" (explain_coercion_error ref e ++ str ".") -let try_add_new_coercion ref ~local = - try_add_new_coercion_core ref ~local None None false +let try_add_new_coercion ref ~local poly = + try_add_new_coercion_core ref ~local poly None None false -let try_add_new_coercion_subclass cl ~local = - let coe_ref = build_id_coercion None cl in - try_add_new_coercion_core coe_ref ~local (Some cl) None true +let try_add_new_coercion_subclass cl ~local poly = + let coe_ref = build_id_coercion None cl poly in + try_add_new_coercion_core coe_ref ~local poly (Some cl) None true -let try_add_new_coercion_with_target ref ~local ~source ~target = - try_add_new_coercion_core ref ~local (Some source) (Some target) false +let try_add_new_coercion_with_target ref ~local poly ~source ~target = + try_add_new_coercion_core ref ~local poly (Some source) (Some target) false -let try_add_new_identity_coercion id ~local ~source ~target = - let ref = build_id_coercion (Some id) source in - try_add_new_coercion_core ref ~local (Some source) (Some target) true +let try_add_new_identity_coercion id ~local poly ~source ~target = + let ref = build_id_coercion (Some id) source poly in + try_add_new_coercion_core ref ~local poly (Some source) (Some target) true -let try_add_new_coercion_with_source ref ~local ~source = - try_add_new_coercion_core ref ~local (Some source) None false +let try_add_new_coercion_with_source ref ~local poly ~source = + try_add_new_coercion_core ref ~local poly (Some source) None false -let add_coercion_hook local ref = +let add_coercion_hook poly local ref = let stre = match local with | Local -> true | Global -> false | Discharge -> assert false in - let () = try_add_new_coercion ref stre in + let () = try_add_new_coercion ref stre poly in let msg = pr_global_env Id.Set.empty ref ++ str " is now a coercion" in Flags.if_verbose msg_info msg -let add_subclass_hook local ref = +let add_subclass_hook poly local ref = let stre = match local with | Local -> true | Global -> false | Discharge -> assert false in let cl = class_of_global ref in - try_add_new_coercion_subclass cl stre + try_add_new_coercion_subclass cl stre poly diff --git a/toplevel/class.mli b/toplevel/class.mli index 8bb3eb7ce..d472bd984 100644 --- a/toplevel/class.mli +++ b/toplevel/class.mli @@ -14,32 +14,35 @@ open Globnames (** [try_add_new_coercion_with_target ref s src tg] declares [ref] as a coercion from [src] to [tg] *) -val try_add_new_coercion_with_target : global_reference -> local:bool -> +val try_add_new_coercion_with_target : global_reference -> local:bool -> + Decl_kinds.polymorphic -> source:cl_typ -> target:cl_typ -> unit (** [try_add_new_coercion ref s] declares [ref], assumed to be of type [(x1:T1)...(xn:Tn)src->tg], as a coercion from [src] to [tg] *) -val try_add_new_coercion : global_reference -> local:bool -> unit +val try_add_new_coercion : global_reference -> local:bool -> + Decl_kinds.polymorphic -> unit (** [try_add_new_coercion_subclass cst s] expects that [cst] denotes a transparent constant which unfolds to some class [tg]; it declares an identity coercion from [cst] to [tg], named something like ["Id_cst_tg"] *) -val try_add_new_coercion_subclass : cl_typ -> local:bool -> unit +val try_add_new_coercion_subclass : cl_typ -> local:bool -> + Decl_kinds.polymorphic -> unit (** [try_add_new_coercion_with_source ref s src] declares [ref] as a coercion from [src] to [tg] where the target is inferred from the type of [ref] *) -val try_add_new_coercion_with_source : global_reference -> local:bool -> - source:cl_typ -> unit +val try_add_new_coercion_with_source : global_reference -> local:bool -> + Decl_kinds.polymorphic -> source:cl_typ -> unit (** [try_add_new_identity_coercion id s src tg] enriches the environment with a new definition of name [id] declared as an identity coercion from [src] to [tg] *) -val try_add_new_identity_coercion : Id.t -> local:bool -> - source:cl_typ -> target:cl_typ -> unit +val try_add_new_identity_coercion : Id.t -> local:bool -> + Decl_kinds.polymorphic -> source:cl_typ -> target:cl_typ -> unit -val add_coercion_hook : unit Tacexpr.declaration_hook +val add_coercion_hook : Decl_kinds.polymorphic -> unit Tacexpr.declaration_hook -val add_subclass_hook : unit Tacexpr.declaration_hook +val add_subclass_hook : Decl_kinds.polymorphic -> unit Tacexpr.declaration_hook val class_of_global : global_reference -> cl_typ diff --git a/toplevel/classes.ml b/toplevel/classes.ml index 2e17f646b..cf47abf44 100644 --- a/toplevel/classes.ml +++ b/toplevel/classes.ml @@ -33,11 +33,14 @@ let set_typeclass_transparency c local b = let _ = Hook.set Typeclasses.add_instance_hint_hook - (fun inst path local pri -> + (fun inst path local pri poly -> + let inst' = match inst with IsConstr c -> Auto.IsConstr (c, Univ.ContextSet.empty) + | IsGlobal gr -> Auto.IsGlobRef gr + in Flags.silently (fun () -> Auto.add_hints local [typeclasses_db] (Auto.HintsResolveEntry - [pri, false, Auto.PathHints path, inst])) ()); + [pri, poly, false, Auto.PathHints path, inst'])) ()); Hook.set Typeclasses.set_typeclass_transparency_hook set_typeclass_transparency; Hook.set Typeclasses.classes_transparent_state_hook (fun () -> Auto.Hint_db.transparent_state (Auto.searchtable_map typeclasses_db)) @@ -52,10 +55,11 @@ let declare_class g = (** TODO: add subinstances *) let existing_instance glob g pri = let c = global g in - let instance = Typing.type_of (Global.env ()) Evd.empty (constr_of_global c) in + let instance = Typing.type_of (Global.env ()) Evd.empty (Universes.constr_of_global c) in let _, r = decompose_prod_assum instance in match class_of_constr r with - | Some (_, (tc, _)) -> add_instance (new_instance tc pri glob c) + | Some (_, ((tc,u), _)) -> add_instance (new_instance tc pri glob + (*FIXME*) (Flags.use_polymorphic_flag ()) c) | None -> user_err_loc (loc_of_reference g, "declare_instance", Pp.str "Constant does not build instances of a declared type class.") @@ -95,27 +99,22 @@ let instance_hook k pri global imps ?hook cst = Typeclasses.declare_instance pri (not global) cst; (match hook with Some h -> h cst | None -> ()) -let declare_instance_constant k pri global imps ?hook id term termtype = +let declare_instance_constant k pri global imps ?hook id poly uctx term termtype = let kind = IsDefinition Instance in - let entry = { - const_entry_body = Future.from_val term; - const_entry_secctx = None; - const_entry_type = Some termtype; - const_entry_opaque = false; - const_entry_inline_code = false; - const_entry_feedback = None; - } in + let entry = + Declare.definition_entry ~types:termtype ~poly ~univs:uctx term + in let cdecl = (DefinitionEntry entry, kind) in let kn = Declare.declare_constant id cdecl in Declare.definition_message id; instance_hook k pri global imps ?hook (ConstRef kn); id -let new_instance ?(abstract=false) ?(global=false) ctx (instid, bk, cl) props +let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) props ?(generalize=true) ?(tac:unit Proofview.tactic option) ?hook pri = let env = Global.env() in - let evars = ref Evd.empty in + let evars = ref (Evd.from_env env) in let tclass, ids = match bk with | Implicit -> @@ -129,15 +128,19 @@ let new_instance ?(abstract=false) ?(global=false) ctx (instid, bk, cl) props cl | Explicit -> cl, Id.Set.empty in - let tclass = if generalize then CGeneralization (Loc.ghost, Implicit, Some AbsPi, tclass) else tclass in - let k, cty, ctx', ctx, len, imps, subst = + let tclass = + if generalize then CGeneralization (Loc.ghost, Implicit, Some AbsPi, tclass) + else tclass + in + let k, u, cty, ctx', ctx, len, imps, subst = let impls, ((env', ctx), imps) = interp_context_evars evars env ctx in let c', imps' = interp_type_evars_impls ~impls evars env' tclass in let len = List.length ctx in let imps = imps @ Impargs.lift_implicits len imps' in let ctx', c = decompose_prod_assum c' in let ctx'' = ctx' @ ctx in - let cl, args = Typeclasses.dest_class_app (push_rel_context ctx'' env) c in + let k, args = Typeclasses.dest_class_app (push_rel_context ctx'' env) c in + let cl, u = Typeclasses.typeclass_univ_instance k in let _, args = List.fold_right (fun (na, b, t) (args, args') -> match b with @@ -145,7 +148,7 @@ let new_instance ?(abstract=false) ?(global=false) ctx (instid, bk, cl) props | Some b -> (args, substl args' b :: args')) (snd cl.cl_context) (args, []) in - cl, c', ctx', ctx, len, imps, args + cl, u, c', ctx', ctx, len, imps, args in let id = match snd instid with @@ -161,19 +164,23 @@ let new_instance ?(abstract=false) ?(global=false) ctx (instid, bk, cl) props let env' = push_rel_context ctx env in evars := Evarutil.nf_evar_map !evars; evars := resolve_typeclasses ~filter:Typeclasses.no_goals ~fail:true env !evars; - let sigma = !evars in - let subst = List.map (Evarutil.nf_evar sigma) subst in + let subst = List.map (Evarutil.nf_evar !evars) subst in if abstract then begin - let _, ty_constr = instance_constructor k (List.rev subst) in + let subst = List.fold_left2 + (fun subst' s (_, b, _) -> if Option.is_empty b then s :: subst' else subst') + [] subst (snd k.cl_context) + in + let (_, ty_constr) = instance_constructor (k,u) subst in let termtype = let t = it_mkProd_or_LetIn ty_constr (ctx' @ ctx) in - Evarutil.nf_evar !evars t + fst (Evarutil.e_nf_evars_and_universes evars) t in Evarutil.check_evars env Evd.empty !evars termtype; + let ctx = Evd.universe_context !evars in let cst = Declare.declare_constant ~internal:Declare.KernelSilent id (Entries.ParameterEntry - (None,termtype,None), Decl_kinds.IsAssumption Decl_kinds.Logical) + (None,poly,(termtype,ctx),None), Decl_kinds.IsAssumption Decl_kinds.Logical) in instance_hook k None global imps ?hook (ConstRef cst); id end else ( @@ -203,11 +210,11 @@ let new_instance ?(abstract=false) ?(global=false) ctx (instid, bk, cl) props let props, rest = List.fold_left (fun (props, rest) (id,b,_) -> - if Option.is_empty b then - try - let is_id (id', _) = match id, get_id id' with - | Name id, (_, id') -> Id.equal id id' - | Anonymous, _ -> false + if Option.is_empty b then + try + let is_id (id', _) = match id, get_id id' with + | Name id, (_, id') -> Id.equal id id' + | Anonymous, _ -> false in let (loc_mid, c) = List.find is_id rest @@ -242,7 +249,7 @@ let new_instance ?(abstract=false) ?(global=false) ctx (instid, bk, cl) props (fun subst' s (_, b, _) -> if Option.is_empty b then s :: subst' else subst') [] subst (k.cl_props @ snd k.cl_context) in - let app, ty_constr = instance_constructor k subst in + let (app, ty_constr) = instance_constructor (k,u) subst in let termtype = it_mkProd_or_LetIn ty_constr (ctx' @ ctx) in let term = Termops.it_mkLambda_or_LetIn (Option.get app) (ctx' @ ctx) in Some term, termtype @@ -259,17 +266,19 @@ let new_instance ?(abstract=false) ?(global=false) ctx (instid, bk, cl) props evars := Typeclasses.resolve_typeclasses ~filter:Typeclasses.all_evars ~fail:false env !evars in - let termtype = Evarutil.nf_evar !evars termtype in + let _ = evars := Evarutil.nf_evar_map_undefined !evars in + let evm, nf = Evarutil.nf_evar_map_universes !evars in + let termtype = nf termtype in let _ = (* Check that the type is free of evars now. *) - Evarutil.check_evars env Evd.empty !evars termtype + Evarutil.check_evars env Evd.empty evm termtype in - let term = Option.map (Evarutil.nf_evar !evars) term in - let evm = Evarutil.nf_evar_map_undefined !evars in + let term = Option.map nf term in if not (Evd.has_undefined evm) && not (Option.is_empty term) then + let ctx = Evd.universe_context evm in declare_instance_constant k pri global imps ?hook id - (Option.get term,Declareops.no_seff) termtype + poly ctx (Option.get term) termtype else begin - let kind = Decl_kinds.Global, Decl_kinds.DefinitionBody Decl_kinds.Instance in + let kind = Decl_kinds.Global, poly, Decl_kinds.DefinitionBody Decl_kinds.Instance in if Flags.is_program_mode () then let hook vis gr = let cst = match gr with ConstRef kn -> kn | _ -> assert false in @@ -280,17 +289,18 @@ let new_instance ?(abstract=false) ?(global=false) ctx (instid, bk, cl) props match term with | Some t -> let obls, _, constr, typ = - Obligations.eterm_obligations env id !evars 0 t termtype + Obligations.eterm_obligations env id evm 0 t termtype in obls, Some constr, typ | None -> [||], None, termtype in + let ctx = Evd.get_universe_context_set evm in ignore (Obligations.add_definition id ?term:constr - typ ~kind:(Global,Instance) ~hook obls); + typ ctx ~kind:(Global,poly,Instance) ~hook obls); id else (Flags.silently (fun () -> - Lemmas.start_proof id kind termtype + Lemmas.start_proof id kind (termtype, Evd.get_universe_context_set evm) (fun _ -> instance_hook k pri global imps ?hook); (* spiwack: I don't know what to do with the status here. *) if not (Option.is_empty term) then @@ -315,7 +325,8 @@ let context l = let env = Global.env() in let evars = ref Evd.empty in let _, ((env', fullctx), impls) = interp_context_evars evars env l in - let fullctx = Evarutil.nf_rel_context_evar !evars fullctx in + let subst = Evarutil.evd_comb0 Evarutil.nf_evars_and_universes evars in + let fullctx = Context.map_rel_context subst fullctx in let ce t = Evarutil.check_evars env Evd.empty !evars t in let () = List.iter (fun (n, b, t) -> Option.iter ce b; ce t) fullctx in let ctx = @@ -323,13 +334,17 @@ let context l = with e when Errors.noncritical e -> error "Anonymous variables not allowed in contexts." in - let fn status (id, _, t) = + let uctx = Evd.get_universe_context_set !evars in + let fn status (id, b, t) = + let uctx = Universes.shrink_universe_context uctx (Universes.universes_of_constr t) in if Lib.is_modtype () && not (Lib.sections_are_opened ()) then - let decl = (ParameterEntry (None,t,None), IsAssumption Logical) in + let uctx = Univ.ContextSet.to_context uctx in + let decl = (ParameterEntry (None,false,(t,uctx),None), IsAssumption Logical) in let cst = Declare.declare_constant ~internal:Declare.KernelSilent id decl in match class_of_constr t with - | Some (rels, (tc, args) as _cl) -> - add_instance (Typeclasses.new_instance tc None false (ConstRef cst)); + | Some (rels, ((tc,_), args) as _cl) -> + add_instance (Typeclasses.new_instance tc None false (*FIXME*) + (Flags.use_polymorphic_flag ()) (ConstRef cst)); status (* declare_subclasses (ConstRef cst) cl *) | None -> status @@ -339,9 +354,9 @@ let context l = | _ -> false in let impl = List.exists test impls in - let decl = (Discharge, Definitional) in + let decl = (Discharge, (Flags.use_polymorphic_flag ()), Definitional) in let nstatus = - snd (Command.declare_assumption false decl t [] impl + snd (Command.declare_assumption false decl (t, uctx) [] impl Vernacexpr.NoInline (Loc.ghost, id)) in status && nstatus diff --git a/toplevel/classes.mli b/toplevel/classes.mli index de62ff369..4dd62ba9f 100644 --- a/toplevel/classes.mli +++ b/toplevel/classes.mli @@ -36,13 +36,16 @@ val declare_instance_constant : Impargs.manual_explicitation list -> (** implicits *) ?hook:(Globnames.global_reference -> unit) -> Id.t -> (** name *) - Entries.proof_output -> (** body *) + bool -> (* polymorphic *) + Univ.universe_context -> (* Universes *) + Constr.t -> (** body *) Term.types -> (** type *) Names.Id.t val new_instance : ?abstract:bool -> (** Not abstract by default. *) ?global:bool -> (** Not global by default. *) + Decl_kinds.polymorphic -> local_binder list -> typeclass_constraint -> constr_expr option -> diff --git a/toplevel/command.ml b/toplevel/command.ml index f41acaba2..d2111f0fb 100644 --- a/toplevel/command.ml +++ b/toplevel/command.ml @@ -56,8 +56,8 @@ let rec complete_conclusion a cs = function user_err_loc (loc,"", strbrk"Cannot infer the non constant arguments of the conclusion of " ++ pr_id cs ++ str "."); - let args = List.map (fun id -> CRef(Ident(loc,id))) params in - CAppExpl (loc,(None,Ident(loc,name)),List.rev args) + let args = List.map (fun id -> CRef(Ident(loc,id),None)) params in + CAppExpl (loc,(None,Ident(loc,name),None),List.rev args) | c -> c (* Commands of the interface *) @@ -74,29 +74,34 @@ let red_constant_entry n ce = function under_binders env (fst (reduction_of_red_expr env red)) n body,eff) } -let interp_definition bl red_option c ctypopt = +let interp_definition bl p red_option c ctypopt = let env = Global.env() in - let evdref = ref Evd.empty in + let evdref = ref (Evd.from_env env) in let impls, ((env_bl, ctx), imps1) = interp_context_evars evdref env bl in let nb_args = List.length ctx in let imps,ce = match ctypopt with None -> + let subst = evd_comb0 Evd.nf_univ_variables evdref in + let ctx = map_rel_context (Vars.subst_univs_constr subst) ctx in + let env_bl = push_rel_context ctx env in let c, imps2 = interp_constr_evars_impls ~impls evdref env_bl c in - let body = nf_evar !evdref (it_mkLambda_or_LetIn c ctx) in - imps1@(Impargs.lift_implicits nb_args imps2), - { const_entry_body = Future.from_val (body,Declareops.no_seff); - const_entry_secctx = None; - const_entry_type = None; - const_entry_opaque = false; - const_entry_inline_code = false; - const_entry_feedback = None; - } + let nf,subst = Evarutil.e_nf_evars_and_universes evdref in + let body = nf (it_mkLambda_or_LetIn c ctx) in + let vars = Universes.universes_of_constr body in + let ctx = Universes.restrict_universe_context + (Evd.get_universe_context_set !evdref) vars in + imps1@(Impargs.lift_implicits nb_args imps2), + definition_entry ~univs:(Univ.ContextSet.to_context ctx) ~poly:p body | Some ctyp -> let ty, impsty = interp_type_evars_impls ~impls evdref env_bl ctyp in + let subst = evd_comb0 Evd.nf_univ_variables evdref in + let ctx = map_rel_context (Vars.subst_univs_constr subst) ctx in + let env_bl = push_rel_context ctx env in let c, imps2 = interp_casted_constr_evars_impls ~impls evdref env_bl c ty in - let body = nf_evar !evdref (it_mkLambda_or_LetIn c ctx) in - let typ = nf_evar !evdref (it_mkProd_or_LetIn ty ctx) in + let nf, subst = Evarutil.e_nf_evars_and_universes evdref in + let body = nf (it_mkLambda_or_LetIn c ctx) in + let typ = nf (it_mkProd_or_LetIn ty ctx) in let beq b1 b2 = if b1 then b2 else not b2 in let impl_eq (x,y,z) (x',y',z') = beq x x' && beq y y' && beq z z' in (* Check that all implicit arguments inferable from the term @@ -108,14 +113,13 @@ let interp_definition bl red_option c ctypopt = then msg_warning (strbrk "Implicit arguments declaration relies on type." ++ spc () ++ strbrk "The term declares more implicits than the type here."); + let vars = Univ.LSet.union (Universes.universes_of_constr body) + (Universes.universes_of_constr typ) in + let ctx = Universes.restrict_universe_context + (Evd.get_universe_context_set !evdref) vars in imps1@(Impargs.lift_implicits nb_args impsty), - { const_entry_body = Future.from_val(body,Declareops.no_seff); - const_entry_secctx = None; - const_entry_type = Some typ; - const_entry_opaque = false; - const_entry_inline_code = false; - const_entry_feedback = None; - } + definition_entry ~types:typ ~poly:p + ~univs:(Univ.ContextSet.to_context ctx) body in red_constant_entry (rel_context_length ctx) ce red_option, !evdref, imps @@ -144,7 +148,7 @@ let declare_definition_hook = ref ignore let set_declare_definition_hook = (:=) declare_definition_hook let get_declare_definition_hook () = !declare_definition_hook -let declare_definition ident (local,k) ce imps hook = +let declare_definition ident (local, p, k) ce imps hook = let () = !declare_definition_hook ce in let r = match local with | Discharge when Lib.sections_are_opened () -> @@ -164,7 +168,7 @@ let declare_definition ident (local,k) ce imps hook = let _ = Obligations.declare_definition_ref := declare_definition let do_definition ident k bl red_option c ctypopt hook = - let (ce, evd, imps as def) = interp_definition bl red_option c ctypopt in + let (ce, evd, imps as def) = interp_definition bl (pi2 k) red_option c ctypopt in if Flags.is_program_mode () then let env = Global.env () in let c,sideff = Future.force ce.const_entry_body in @@ -177,16 +181,17 @@ let do_definition ident k bl red_option c ctypopt hook = let obls, _, c, cty = Obligations.eterm_obligations env ident evd 0 c typ in - ignore(Obligations.add_definition ident ~term:c cty ~implicits:imps ~kind:k ~hook obls) + let ctx = Evd.get_universe_context_set evd in + ignore(Obligations.add_definition ident ~term:c cty ctx ~implicits:imps ~kind:k ~hook obls) else let ce = check_definition def in ignore(declare_definition ident k ce imps (fun l r -> hook l r;r)) (* 2| Variable/Hypothesis/Parameter/Axiom declarations *) -let declare_assumption is_coe (local, kind) c imps impl nl (_,ident) = match local with +let declare_assumption is_coe (local,p,kind) (c,ctx) imps impl nl (_,ident) = match local with | Discharge when Lib.sections_are_opened () -> - let decl = (Lib.cwd(), SectionLocalAssum (c,impl), IsAssumption kind) in + let decl = (Lib.cwd(), SectionLocalAssum ((c,ctx),p,impl), IsAssumption kind) in let _ = declare_variable ident decl in let () = assumption_message ident in let () = @@ -196,8 +201,9 @@ let declare_assumption is_coe (local, kind) c imps impl nl (_,ident) = match loc in let r = VarRef ident in let () = Typeclasses.declare_instance None true r in - let () = if is_coe then Class.try_add_new_coercion r ~local:true in + let () = if is_coe then Class.try_add_new_coercion r ~local:true false in (r,true) + | Global | Local | Discharge -> let local = get_locality ident local in let inl = match nl with @@ -205,18 +211,25 @@ let declare_assumption is_coe (local, kind) c imps impl nl (_,ident) = match loc | DefaultInline -> Some (Flags.get_inline_level()) | InlineAt i -> Some i in - let decl = (ParameterEntry (None,c,inl), IsAssumption kind) in + let ctx = Univ.ContextSet.to_context ctx in + let decl = (ParameterEntry (None,p,(c,ctx),inl), IsAssumption kind) in let kn = declare_constant ident ~local decl in let gr = ConstRef kn in let () = maybe_declare_manual_implicits false gr imps in let () = assumption_message ident in let () = Typeclasses.declare_instance None false gr in - let () = if is_coe then Class.try_add_new_coercion gr local in + let () = if is_coe then Class.try_add_new_coercion gr local p in (gr,Lib.is_modtype_strict ()) +let declare_assumptions_hook = ref ignore +let set_declare_assumptions_hook = (:=) declare_assumptions_hook + let interp_assumption evdref env bl c = let c = prod_constr_expr c bl in - interp_type_evars_impls evdref env c + let ty, impls = interp_type_evars_impls evdref env c in + let evd, nf = nf_evars_and_universes !evdref in + let ctx = Evd.get_universe_context_set evd in + ((nf ty, ctx), impls) let declare_assumptions idl is_coe k c imps impl_is_on nl = let refs, status = @@ -229,16 +242,16 @@ let do_assumptions kind nl l = let env = Global.env () in let evdref = ref Evd.empty in let _,l = List.fold_map (fun env (is_coe,(idl,c)) -> - let t,imps = interp_assumption evdref env [] c in + let (t,ctx),imps = interp_assumption evdref env [] c in let env = push_named_context (List.map (fun (_,id) -> (id,None,t)) idl) env in - (env,((is_coe,idl),t,imps))) env l in + (env,((is_coe,idl),t,(ctx,imps)))) env l in let evd = solve_remaining_evars all_and_fail_flags env Evd.empty !evdref in let l = List.map (on_pi2 (nf_evar evd)) l in - snd (List.fold_left (fun (subst,status) ((is_coe,idl),t,imps) -> + snd (List.fold_left (fun (subst,status) ((is_coe,idl),t,(ctx,imps)) -> let t = replace_vars subst t in - let (refs,status') = declare_assumptions idl is_coe kind t imps false nl in - let subst' = List.map2 (fun (_,id) c -> (id,constr_of_global c)) idl refs in + let (refs,status') = declare_assumptions idl is_coe kind (t,ctx) imps false nl in + let subst' = List.map2 (fun (_,id) c -> (id,Universes.constr_of_global c)) idl refs in (subst'@subst, status' && status)) ([],true) l) (* 3a| Elimination schemes for mutual inductive definitions *) @@ -290,6 +303,23 @@ let prepare_param = function | (na,None,t) -> out_name na, LocalAssum t | (na,Some b,_) -> out_name na, LocalDef b + +let make_conclusion_flexible evdref ty = + if isArity ty then + let _, concl = destArity ty in + match concl with + | Type u -> + (match Univ.universe_level u with + | Some u -> evdref := Evd.make_flexible_variable !evdref true u + | None -> ()) + | _ -> () + else () + +let is_impredicative env u = + u = Prop Null || + (engagement env = Some Declarations.ImpredicativeSet && u = Prop Pos) + +(** Make the arity conclusion flexible to avoid generating an upper bound universe now. *) let interp_ind_arity evdref env ind = interp_type_evars_impls evdref env ind.ind_arity @@ -301,10 +331,88 @@ let interp_cstrs evdref env impls mldata arity ind = let ctyps'', cimpls = List.split (List.map (interp_type_evars_impls evdref env ~impls) ctyps') in (cnames, ctyps'', cimpls) -let interp_mutual_inductive (paramsl,indl) notations finite = +let sign_level env evd sign = + fst (List.fold_right + (fun (_,_,t as d) (lev,env) -> + let s = destSort (Reduction.whd_betadeltaiota env + (nf_evar evd (Retyping.get_type_of env evd t))) + in + let u = univ_of_sort s in + (Univ.sup u lev, push_rel d env)) + sign (Univ.type0m_univ,env)) + +let sup_list = List.fold_left Univ.sup Univ.type0m_univ + +let extract_level env evd tys = + let sorts = List.map (fun ty -> + let ctx, concl = Reduction.dest_prod_assum env ty in + sign_level env evd ctx) tys + in sup_list sorts + +let inductive_levels env evdref arities inds = + let destarities = List.map (Reduction.dest_arity env) arities in + let levels = List.map (fun (ctx,a) -> + if a = Prop Null then None + else Some (univ_of_sort a)) destarities + in + let cstrs_levels, min_levels, sizes = + CList.split3 + (List.map2 (fun (_,tys,_) (ctx,du) -> + let len = List.length tys in + let clev = extract_level env !evdref tys in + let minlev = + if len > 1 && not (is_impredicative env du) then + Univ.type0_univ + else Univ.type0m_univ + in + (clev, minlev, len)) inds destarities) + in + (* Take the transitive closure of the system of constructors *) + (* level constraints and remove the recursive dependencies *) + let levels' = Univ.solve_constraints_system (Array.of_list levels) + (Array.of_list cstrs_levels) (Array.of_list min_levels) + in + let evd = + CList.fold_left3 (fun evd cu (ctx,du) len -> + if is_impredicative env du then + (** Any product is allowed here. *) + evd + else (** If in a predicative sort, or asked to infer the type, + we take the max of: + - indices (if in indices-matter mode) + - constructors + - Type(1) if there is more than 1 constructor + *) + let evd = + (** Indices contribute. *) + if Indtypes.is_indices_matter () then ( + let ilev = sign_level env !evdref ctx in + Evd.set_leq_sort evd (Type ilev) du) + else evd + in + (** Constructors contribute. *) + let evd = + if Sorts.is_set du then + if not (Evd.check_leq evd cu Univ.type0_univ) then + raise (Indtypes.InductiveError Indtypes.LargeNonPropInductiveNotInType) + else evd + else Evd.set_leq_sort evd (Type cu) du + in + let evd = + if len >= 2 && Univ.is_type0m_univ cu then + (** "Polymorphic" type constraint and more than one constructor, + should not land in Prop. Add constraint only if it would + land in Prop directly (no informative arguments as well). *) + Evd.set_leq_sort evd (Prop Pos) du + else evd + in evd) + !evdref (Array.to_list levels') destarities sizes + in evdref := evd; arities + +let interp_mutual_inductive (paramsl,indl) notations poly finite = check_all_names_different indl; let env0 = Global.env() in - let evdref = ref Evd.empty in + let evdref = ref Evd.(from_env env0) in let _, ((env_params, ctx_params), userimpls) = interp_context_evars evdref env0 paramsl in @@ -316,12 +424,14 @@ let interp_mutual_inductive (paramsl,indl) notations finite = (* Interpret the arities *) let arities = List.map (interp_ind_arity evdref env_params) indl in + let fullarities = List.map (fun (c, _) -> it_mkProd_or_LetIn c ctx_params) arities in let env_ar = push_types env0 indnames fullarities in let env_ar_params = push_rel_context ctx_params env_ar in (* Compute interpretation metadatas *) - let indimpls = List.map (fun (_, impls) -> userimpls @ lift_implicits (rel_context_nhyps ctx_params) impls) arities in + let indimpls = List.map (fun (_, impls) -> userimpls @ + lift_implicits (rel_context_nhyps ctx_params) impls) arities in let arities = List.map fst arities in let impls = compute_internalization_env env0 (Inductive params) indnames fullarities indimpls in let mldatas = List.map2 (mk_mltype_data evdref env_params params) arities indnames in @@ -336,9 +446,24 @@ let interp_mutual_inductive (paramsl,indl) notations finite = (* Try further to solve evars, and instantiate them *) let sigma = solve_remaining_evars all_and_fail_flags env_params Evd.empty !evdref in - let constructors = List.map (fun (idl,cl,impsl) -> (idl,List.map (nf_evar sigma) cl,impsl)) constructors in - let ctx_params = Context.map_rel_context (nf_evar sigma) ctx_params in - let arities = List.map (nf_evar sigma) arities in + evdref := sigma; + (* Compute renewed arities *) + let nf,_ = e_nf_evars_and_universes evdref in + let arities = List.map nf arities in + let constructors = List.map (fun (idl,cl,impsl) -> (idl,List.map nf cl,impsl)) constructors in + let _ = List.iter (fun ty -> make_conclusion_flexible evdref ty) arities in + let arities = inductive_levels env_ar_params evdref arities constructors in + let nf',_ = e_nf_evars_and_universes evdref in + let nf x = nf' (nf x) in + let arities = List.map nf' arities in + let constructors = List.map (fun (idl,cl,impsl) -> (idl,List.map nf' cl,impsl)) constructors in + let ctx_params = map_rel_context nf ctx_params in + let evd = !evdref in + List.iter (check_evars env_params Evd.empty evd) arities; + iter_rel_context (check_evars env0 Evd.empty evd) ctx_params; + List.iter (fun (_,ctyps,_) -> + List.iter (check_evars env_ar_params Evd.empty evd) ctyps) + constructors; (* Build the inductive entries *) let entries = List.map3 (fun ind arity (cnames,ctypes,cimpls) -> { @@ -357,7 +482,9 @@ let interp_mutual_inductive (paramsl,indl) notations finite = { mind_entry_params = List.map prepare_param ctx_params; mind_entry_record = false; mind_entry_finite = finite; - mind_entry_inds = entries }, + mind_entry_inds = entries; + mind_entry_polymorphic = poly; + mind_entry_universes = Evd.universe_context evd }, impls (* Very syntactical equality *) @@ -412,16 +539,19 @@ type one_inductive_impls = Impargs.manual_explicitation list (* for inds *)* Impargs.manual_explicitation list list (* for constrs *) -let do_mutual_inductive indl finite = +type one_inductive_expr = + lident * local_binder list * constr_expr option * constructor_expr list + +let do_mutual_inductive indl poly finite = let indl,coes,ntns = extract_mutual_inductive_declaration_components indl in (* Interpret the types *) - let mie,impls = interp_mutual_inductive indl ntns finite in + let mie,impls = interp_mutual_inductive indl ntns poly finite in (* Declare the mutual inductive block with its associated schemes *) ignore (declare_mutual_inductive_with_eliminations UserVerbose mie impls); (* Declare the possible notations of inductive types *) List.iter Metasyntax.add_notation_interpretation ntns; (* Declare the coercions *) - List.iter (fun qid -> Class.try_add_new_coercion (locate qid) false) coes + List.iter (fun qid -> Class.try_add_new_coercion (locate qid) false poly) coes (* 3c| Fixpoints and co-fixpoints *) @@ -525,11 +655,14 @@ let interp_fix_body evdref env_rec impls (_,ctx) fix ccl = let build_fix_type (_,ctx) ccl = it_mkProd_or_LetIn ccl ctx -let declare_fix kind f def t imps = +let declare_fix (_,poly,_ as kind) ctx f def t imps = let ce = { const_entry_body = Future.from_val def; const_entry_secctx = None; const_entry_type = Some t; + const_entry_polymorphic = poly; + const_entry_universes = ctx; + const_entry_proj = None; const_entry_opaque = false; const_entry_inline_code = false; const_entry_feedback = None; @@ -576,7 +709,7 @@ let fix_sub_ref = make_ref fixsub_module "Fix_sub" let measure_on_R_ref = make_ref fixsub_module "MR" let well_founded = init_constant ["Init"; "Wf"] "well_founded" let mkSubset name typ prop = - mkApp ((delayed_force build_sigma).typ, + mkApp (Universes.constr_of_global (delayed_force build_sigma).typ, [| typ; mkLambda (name, typ, prop) |]) let sigT = Lazy.lazy_from_fun build_sigma_type @@ -591,15 +724,19 @@ let rec telescope = function List.fold_left (fun (ty, tys, (k, constr)) (n, b, t) -> let pred = mkLambda (n, t, ty) in - let sigty = mkApp ((Lazy.force sigT).typ, [|t; pred|]) in - let intro = mkApp ((Lazy.force sigT).intro, [|lift k t; lift k pred; mkRel k; constr|]) in + let ty = Universes.constr_of_global (Lazy.force sigT).typ in + let intro = Universes.constr_of_global (Lazy.force sigT).intro in + let sigty = mkApp (ty, [|t; pred|]) in + let intro = mkApp (intro, [|lift k t; lift k pred; mkRel k; constr|]) in (sigty, pred :: tys, (succ k, intro))) (t, [], (2, mkRel 1)) tl in let (last, subst) = List.fold_right2 (fun pred (n, b, t) (prev, subst) -> - let proj1 = applistc (Lazy.force sigT).proj1 [t; pred; prev] in - let proj2 = applistc (Lazy.force sigT).proj2 [t; pred; prev] in + let p1 = Universes.constr_of_global (Lazy.force sigT).proj1 in + let p2 = Universes.constr_of_global (Lazy.force sigT).proj2 in + let proj1 = applistc p1 [t; pred; prev] in + let proj2 = applistc p2 [t; pred; prev] in (lift 1 proj2, (n, Some proj1, t) :: subst)) (List.rev tys) tl (mkRel 1, []) in ty, ((n, Some last, t) :: subst), constr @@ -648,7 +785,7 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation = it_mkLambda_or_LetIn measure letbinders, it_mkLambda_or_LetIn measure binders in - let comb = constr_of_global (delayed_force measure_on_R_ref) in + let comb = Universes.constr_of_global (delayed_force measure_on_R_ref) in let wf_rel = mkApp (comb, [| argtyp; relargty; rel; measure |]) in let wf_rel_fun x y = mkApp (rel, [| subst1 x measure_body; @@ -663,7 +800,7 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation = in let intern_bl = wfarg 1 :: [arg] in let _intern_env = push_rel_context intern_bl env in - let proj = (delayed_force build_sigma).Coqlib.proj1 in + let proj = (*FIXME*)Universes.constr_of_global (delayed_force build_sigma).Coqlib.proj1 in let wfargpred = mkLambda (Name argid', argtyp, wf_rel_fun (mkRel 1) (mkRel 3)) in let projection = (* in wfarg :: arg :: before *) mkApp (proj, [| argtyp ; wfargpred ; mkRel 1 |]) @@ -676,7 +813,8 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation = let intern_fun_binder = (Name (add_suffix recname "'"), None, intern_fun_arity_prod) in let curry_fun = let wfpred = mkLambda (Name argid', argtyp, wf_rel_fun (mkRel 1) (mkRel (2 * len + 4))) in - let arg = mkApp ((delayed_force build_sigma).intro, [| argtyp; wfpred; lift 1 make; mkRel 1 |]) in + let intro = (*FIXME*)Universes.constr_of_global (delayed_force build_sigma).Coqlib.intro in + let arg = mkApp (intro, [| argtyp; wfpred; lift 1 make; mkRel 1 |]) in let app = mkApp (mkRel (2 * len + 2 (* recproof + orig binders + current binders *)), [| arg |]) in let rcurry = mkApp (rel, [| measure; lift len measure |]) in let lam = (Name (Id.of_string "recproof"), None, rcurry) in @@ -701,7 +839,7 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation = let intern_body_lam = it_mkLambda_or_LetIn intern_body (curry_fun :: lift_lets @ fun_bl) in let prop = mkLambda (Name argname, argtyp, top_arity_let) in let def = - mkApp (constr_of_global (delayed_force fix_sub_ref), + mkApp (Universes.constr_of_global (delayed_force fix_sub_ref), [| argtyp ; wf_rel ; Evarutil.e_new_evar evdref env ~src:(Loc.ghost, Evar_kinds.QuestionMark (Evar_kinds.Define false)) wf_proof; @@ -715,16 +853,20 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation = if List.length binders_rel > 1 then let name = add_suffix recname "_func" in let hook l gr = - let body = it_mkLambda_or_LetIn (mkApp (constr_of_global gr, [|make|])) binders_rel in + let body = it_mkLambda_or_LetIn (mkApp (Universes.constr_of_global gr, [|make|])) binders_rel in let ty = it_mkProd_or_LetIn top_arity binders_rel in let ce = { const_entry_body = Future.from_val (Evarutil.nf_evar !evdref body,Declareops.no_seff); const_entry_secctx = None; const_entry_type = Some ty; - const_entry_opaque = false; - const_entry_inline_code = false; + (* FIXME *) + const_entry_proj = None; + const_entry_polymorphic = false; + const_entry_universes = Evd.universe_context !evdref; const_entry_feedback = None; - } in + const_entry_opaque = false; + const_entry_inline_code = false} + in (** FIXME: include locality *) let c = Declare.declare_constant recname (DefinitionEntry ce, IsDefinition Definition) in let gr = ConstRef c in @@ -746,9 +888,9 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation = let evars, _, evars_def, evars_typ = Obligations.eterm_obligations env recname !evdref 0 fullcoqc fullctyp in - ignore(Obligations.add_definition - recname ~term:evars_def evars_typ evars ~hook) - + let ctx = Evd.get_universe_context_set !evdref in + ignore(Obligations.add_definition recname ~term:evars_def + evars_typ ctx evars ~hook) let interp_recursive isfix fixl notations = let env = Global.env() in @@ -794,8 +936,9 @@ let interp_recursive isfix fixl notations = (* Instantiate evars and check all are resolved *) let evd = consider_remaining_unif_problems env_rec !evdref in - let fixdefs = List.map (Option.map (nf_evar evd)) fixdefs in - let fixtypes = List.map (nf_evar evd) fixtypes in + let evd, nf = nf_evars_and_universes evd in + let fixdefs = List.map (Option.map nf) fixdefs in + let fixtypes = List.map nf fixtypes in let fixctxnames = List.map (fun (_,ctx) -> List.map pi1 ctx) fixctxs in (* Build the fix declaration block *) @@ -811,25 +954,25 @@ let check_recursive isfix env evd (fixnames,fixdefs,_) = let interp_fixpoint l ntns = let (env,_,evd),fix,info = interp_recursive true l ntns in check_recursive true env evd fix; - fix,info + (fix,Evd.get_universe_context_set evd,info) let interp_cofixpoint l ntns = let (env,_,evd),fix,info = interp_recursive false l ntns in check_recursive false env evd fix; - fix,info + fix,Evd.get_universe_context_set evd,info -let declare_fixpoint local ((fixnames,fixdefs,fixtypes),fiximps) indexes ntns = +let declare_fixpoint local poly ((fixnames,fixdefs,fixtypes),ctx,fiximps) indexes ntns = if List.exists Option.is_empty fixdefs then (* Some bodies to define by proof *) let thms = - List.map3 (fun id t (len,imps,_) -> (id,(t,(len,imps)))) fixnames fixtypes fiximps in + List.map3 (fun id t (len,imps,_) -> (id,((t,ctx),(len,imps)))) fixnames fixtypes fiximps in let init_tac = Some (List.map (Option.cata Tacmach.refine_no_check Tacticals.tclIDTAC) fixdefs) in let init_tac = Option.map (List.map Proofview.V82.tactic) init_tac in - Lemmas.start_proof_with_initialization (Global,DefinitionBody Fixpoint) + Lemmas.start_proof_with_initialization (Global,poly,DefinitionBody Fixpoint) (Some(false,indexes,init_tac)) thms None (fun _ _ -> ()) else begin (* We shortcut the proof process *) @@ -841,25 +984,27 @@ let declare_fixpoint local ((fixnames,fixdefs,fixtypes),fiximps) indexes ntns = let fixdecls = List.map_i (fun i _ -> mkFix ((indexes,i),fixdecls)) 0 fixnames in let fixdecls = List.map (fun c -> c, Declareops.no_seff) fixdecls in - ignore (List.map4 (declare_fix (local, Fixpoint)) fixnames fixdecls fixtypes fiximps); + let ctx = Univ.ContextSet.to_context ctx in + ignore (List.map4 (declare_fix (local, poly, Fixpoint) ctx) + fixnames fixdecls fixtypes fiximps); (* Declare the recursive definitions *) fixpoint_message (Some indexes) fixnames; end; (* Declare notations *) List.iter Metasyntax.add_notation_interpretation ntns -let declare_cofixpoint local ((fixnames,fixdefs,fixtypes),fiximps) ntns = +let declare_cofixpoint local poly ((fixnames,fixdefs,fixtypes),ctx,fiximps) ntns = if List.exists Option.is_empty fixdefs then (* Some bodies to define by proof *) let thms = - List.map3 (fun id t (len,imps,_) -> (id,(t,(len,imps)))) fixnames fixtypes fiximps in + List.map3 (fun id t (len,imps,_) -> (id,((t,ctx),(len,imps)))) fixnames fixtypes fiximps in let init_tac = Some (List.map (Option.cata Tacmach.refine_no_check Tacticals.tclIDTAC) fixdefs) in let init_tac = Option.map (List.map Proofview.V82.tactic) init_tac in - Lemmas.start_proof_with_initialization (Global,DefinitionBody CoFixpoint) + Lemmas.start_proof_with_initialization (Global,poly, DefinitionBody CoFixpoint) (Some(true,[],init_tac)) thms None (fun _ _ -> ()) else begin (* We shortcut the proof process *) @@ -868,7 +1013,9 @@ let declare_cofixpoint local ((fixnames,fixdefs,fixtypes),fiximps) ntns = let fixdecls = List.map_i (fun i _ -> mkCoFix (i,fixdecls)) 0 fixnames in let fixdecls = List.map (fun c-> c,Declareops.no_seff) fixdecls in let fiximps = List.map (fun (len,imps,idx) -> imps) fiximps in - ignore (List.map4 (declare_fix (local, CoFixpoint)) fixnames fixdecls fixtypes fiximps); + let ctx = Univ.ContextSet.to_context ctx in + ignore (List.map4 (declare_fix (local, poly, CoFixpoint) ctx) + fixnames fixdecls fixtypes fiximps); (* Declare the recursive definitions *) cofixpoint_message fixnames end; @@ -898,7 +1045,12 @@ let out_def = function | Some def -> def | None -> error "Program Fixpoint needs defined bodies." -let do_program_recursive local fixkind fixl ntns = +let collect_evars_of_term evd c ty = + let evars = Evar.Set.union (evars_of_term c) (evars_of_term ty) in + Evar.Set.fold (fun ev acc -> Evd.add acc ev (Evd.find_undefined evd ev)) + evars Evd.empty + +let do_program_recursive local p fixkind fixl ntns = let isfix = fixkind != Obligations.IsCoFixpoint in let (env, rec_sign, evd), fix, info = interp_recursive isfix fixl ntns @@ -934,13 +1086,14 @@ let do_program_recursive local fixkind fixl ntns = Pretyping.search_guard Loc.ghost (Global.env ()) possible_indexes fixdecls in List.iteri (fun i _ -> Inductive.check_fix env ((indexes,i),fixdecls)) fixl end in + let ctx = Evd.get_universe_context_set evd in let kind = match fixkind with - | Obligations.IsFixpoint _ -> (local, Fixpoint) - | Obligations.IsCoFixpoint -> (local, CoFixpoint) + | Obligations.IsFixpoint _ -> (local, p, Fixpoint) + | Obligations.IsCoFixpoint -> (local, p, CoFixpoint) in - Obligations.add_mutual_definitions defs ~kind ntns fixkind + Obligations.add_mutual_definitions defs ~kind ctx ntns fixkind -let do_program_fixpoint local l = +let do_program_fixpoint local poly l = let g = List.map (fun ((_,wf,_,_,_),_) -> wf) l in match g, l with | [(n, CWfRec r)], [(((_,id),_,bl,typ,def),ntn)] -> @@ -954,30 +1107,30 @@ let do_program_fixpoint local l = | [(n, CMeasureRec (m, r))], [(((_,id),_,bl,typ,def),ntn)] -> build_wellfounded (id, n, bl, typ, out_def def) - (Option.default (CRef lt_ref) r) m ntn + (Option.default (CRef (lt_ref,None)) r) m ntn | _, _ when List.for_all (fun (n, ro) -> ro == CStructRec) g -> let fixl,ntns = extract_fixpoint_components true l in let fixkind = Obligations.IsFixpoint g in - do_program_recursive local fixkind fixl ntns + do_program_recursive local poly fixkind fixl ntns | _, _ -> errorlabstrm "do_program_fixpoint" (str "Well-founded fixpoints not allowed in mutually recursive blocks") -let do_fixpoint local l = - if Flags.is_program_mode () then do_program_fixpoint local l +let do_fixpoint local poly l = + if Flags.is_program_mode () then do_program_fixpoint local poly l else let fixl, ntns = extract_fixpoint_components true l in let fix = interp_fixpoint fixl ntns in let possible_indexes = - List.map compute_possible_guardness_evidences (snd fix) in - declare_fixpoint local fix possible_indexes ntns + List.map compute_possible_guardness_evidences (pi3 fix) in + declare_fixpoint local poly fix possible_indexes ntns -let do_cofixpoint local l = +let do_cofixpoint local poly l = let fixl,ntns = extract_cofixpoint_components l in if Flags.is_program_mode () then - do_program_recursive local Obligations.IsCoFixpoint fixl ntns + do_program_recursive local poly Obligations.IsCoFixpoint fixl ntns else let cofix = interp_cofixpoint fixl ntns in - declare_cofixpoint local cofix ntns + declare_cofixpoint local poly cofix ntns diff --git a/toplevel/command.mli b/toplevel/command.mli index d2ebdc561..b2ba23ef2 100644 --- a/toplevel/command.mli +++ b/toplevel/command.mli @@ -29,7 +29,7 @@ val get_declare_definition_hook : unit -> (definition_entry -> unit) (** {6 Definitions/Let} *) val interp_definition : - local_binder list -> red_expr option -> constr_expr -> + local_binder list -> polymorphic -> red_expr option -> constr_expr -> constr_expr option -> definition_entry * Evd.evar_map * Impargs.manual_implicits val declare_definition : Id.t -> definition_kind -> @@ -42,16 +42,25 @@ val do_definition : Id.t -> definition_kind -> (** {6 Parameters/Assumptions} *) +(* val interp_assumption : env -> evar_map ref -> *) +(* local_binder list -> constr_expr -> *) +(* types Univ.in_universe_context_set * Impargs.manual_implicits *) + (** returns [false] if the assumption is neither local to a section, nor in a module type and meant to be instantiated. *) -val declare_assumption : coercion_flag -> assumption_kind -> types -> +val declare_assumption : coercion_flag -> assumption_kind -> + types Univ.in_universe_context_set -> Impargs.manual_implicits -> bool (** implicit *) -> Vernacexpr.inline -> variable Loc.located -> global_reference * bool -val do_assumptions : locality * assumption_object_kind -> +val do_assumptions : locality * polymorphic * assumption_object_kind -> Vernacexpr.inline -> simple_binder with_coercion list -> bool +(* val declare_assumptions : variable Loc.located list -> *) +(* coercion_flag -> assumption_kind -> types Univ.in_universe_context_set -> *) +(* Impargs.manual_implicits -> bool -> Vernacexpr.inline -> bool *) + (** {6 Inductive and coinductive types} *) (** Extracting the semantical components out of the raw syntax of mutual @@ -77,7 +86,7 @@ type one_inductive_impls = Impargs.manual_implicits list (** for constrs *) val interp_mutual_inductive : - structured_inductive_expr -> decl_notation list -> bool -> + structured_inductive_expr -> decl_notation list -> polymorphic -> bool(*finite*) -> mutual_inductive_entry * one_inductive_impls list (** Registering a mutual inductive definition together with its @@ -90,7 +99,7 @@ val declare_mutual_inductive_with_eliminations : (** Entry points for the vernacular commands Inductive and CoInductive *) val do_mutual_inductive : - (one_inductive_expr * decl_notation list) list -> bool -> unit + (one_inductive_expr * decl_notation list) list -> polymorphic -> bool -> unit (** {6 Fixpoints and cofixpoints} *) @@ -120,33 +129,38 @@ type recursive_preentry = val interp_fixpoint : structured_fixpoint_expr list -> decl_notation list -> - recursive_preentry * (Name.t list * Impargs.manual_implicits * int option) list + recursive_preentry * Univ.universe_context_set * + (Name.t list * Impargs.manual_implicits * int option) list val interp_cofixpoint : structured_fixpoint_expr list -> decl_notation list -> - recursive_preentry * (Name.t list * Impargs.manual_implicits * int option) list + recursive_preentry * Univ.universe_context_set * + (Name.t list * Impargs.manual_implicits * int option) list (** Registering fixpoints and cofixpoints in the environment *) val declare_fixpoint : - locality -> recursive_preentry * (Name.t list * Impargs.manual_implicits * int option) list -> + locality -> polymorphic -> + recursive_preentry * Univ.universe_context_set * + (Name.t list * Impargs.manual_implicits * int option) list -> lemma_possible_guards -> decl_notation list -> unit -val declare_cofixpoint : - locality -> recursive_preentry * (Name.t list * Impargs.manual_implicits * int option) list -> - decl_notation list -> unit +val declare_cofixpoint : locality -> polymorphic -> + recursive_preentry * Univ.universe_context_set * + (Name.t list * Impargs.manual_implicits * int option) list -> + decl_notation list -> unit (** Entry points for the vernacular commands Fixpoint and CoFixpoint *) val do_fixpoint : - locality -> (fixpoint_expr * decl_notation list) list -> unit + locality -> polymorphic -> (fixpoint_expr * decl_notation list) list -> unit val do_cofixpoint : - locality -> (cofixpoint_expr * decl_notation list) list -> unit + locality -> polymorphic -> (cofixpoint_expr * decl_notation list) list -> unit (** Utils *) val check_mutuality : Environ.env -> bool -> (Id.t * types) list -> unit -val declare_fix : definition_kind -> Id.t -> +val declare_fix : definition_kind -> Univ.universe_context -> Id.t -> Entries.proof_output -> types -> Impargs.manual_implicits -> global_reference diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 51dc8d5bb..d772171e5 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -382,6 +382,7 @@ let parse_args arglist = Serialize.document Xml_printer.to_string_fmt; exit 0 |"-ideslave" -> Flags.ide_slave := true |"-impredicative-set" -> set_engagement Declarations.ImpredicativeSet + |"-indices-matter" -> Indtypes.enforce_indices_matter () |"-just-parsing" -> Vernac.just_parsing := true |"-lazy-load-proofs" -> Flags.load_proofs := Flags.Lazy |"-m"|"--memory" -> memory_stat := true diff --git a/toplevel/discharge.ml b/toplevel/discharge.ml index b9ffbaea5..55475a378 100644 --- a/toplevel/discharge.ml +++ b/toplevel/discharge.ml @@ -69,14 +69,9 @@ let abstract_inductive hyps nparams inds = in (params',ind'') let refresh_polymorphic_type_of_inductive (_,mip) = - match mip.mind_arity with - | Monomorphic s -> - s.mind_user_arity - | Polymorphic ar -> - let ctx = List.rev mip.mind_arity_ctxt in - mkArity (List.rev ctx,Termops.new_Type_sort()) + mip.mind_arity.mind_user_arity -let process_inductive sechyps modlist mib = +let process_inductive (sechyps,abs_ctx) modlist mib = let nparams = mib.mind_nparams in let inds = Array.map_to_list @@ -90,7 +85,11 @@ let process_inductive sechyps modlist mib = mib.mind_packets in let sechyps' = map_named_context (expmod_constr modlist) sechyps in let (params',inds') = abstract_inductive sechyps' nparams inds in - { mind_entry_record = mib.mind_record; + let univs = Univ.UContext.union abs_ctx mib.mind_universes in + { mind_entry_record = mib.mind_record <> None; mind_entry_finite = mib.mind_finite; mind_entry_params = params'; - mind_entry_inds = inds' } + mind_entry_inds = inds'; + mind_entry_polymorphic = mib.mind_polymorphic; + mind_entry_universes = univs + } diff --git a/toplevel/discharge.mli b/toplevel/discharge.mli index 6cef31c8a..c074a1cc8 100644 --- a/toplevel/discharge.mli +++ b/toplevel/discharge.mli @@ -12,4 +12,4 @@ open Entries open Opaqueproof val process_inductive : - named_context -> work_list -> mutual_inductive_body -> mutual_inductive_entry + named_context Univ.in_universe_context -> work_list -> mutual_inductive_body -> mutual_inductive_entry diff --git a/toplevel/himsg.ml b/toplevel/himsg.ml index fd74f9c06..9d6e9756d 100644 --- a/toplevel/himsg.ml +++ b/toplevel/himsg.ml @@ -65,7 +65,7 @@ let contract3' env a b c = function contract3 env a b c, ConversionFailed (env',t1,t2) | NotSameArgSize | NotSameHead | NoCanonicalStructure | MetaOccurInBody _ | InstanceNotSameType _ - | UnifUnivInconsistency as x -> contract3 env a b c, x + | UnifUnivInconsistency _ as x -> contract3 env a b c, x (** Printers *) @@ -143,9 +143,15 @@ let rec pr_disjunction pr = function | a::l -> pr a ++ str "," ++ spc () ++ pr_disjunction pr l | [] -> assert false +let pr_puniverses f env (c,u) = + f env c ++ + (if Flags.is_universe_polymorphism () && not (Univ.Instance.is_empty u) then + str"(*" ++ Univ.Instance.pr u ++ str"*)" + else mt()) + let explain_elim_arity env ind sorts c pj okinds = let env = make_all_name_different env in - let pi = pr_inductive env ind in + let pi = pr_inductive env (fst ind) in let pc = pr_lconstr_env env c in let msg = match okinds with | Some(kp,ki,explanation) -> @@ -200,14 +206,14 @@ let explain_number_branches env sigma cj expn = str "expects " ++ int expn ++ str " branches." let explain_ill_formed_branch env sigma c ci actty expty = - let simp t = Reduction.nf_betaiota (Evarutil.nf_evar sigma t) in + let simp t = Reduction.nf_betaiota env (Evarutil.nf_evar sigma t) in let c = Evarutil.nf_evar sigma c in let env = make_all_name_different env in let pc = pr_lconstr_env env c in let pa, pe = pr_explicit env (simp actty) (simp expty) in strbrk "In pattern-matching on term" ++ brk(1,1) ++ pc ++ spc () ++ strbrk "the branch for constructor" ++ spc () ++ - quote (pr_constructor env ci) ++ + quote (pr_puniverses pr_constructor env ci) ++ spc () ++ str "has type" ++ brk(1,1) ++ pa ++ spc () ++ str "which should be" ++ brk(1,1) ++ pe ++ str "." @@ -260,8 +266,12 @@ let explain_unification_error env sigma p1 p2 = function quote (pr_existential_key evk) ++ str ":" ++ spc () ++ str "cannot unify" ++ t ++ spc () ++ str "and" ++ spc () ++ u ++ str ")" - | UnifUnivInconsistency -> - spc () ++ str "(Universe inconsistency)" + | UnifUnivInconsistency p -> + if !Constrextern.print_universes then + spc () ++ str "(Universe inconsistency: " ++ + Univ.explain_universe_inconsistency p ++ str")" + else + spc () ++ str "(Universe inconsistency)" let explain_actual_type env sigma j t reason = let env = make_all_name_different env in @@ -513,7 +523,7 @@ let explain_var_not_found env id = spc () ++ str "was not found" ++ spc () ++ str "in the current" ++ spc () ++ str "environment" ++ str "." -let explain_wrong_case_info env ind ci = +let explain_wrong_case_info env (ind,u) ci = let pi = pr_inductive (Global.env()) ind in if eq_ind ci.ci_ind ind then str "Pattern-matching expression on an object of inductive type" ++ @@ -584,6 +594,10 @@ let explain_non_linear_unification env m t = strbrk " which would require to abstract twice on " ++ pr_lconstr_env env t ++ str "." +let explain_unsatisfied_constraints env cst = + strbrk "Unsatisfied constraints: " ++ Univ.pr_constraints cst ++ + spc () ++ str "(maybe a bugged tactic)." + let explain_type_error env sigma err = let env = make_all_name_different env in match err with @@ -619,6 +633,8 @@ let explain_type_error env sigma err = explain_ill_typed_rec_body env sigma i lna vdefj vargs | WrongCaseInfo (ind,ci) -> explain_wrong_case_info env ind ci + | UnsatisfiedConstraints cst -> + explain_unsatisfied_constraints env cst let explain_pretype_error env sigma err = let env = Evarutil.env_nf_betaiotaevar sigma env in @@ -998,7 +1014,7 @@ let error_not_allowed_case_analysis isrec kind i = str (if isrec then "Induction" else "Case analysis") ++ strbrk " on sort " ++ pr_sort kind ++ strbrk " is not allowed for inductive definition " ++ - pr_inductive (Global.env()) i ++ str "." + pr_inductive (Global.env()) (fst i) ++ str "." let error_not_mutual_in_scheme ind ind' = if eq_ind ind ind' then diff --git a/toplevel/ind_tables.ml b/toplevel/ind_tables.ml index f5ee027f1..2a408e03d 100644 --- a/toplevel/ind_tables.ml +++ b/toplevel/ind_tables.ml @@ -27,13 +27,18 @@ open Decl_kinds (**********************************************************************) (* Registering schemes in the environment *) -type mutual_scheme_object_function = mutual_inductive -> constr array * Declareops.side_effects -type individual_scheme_object_function = inductive -> constr * Declareops.side_effects + +type mutual_scheme_object_function = + mutual_inductive -> constr array Evd.in_evar_universe_context * Declareops.side_effects +type individual_scheme_object_function = + inductive -> constr Evd.in_evar_universe_context * Declareops.side_effects type 'a scheme_kind = string let scheme_map = Summary.ref Indmap.empty ~name:"Schemes" +let pr_scheme_kind = Pp.str + let cache_one_scheme kind (ind,const) = let map = try Indmap.find ind !scheme_map with Not_found -> String.Map.empty in scheme_map := Indmap.add ind (String.Map.add kind const map) !scheme_map @@ -41,9 +46,9 @@ let cache_one_scheme kind (ind,const) = let cache_scheme (_,(kind,l)) = Array.iter (cache_one_scheme kind) l -let subst_one_scheme subst ((mind,i),const) = +let subst_one_scheme subst (ind,const) = (* Remark: const is a def: the result of substitution is a constant *) - ((subst_ind subst mind,i),fst (subst_con subst const)) + (subst_ind subst ind,subst_constant subst const) let subst_scheme (subst,(kind,l)) = (kind,Array.map (subst_one_scheme subst) l) @@ -67,8 +72,8 @@ type individual type mutual type scheme_object_function = - | MutualSchemeFunction of (mutual_inductive -> constr array * Declareops.side_effects) - | IndividualSchemeFunction of (inductive -> constr * Declareops.side_effects) + | MutualSchemeFunction of mutual_scheme_object_function + | IndividualSchemeFunction of individual_scheme_object_function let scheme_object_table = (Hashtbl.create 17 : (string, string * scheme_object_function) Hashtbl.t) @@ -111,31 +116,37 @@ let compute_name internal id = | KernelSilent -> Namegen.next_ident_away_from (add_prefix "internal_" id) is_visible_name -let define internal id c = +let define internal id c p univs = let fd = declare_constant ~internal in let id = compute_name internal id in + let ctx = Evd.normalize_evar_universe_context univs in + let c = Vars.subst_univs_fn_constr + (Universes.make_opt_subst (Evd.evar_universe_context_subst ctx)) c in let entry = { const_entry_body = Future.from_val (c,Declareops.no_seff); const_entry_secctx = None; const_entry_type = None; + const_entry_proj = None; + const_entry_polymorphic = p; + const_entry_universes = Evd.evar_context_universe_context ctx; const_entry_opaque = false; const_entry_inline_code = false; const_entry_feedback = None; } in let kn = fd id (DefinitionEntry entry, Decl_kinds.IsDefinition Scheme) in let () = match internal with - | KernelSilent -> () - | _-> definition_message id + | KernelSilent -> () + | _-> definition_message id in kn let define_individual_scheme_base kind suff f internal idopt (mind,i as ind) = - let c, eff = f ind in + let (c, ctx), eff = f ind in let mib = Global.lookup_mind mind in let id = match idopt with | Some id -> id | None -> add_suffix mib.mind_packets.(i).mind_typename suff in - let const = define internal id c in + let const = define internal id c mib.mind_polymorphic ctx in declare_scheme kind [|ind,const|]; const, Declareops.cons_side_effects (Safe_typing.sideff_of_scheme kind (Global.safe_env()) [ind,const]) eff @@ -147,12 +158,14 @@ let define_individual_scheme kind internal names (mind,i as ind) = define_individual_scheme_base kind s f internal names ind let define_mutual_scheme_base kind suff f internal names mind = - let cl, eff = f mind in + let (cl, ctx), eff = f mind in let mib = Global.lookup_mind mind in let ids = Array.init (Array.length mib.mind_packets) (fun i -> try Int.List.assoc i names with Not_found -> add_suffix mib.mind_packets.(i).mind_typename suff) in - let consts = Array.map2 (define internal) ids cl in + + let consts = Array.map2 (fun id cl -> + define internal id cl mib.mind_polymorphic ctx) ids cl in let schemes = Array.mapi (fun i cst -> ((mind,i),cst)) consts in declare_scheme kind schemes; consts, @@ -185,4 +198,3 @@ let find_scheme kind (mind,i as ind) = let check_scheme kind ind = try let _ = find_scheme_on_env_too kind ind in true with Not_found -> false - diff --git a/toplevel/ind_tables.mli b/toplevel/ind_tables.mli index d57f1556d..7f84843a9 100644 --- a/toplevel/ind_tables.mli +++ b/toplevel/ind_tables.mli @@ -19,9 +19,9 @@ type individual type 'a scheme_kind type mutual_scheme_object_function = - mutual_inductive -> constr array * Declareops.side_effects + mutual_inductive -> constr array Evd.in_evar_universe_context * Declareops.side_effects type individual_scheme_object_function = - inductive -> constr * Declareops.side_effects + inductive -> constr Evd.in_evar_universe_context * Declareops.side_effects (** Main functions to register a scheme builder *) @@ -49,3 +49,6 @@ val define_mutual_scheme : mutual scheme_kind -> Declare.internal_flag (** inter val find_scheme : 'a scheme_kind -> inductive -> constant * Declareops.side_effects val check_scheme : 'a scheme_kind -> inductive -> bool + + +val pr_scheme_kind : 'a scheme_kind -> Pp.std_ppcmds diff --git a/toplevel/indschemes.ml b/toplevel/indschemes.ml index 2cc98feea..c139f1910 100644 --- a/toplevel/indschemes.ml +++ b/toplevel/indschemes.ml @@ -113,13 +113,16 @@ let _ = (* Util *) -let define id internal c t = +let define id internal ctx c t = let f = declare_constant ~internal in let kn = f id (DefinitionEntry { const_entry_body = c; const_entry_secctx = None; const_entry_type = t; + const_entry_proj = None; + const_entry_polymorphic = true; + const_entry_universes = Evd.universe_context ctx; (* FIXME *) const_entry_opaque = false; const_entry_inline_code = false; const_entry_feedback = None; @@ -292,6 +295,7 @@ let declare_sym_scheme ind = (* Scheme command *) +let smart_global_inductive y = smart_global_inductive y let rec split_scheme l = let env = Global.env() in match l with @@ -311,7 +315,7 @@ requested let names inds recs isdep y z = let ind = smart_global_inductive y in let sort_of_ind = inductive_sort_family (snd (lookup_mind_specif env ind)) in - let z' = family_of_sort (interp_sort z) in + let z' = interp_elimination_sort z in let suffix = ( match sort_of_ind with | InProp -> @@ -345,19 +349,20 @@ requested let do_mutual_induction_scheme lnamedepindsort = let lrecnames = List.map (fun ((_,f),_,_,_) -> f) lnamedepindsort - and sigma = Evd.empty and env0 = Global.env() in - let lrecspec = - List.map - (fun (_,dep,ind,sort) -> (ind,dep,interp_elimination_sort sort)) - lnamedepindsort + let sigma, lrecspec = + List.fold_left + (fun (evd, l) (_,dep,ind,sort) -> + let evd, indu = Evd.fresh_inductive_instance env0 evd ind in + (evd, (indu,dep,interp_elimination_sort sort) :: l)) + (Evd.from_env env0,[]) lnamedepindsort in - let listdecl = Indrec.build_mutual_induction_scheme env0 sigma lrecspec in + let sigma, listdecl = Indrec.build_mutual_induction_scheme env0 sigma lrecspec in let declare decl fi lrecref = - let decltype = Retyping.get_type_of env0 Evd.empty decl in - let decltype = refresh_universes decltype in + let decltype = Retyping.get_type_of env0 sigma decl in + (* let decltype = refresh_universes decltype in *) let proof_output = Future.from_val (decl,Declareops.no_seff) in - let cst = define fi UserVerbose proof_output (Some decltype) in + let cst = define fi UserVerbose sigma proof_output (Some decltype) in ConstRef cst :: lrecref in let _ = List.fold_right2 declare listdecl lrecnames [] in @@ -407,7 +412,9 @@ let fold_left' f = function | hd :: tl -> List.fold_left f hd tl let build_combined_scheme env schemes = - let defs = List.map (fun cst -> (cst, Typeops.type_of_constant env cst)) schemes in + let defs = List.map (fun cst -> (* FIXME *) + let evd, c = Evd.fresh_constant_instance env Evd.empty cst in + (c, Typeops.type_of_constant_in env c)) schemes in (* let nschemes = List.length schemes in *) let find_inductive ty = let (ctx, arity) = decompose_prod ty in @@ -415,7 +422,7 @@ let build_combined_scheme env schemes = match kind_of_term last with | App (ind, args) -> let ind = destInd ind in - let (_,spec) = Inductive.lookup_mind_specif env ind in + let (_,spec) = Inductive.lookup_mind_specif env (fst ind) in ctx, ind, spec.mind_nrealargs | _ -> ctx, destInd last, 0 in @@ -426,8 +433,8 @@ let build_combined_scheme env schemes = let coqand = Coqlib.build_coq_and () and coqconj = Coqlib.build_coq_conj () in let relargs = rel_vect 0 prods in let concls = List.rev_map - (fun (cst, t) -> - mkApp(mkConst cst, relargs), + (fun (cst, t) -> (* FIXME *) + mkApp(mkConstU cst, relargs), snd (decompose_prod_n prods t)) defs in let concl_bod, concl_typ = fold_left' @@ -451,10 +458,9 @@ let do_combined_scheme name schemes = with Not_found -> error ((string_of_qualid (snd qualid))^" is not declared.")) schemes in - let env = Global.env () in - let body,typ = build_combined_scheme env csts in + let body,typ = build_combined_scheme (Global.env ()) csts in let proof_output = Future.from_val (body,Declareops.no_seff) in - ignore (define (snd name) UserVerbose proof_output (Some typ)); + ignore (define (snd name) UserVerbose Evd.empty proof_output (Some typ)); fixpoint_message None [snd name] (**********************************************************************) @@ -464,7 +470,7 @@ let map_inductive_block f kn n = for i=0 to n-1 do f (kn,i) done let declare_default_schemes kn = let mib = Global.lookup_mind kn in let n = Array.length mib.mind_packets in - if !elim_flag && (not mib.mind_record || !record_elim_flag) then + if !elim_flag && (mib.mind_record = None || !record_elim_flag) then declare_induction_schemes kn; if !case_flag then map_inductive_block declare_one_case_analysis_scheme kn n; if is_eq_flag() then try_declare_beq_scheme kn; diff --git a/toplevel/metasyntax.ml b/toplevel/metasyntax.ml index 761f9c214..3b86cf72f 100644 --- a/toplevel/metasyntax.ml +++ b/toplevel/metasyntax.ml @@ -1269,7 +1269,7 @@ let add_notation local c ((loc,df),modifiers) sc = (* Infix notations *) -let inject_var x = CRef (Ident (Loc.ghost, Id.of_string x)) +let inject_var x = CRef (Ident (Loc.ghost, Id.of_string x),None) let add_infix local ((loc,inf),modifiers) pr sc = check_infix_modifiers modifiers; @@ -1323,7 +1323,7 @@ let add_class_scope scope cl = (* Check if abbreviation to a name and avoid early insertion of maximal implicit arguments *) let try_interp_name_alias = function - | [], CRef ref -> intern_reference ref + | [], CRef (ref,_) -> intern_reference ref | _ -> raise Not_found let add_syntactic_definition ident (vars,c) local onlyparse = diff --git a/toplevel/obligations.ml b/toplevel/obligations.ml index d772af3c1..d937c400a 100644 --- a/toplevel/obligations.ml +++ b/toplevel/obligations.ml @@ -21,7 +21,7 @@ open Pp open Errors open Util -let declare_fix_ref = ref (fun _ _ _ _ _ -> assert false) +let declare_fix_ref = ref (fun _ _ _ _ _ _ -> assert false) let declare_definition_ref = ref (fun _ _ _ _ _ -> assert false) let trace s = @@ -298,11 +298,15 @@ type obligation_info = (Names.Id.t * Term.types * Evar_kinds.t Loc.located * Evar_kinds.obligation_definition_status * Int.Set.t * unit Proofview.tactic option) array +type 'a obligation_body = + | DefinedObl of 'a + | TermObl of constr + type obligation = { obl_name : Id.t; obl_type : types; obl_location : Evar_kinds.t Loc.located; - obl_body : constr option; + obl_body : constant obligation_body option; obl_status : Evar_kinds.obligation_definition_status; obl_deps : Int.Set.t; obl_tac : unit Proofview.tactic option; @@ -320,6 +324,8 @@ type program_info = { prg_name: Id.t; prg_body: constr; prg_type: constr; + prg_ctx: Univ.universe_context_set; + prg_subst : Universes.universe_opt_subst; prg_obligations: obligations; prg_deps : Id.t list; prg_fixkind : fixpoint_kind option ; @@ -383,27 +389,43 @@ let _ = let evar_of_obligation o = make_evar (Global.named_context_val ()) o.obl_type -let get_obligation_body expand obl = - let c = Option.get obl.obl_body in +let get_body subst obl = + match obl.obl_body with + | None -> assert false + | Some (DefinedObl c) -> + let _, ctx = Environ.constant_type_in_ctx (Global.env ()) c in + let pc = subst_univs_fn_puniverses (Univ.level_subst_of subst) (c, Univ.UContext.instance ctx) in + DefinedObl pc + | Some (TermObl c) -> + TermObl (subst_univs_fn_constr subst c) + +let get_obligation_body expand subst obl = + let c = get_body subst obl in + let c' = if expand && obl.obl_status == Evar_kinds.Expand then - match kind_of_term c with - | Const c -> constant_value (Global.env ()) c - | _ -> c - else c - -let obl_substitution expand obls deps = + (match c with + | DefinedObl pc -> constant_value_in (Global.env ()) pc + | TermObl c -> c) + else (match c with + | DefinedObl pc -> mkConstU pc + | TermObl c -> c) + in c' + +let obl_substitution expand subst obls deps = Int.Set.fold (fun x acc -> let xobl = obls.(x) in let oblb = - try get_obligation_body expand xobl + try get_obligation_body expand subst xobl with e when Errors.noncritical e -> assert false in (xobl.obl_name, (xobl.obl_type, oblb)) :: acc) deps [] -let subst_deps expand obls deps t = - let subst = obl_substitution expand obls deps in - Vars.replace_vars (List.map (fun (n, (_, b)) -> n, b) subst) t +let subst_deps expand subst obls deps t = + let subst = Universes.make_opt_subst subst in + let osubst = obl_substitution expand subst obls deps in + Vars.subst_univs_fn_constr subst + (Vars.replace_vars (List.map (fun (n, (_, b)) -> n, b) osubst) t) let rec prod_app t n = match kind_of_term (strip_outer_cast t) with @@ -431,17 +453,18 @@ let replace_appvars subst = in map_constr aux let subst_prog expand obls ints prg = - let subst = obl_substitution expand obls ints in + let usubst = Universes.make_opt_subst prg.prg_subst in + let subst = obl_substitution expand usubst obls ints in if get_hide_obligations () then (replace_appvars subst prg.prg_body, - replace_appvars subst (Termops.refresh_universes prg.prg_type)) + replace_appvars subst ((* Termops.refresh_universes *) prg.prg_type)) else let subst' = List.map (fun (n, (_, b)) -> n, b) subst in (Vars.replace_vars subst' prg.prg_body, - Vars.replace_vars subst' (Termops.refresh_universes prg.prg_type)) + Vars.replace_vars subst' ((* Termops.refresh_universes *) prg.prg_type)) -let subst_deps_obl obls obl = - let t' = subst_deps true obls obl.obl_deps obl.obl_type in +let subst_deps_obl subst obls obl = + let t' = subst_deps true subst obls obl.obl_deps obl.obl_type in { obl with obl_type = t' } module ProgMap = Map.Make(Id) @@ -509,6 +532,9 @@ let declare_definition prg = { const_entry_body = Future.from_val (body,Declareops.no_seff); const_entry_secctx = None; const_entry_type = Some typ; + const_entry_proj = None; + const_entry_polymorphic = pi2 prg.prg_kind; + const_entry_universes = Univ.ContextSet.to_context prg.prg_ctx; const_entry_opaque = false; const_entry_inline_code = false; const_entry_feedback = None; @@ -556,10 +582,9 @@ let declare_mutual_definition l = let fixkind = Option.get first.prg_fixkind in let arrrec, recvec = Array.of_list fixtypes, Array.of_list fixdefs in let fixdecls = (Array.of_list (List.map (fun x -> Name x.prg_name) l), arrrec, recvec) in + let (local,poly,kind) = first.prg_kind in let fixnames = first.prg_deps in - let kind = - fst first.prg_kind, - if fixkind != IsCoFixpoint then Fixpoint else CoFixpoint in + let kind = if fixkind != IsCoFixpoint then Fixpoint else CoFixpoint in let indexes, fixdecls = match fixkind with | IsFixpoint wfl -> @@ -578,13 +603,15 @@ let declare_mutual_definition l = mkCoFix (i,fixdecls),Declareops.no_seff) 0 l in (* Declare the recursive definitions *) - let kns = List.map4 (!declare_fix_ref kind) fixnames fixdecls fixtypes fiximps in + let ctx = Univ.ContextSet.to_context first.prg_ctx in + let kns = List.map4 (!declare_fix_ref (local, poly, kind) ctx) + fixnames fixdecls fixtypes fiximps in (* Declare notations *) List.iter Metasyntax.add_notation_interpretation first.prg_notations; Declare.recursive_message (fixkind != IsCoFixpoint) indexes fixnames; let gr = List.hd kns in let kn = match gr with ConstRef kn -> kn | _ -> assert false in - first.prg_hook (fst first.prg_kind) gr; + first.prg_hook local gr; List.iter progmap_remove l; kn let shrink_body c = @@ -597,20 +624,25 @@ let shrink_body c = (b, 1, []) ctx in List.map (fun (c,t) -> (c,None,t)) ctx, b', Array.of_list args -let declare_obligation prg obl body = +let declare_obligation prg obl body uctx = let body = prg.prg_reduce body in let ty = prg.prg_reduce obl.obl_type in match obl.obl_status with - | Evar_kinds.Expand -> { obl with obl_body = Some body } + | Evar_kinds.Expand -> { obl with obl_body = Some (TermObl body) } | Evar_kinds.Define opaque -> let opaque = if get_proofs_transparency () then false else opaque in + let poly = pi2 prg.prg_kind in let ctx, body, args = - if get_shrink_obligations () then shrink_body body else [], body, [||] + if get_shrink_obligations () && not poly then + shrink_body body else [], body, [||] in let ce = { const_entry_body = Future.from_val(body,Declareops.no_seff); const_entry_secctx = None; const_entry_type = if List.is_empty ctx then Some ty else None; + const_entry_proj = None; + const_entry_polymorphic = poly; + const_entry_universes = uctx; const_entry_opaque = opaque; const_entry_inline_code = false; const_entry_feedback = None; @@ -623,9 +655,13 @@ let declare_obligation prg obl body = Auto.add_hints false [Id.to_string prg.prg_name] (Auto.HintsUnfoldEntry [EvalConstRef constant]); definition_message obl.obl_name; - { obl with obl_body = Some (it_mkLambda_or_LetIn (mkApp (mkConst constant, args)) ctx) } + { obl with obl_body = + if poly then + Some (DefinedObl constant) + else + Some (TermObl (it_mkLambda_or_LetIn (mkApp (mkConst constant, args)) ctx)) } -let init_prog_info n b t deps fixkind notations obls impls k reduce hook = +let init_prog_info n b t ctx deps fixkind notations obls impls kind reduce hook = let obls', b = match b with | None -> @@ -645,9 +681,10 @@ let init_prog_info n b t deps fixkind notations obls impls k reduce hook = obls, b in { prg_name = n ; prg_body = b; prg_type = reduce t; + prg_ctx = ctx; prg_subst = Univ.LMap.empty; prg_obligations = (obls', Array.length obls'); prg_deps = deps; prg_fixkind = fixkind ; prg_notations = notations ; - prg_implicits = impls; prg_kind = k; prg_reduce = reduce; + prg_implicits = impls; prg_kind = kind; prg_reduce = reduce; prg_hook = hook; } let get_prog name = @@ -734,14 +771,14 @@ let dependencies obls n = obls; !res -let goal_kind = Decl_kinds.Local, Decl_kinds.DefinitionBody Decl_kinds.Definition +let goal_kind poly = Decl_kinds.Local, poly, Decl_kinds.DefinitionBody Decl_kinds.Definition -let goal_proof_kind = Decl_kinds.Local, Decl_kinds.Proof Decl_kinds.Lemma +let goal_proof_kind poly = Decl_kinds.Local, poly, Decl_kinds.Proof Decl_kinds.Lemma -let kind_of_opacity o = +let kind_of_obligation poly o = match o with - | Evar_kinds.Define false | Evar_kinds.Expand -> goal_kind - | _ -> goal_proof_kind + | Evar_kinds.Define false | Evar_kinds.Expand -> goal_kind poly + | _ -> goal_proof_kind poly let not_transp_msg = str "Obligation should be transparent but was declared opaque." ++ spc () ++ @@ -755,17 +792,37 @@ let rec string_of_list sep f = function | x :: ((y :: _) as tl) -> f x ^ sep ^ string_of_list sep f tl (* Solve an obligation using tactics, return the corresponding proof term *) -let solve_by_tac evi t = + +let solve_by_tac evi t poly subst ctx = let id = Id.of_string "H" in + let concl = Universes.subst_opt_univs_constr subst evi.evar_concl in (* spiwack: the status is dropped *) - let (entry,_) = Pfedit.build_constant_by_tactic - id ~goal_kind evi.evar_hyps evi.evar_concl (Tacticals.New.tclCOMPLETE t) in + let (entry,_,subst) = Pfedit.build_constant_by_tactic + id ~goal_kind:(goal_kind poly) evi.evar_hyps (concl, ctx) (Tacticals.New.tclCOMPLETE t) in let env = Global.env () in let entry = Term_typing.handle_side_effects env entry in let body, eff = Future.force entry.Entries.const_entry_body in assert(Declareops.side_effects_is_empty eff); Inductiveops.control_only_guard (Global.env ()) body; - body + body, subst, entry.Entries.const_entry_universes + + (* try *) + (* let substref = ref (Univ.LMap.empty, Univ.UContext.empty) in *) + (* Pfedit.start_proof id (goal_kind poly) evi.evar_hyps *) + (* (Universes.subst_opt_univs_constr subst evi.evar_concl, ctx) *) + (* (fun subst-> substref:=subst; fun _ _ -> ()); *) + (* Pfedit.by (tclCOMPLETE t); *) + (* let _,(const,_,_,_) = Pfedit.cook_proof ignore in *) + (* Pfedit.delete_current_proof (); *) + (* Inductiveops.control_only_guard (Global.env ()) *) + (* const.Entries.const_entry_body; *) + (* let subst, ctx = !substref in *) + (* subst_univs_fn_constr (Universes.make_opt_subst subst) const.Entries.const_entry_body, *) + (* subst, const.Entries.const_entry_universes *) + (* with reraise -> *) + (* let reraise = Errors.push reraise in *) + (* Pfedit.delete_current_proof(); *) + (* raise reraise *) let rec solve_obligation prg num tac = let user_num = succ num in @@ -776,9 +833,12 @@ let rec solve_obligation prg num tac = else match deps_remaining obls obl.obl_deps with | [] -> - let obl = subst_deps_obl obls obl in - Lemmas.start_proof obl.obl_name (kind_of_opacity obl.obl_status) obl.obl_type - (fun strength gr -> + let ctx = prg.prg_ctx in + let obl = subst_deps_obl prg.prg_subst obls obl in + let kind = kind_of_obligation (pi2 prg.prg_kind) obl.obl_status in + Lemmas.start_proof obl.obl_name kind + (Universes.subst_opt_univs_constr prg.prg_subst obl.obl_type, ctx) + (fun strength gr -> let cst = match gr with ConstRef cst -> cst | _ -> assert false in let obl = let transparent = evaluable_constant cst (Global.env ()) in @@ -786,10 +846,10 @@ let rec solve_obligation prg num tac = match obl.obl_status with | Evar_kinds.Expand -> if not transparent then error_not_transp () - else constant_value (Global.env ()) cst + else DefinedObl cst | Evar_kinds.Define opaque -> if not opaque && not transparent then error_not_transp () - else Globnames.constr_of_global gr + else DefinedObl cst in if transparent then Auto.add_hints true [Id.to_string prg.prg_name] @@ -798,8 +858,15 @@ let rec solve_obligation prg num tac = in let obls = Array.copy obls in let _ = obls.(num) <- obl in - let res = - try update_obls prg obls (pred rem) +(* let ctx = Univ.ContextSet.of_context ctx in *) + let subst = Univ.LMap.empty (** FIXME *) in + let res = + try update_obls + {prg with prg_body = Universes.subst_opt_univs_constr subst prg.prg_body; + prg_type = Universes.subst_opt_univs_constr subst prg.prg_type; + prg_ctx = ctx; + prg_subst = Univ.LMap.union prg.prg_subst subst} + obls (pred rem) with e when Errors.noncritical e -> pperror (Errors.print (Cerrors.process_vernac_interp_error e)) in @@ -835,7 +902,7 @@ and solve_obligation_by_tac prg obls i tac = | None -> try if List.is_empty (deps_remaining obls obl.obl_deps) then - let obl = subst_deps_obl obls obl in + let obl = subst_deps_obl prg.prg_subst obls obl in let tac = match tac with | Some t -> t @@ -844,8 +911,11 @@ and solve_obligation_by_tac prg obls i tac = | Some t -> t | None -> snd (get_default_tactic ()) in - let t = solve_by_tac (evar_of_obligation obl) tac in - obls.(i) <- declare_obligation prg obl t; + let t, subst, ctx = + solve_by_tac (evar_of_obligation obl) tac + (pi2 prg.prg_kind) prg.prg_subst prg.prg_ctx + in + obls.(i) <- declare_obligation {prg with prg_subst = subst} obl t ctx; true else false with e when Errors.noncritical e -> @@ -929,10 +999,10 @@ let show_term n = Printer.pr_constr_env (Global.env ()) prg.prg_type ++ spc () ++ str ":=" ++ fnl () ++ Printer.pr_constr_env (Global.env ()) prg.prg_body) -let add_definition n ?term t ?(implicits=[]) ?(kind=Global,Definition) ?tactic +let add_definition n ?term t ctx ?(implicits=[]) ?(kind=Global,false,Definition) ?tactic ?(reduce=reduce) ?(hook=fun _ _ -> ()) obls = let info = str (Id.to_string n) ++ str " has type-checked" in - let prg = init_prog_info n term t [] None [] obls implicits kind reduce hook in + let prg = init_prog_info n term t ctx [] None [] obls implicits kind reduce hook in let obls,_ = prg.prg_obligations in if Int.equal (Array.length obls) 0 then ( Flags.if_verbose msg_info (info ++ str "."); @@ -947,12 +1017,12 @@ let add_definition n ?term t ?(implicits=[]) ?(kind=Global,Definition) ?tactic | Remain rem -> Flags.if_verbose (fun () -> show_obligations ~msg:false (Some n)) (); res | _ -> res) -let add_mutual_definitions l ?tactic ?(kind=Global,Definition) ?(reduce=reduce) +let add_mutual_definitions l ctx ?tactic ?(kind=Global,false,Definition) ?(reduce=reduce) ?(hook=fun _ _ -> ()) notations fixkind = let deps = List.map (fun (n, b, t, imps, obls) -> n) l in List.iter (fun (n, b, t, imps, obls) -> - let prg = init_prog_info n (Some b) t deps (Some fixkind) + let prg = init_prog_info n (Some b) t ctx deps (Some fixkind) notations obls imps kind reduce hook in progmap_add n prg) l; let _defined = @@ -975,13 +1045,13 @@ let admit_prog prg = (fun i x -> match x.obl_body with | None -> - let x = subst_deps_obl obls x in - (** ppedrot: seems legit to have admitted obligations as local *) + let x = subst_deps_obl prg.prg_subst obls x in + let ctx = Univ.ContextSet.to_context prg.prg_ctx in let kn = Declare.declare_constant x.obl_name ~local:true - (ParameterEntry (None, x.obl_type,None), IsAssumption Conjectural) + (ParameterEntry (None,false,(x.obl_type,ctx),None), IsAssumption Conjectural) in assumption_message x.obl_name; - obls.(i) <- { x with obl_body = Some (mkConst kn) } + obls.(i) <- { x with obl_body = Some (DefinedObl kn) } | Some _ -> ()) obls; ignore(update_obls prg obls 0) diff --git a/toplevel/obligations.mli b/toplevel/obligations.mli index 746b4ed14..f03e6c446 100644 --- a/toplevel/obligations.mli +++ b/toplevel/obligations.mli @@ -17,7 +17,7 @@ open Decl_kinds open Tacexpr (** Forward declaration. *) -val declare_fix_ref : (definition_kind -> Id.t -> +val declare_fix_ref : (definition_kind -> Univ.universe_context -> Id.t -> Entries.proof_output -> types -> Impargs.manual_implicits -> global_reference) ref val declare_definition_ref : @@ -64,6 +64,7 @@ val set_proofs_transparency : bool -> unit (* true = All transparent, false = Op val get_proofs_transparency : unit -> bool val add_definition : Names.Id.t -> ?term:Term.constr -> Term.types -> + Univ.universe_context_set -> ?implicits:(Constrexpr.explicitation * (bool * bool * bool)) list -> ?kind:Decl_kinds.definition_kind -> ?tactic:unit Proofview.tactic -> @@ -80,6 +81,7 @@ type fixpoint_kind = val add_mutual_definitions : (Names.Id.t * Term.constr * Term.types * (Constrexpr.explicitation * (bool * bool * bool)) list * obligation_info) list -> + Univ.universe_context_set -> ?tactic:unit Proofview.tactic -> ?kind:Decl_kinds.definition_kind -> ?reduce:(Term.constr -> Term.constr) -> diff --git a/toplevel/record.ml b/toplevel/record.ml index dc38d2519..7411a6377 100644 --- a/toplevel/record.ml +++ b/toplevel/record.ml @@ -13,6 +13,7 @@ open Names open Globnames open Nameops open Term +open Context open Vars open Environ open Declarations @@ -23,9 +24,21 @@ open Decl_kinds open Type_errors open Constrexpr open Constrexpr_ops +open Goptions (********** definition d'un record (structure) **************) +(** Flag governing use of primitive projections. Disabled by default. *) +let primitive_flag = ref false +let _ = + declare_bool_option + { optsync = true; + optdepr = false; + optname = "use of primitive projections"; + optkey = ["Primitive";"Projections"]; + optread = (fun () -> !primitive_flag) ; + optwrite = (fun b -> primitive_flag := b) } + let interp_fields_evars evars env impls_env nots l = List.fold_left2 (fun (env, uimpls, params, impls) no ((loc, i), b, t) -> @@ -41,15 +54,25 @@ let interp_fields_evars evars env impls_env nots l = (push_rel d env, impl :: uimpls, d::params, impls)) (env, [], [], impls_env) nots l +let compute_constructor_level evars env l = + List.fold_right (fun (n,b,t as d) (env, univ) -> + let univ = + if b = None then + let s = Retyping.get_sort_of env evars t in + Univ.sup (univ_of_sort s) univ + else univ + in (push_rel d env, univ)) + l (env, Univ.type0m_univ) + let binder_of_decl = function | Vernacexpr.AssumExpr(n,t) -> (n,None,t) | Vernacexpr.DefExpr(n,c,t) -> (n,Some c, match t with Some c -> c | None -> CHole (fst n, None, None)) let binders_of_decls = List.map binder_of_decl -let typecheck_params_and_fields id t ps nots fs = +let typecheck_params_and_fields def id t ps nots fs = let env0 = Global.env () in - let evars = ref Evd.empty in + let evars = ref (Evd.from_env ~ctx:(Univ.ContextSet.empty) env0) in let _ = let error bk (loc, name) = match bk, name with @@ -62,15 +85,48 @@ let typecheck_params_and_fields id t ps nots fs = | LocalRawAssum (ls, bk, ce) -> List.iter (error bk) ls) ps in let impls_env, ((env1,newps), imps) = interp_context_evars evars env0 ps in - let fullarity = it_mkProd_or_LetIn (Option.cata (fun x -> x) (Termops.new_Type ()) t) newps in + let t' = match t with + | Some t -> + let env = push_rel_context newps env0 in + let s = interp_type_evars evars env ~impls:empty_internalization_env t in + let sred = Reductionops.whd_betadeltaiota env !evars s in + (match kind_of_term sred with + | Sort s' -> + (match Evd.is_sort_variable !evars s' with + | Some (l, _) -> evars := Evd.make_flexible_variable !evars true (* (not def) *) l; sred + | None -> s) + | _ -> user_err_loc (constr_loc t,"", str"Sort expected.")) + | None -> + let uvarkind = if (* not def *) true then Evd.univ_flexible_alg else Evd.univ_flexible in + mkSort (Evarutil.evd_comb0 (Evd.new_sort_variable uvarkind) evars) + in + let fullarity = it_mkProd_or_LetIn t' newps in let env_ar = push_rel_context newps (push_rel (Name id,None,fullarity) env0) in let env2,impls,newfs,data = interp_fields_evars evars env_ar impls_env nots (binders_of_decls fs) in - let sigma = Pretyping.solve_remaining_evars Pretyping.all_and_fail_flags env_ar Evd.empty !evars in - let newps = Evarutil.nf_rel_context_evar sigma newps in - let newfs = Evarutil.nf_rel_context_evar sigma newfs in - imps, newps, impls, newfs + let sigma = + Pretyping.solve_remaining_evars Pretyping.all_and_fail_flags env_ar Evd.empty !evars in + let evars, nf = Evarutil.nf_evars_and_universes sigma in + let arity = nf t' in + let evars = + let _, univ = compute_constructor_level evars env_ar newfs in + let aritysort = destSort arity in + if Sorts.is_prop aritysort || + (Sorts.is_set aritysort && engagement env0 = Some ImpredicativeSet) then + evars + else Evd.set_leq_sort evars (Type univ) aritysort + (* try Evarconv.the_conv_x_leq env_ar ty arity evars *) + (* with Reduction.NotConvertible -> *) + (* Pretype_errors.error_cannot_unify env_ar evars (ty, arity) *) + in + let evars, nf = Evarutil.nf_evars_and_universes evars in + let newps = map_rel_context nf newps in + let newfs = map_rel_context nf newfs in + let ce t = Evarutil.check_evars env0 Evd.empty evars t in + List.iter (fun (n, b, t) -> Option.iter ce b; ce t) (List.rev newps); + List.iter (fun (n, b, t) -> Option.iter ce b; ce t) (List.rev newfs); + Evd.universe_context evars, nf arity, imps, newps, impls, newfs let degenerate_decl (na,b,t) = let id = match na with @@ -147,21 +203,25 @@ let subst_projection fid l c = raise (NotDefinable (MissingProj (fid,List.rev !bad_projs))); c'' -let instantiate_possibly_recursive_type indsp paramdecls fields = +let instantiate_possibly_recursive_type indu paramdecls fields = let subst = List.map_i (fun i _ -> mkRel i) 1 paramdecls in - Termops.substl_rel_context (subst@[mkInd indsp]) fields + Termops.substl_rel_context (subst@[mkIndU indu]) fields (* We build projections *) let declare_projections indsp ?(kind=StructureComponent) ?name coers fieldimpls fields = let env = Global.env() in let (mib,mip) = Global.lookup_inductive indsp in let paramdecls = mib.mind_params_ctxt in - let r = mkInd indsp in + let poly = mib.mind_polymorphic and ctx = mib.mind_universes in + let u = Inductive.inductive_instance mib in + let indu = indsp, u in + let r = mkIndU (indsp,u) in let rp = applist (r, Termops.extended_rel_list 0 paramdecls) in let paramargs = Termops.extended_rel_list 1 paramdecls in (*def in [[params;x:rp]]*) let x = match name with Some n -> Name n | None -> Namegen.named_hd (Global.env()) r Anonymous in - let fields = instantiate_possibly_recursive_type indsp paramdecls fields in + let fields = instantiate_possibly_recursive_type indu paramdecls fields in let lifted_fields = Termops.lift_rel_context 1 fields in + let nfields = List.length fields in let (_,kinds,sp_projs,_) = List.fold_left3 (fun (nfi,kinds,sp_projs,subst) coe (fi,optci,ti) impls -> @@ -181,18 +241,29 @@ let declare_projections indsp ?(kind=StructureComponent) ?name coers fieldimpls let p = mkLambda (x, lift 1 rp, ccl') in let branch = it_mkLambda_or_LetIn (mkRel nfi) lifted_fields in let ci = Inductiveops.make_case_info env indsp LetStyle in - mkCase (ci, p, mkRel 1, [|branch|]) in + mkCase (ci, p, mkRel 1, [|branch|]) + in let proj = it_mkLambda_or_LetIn (mkLambda (x,rp,body)) paramdecls in let projtyp = it_mkProd_or_LetIn (mkProd (x,rp,ccl)) paramdecls in let kn = try + let projinfo = + (fst indsp, mib.mind_nparams, nfields - nfi, ccl) + in + let projinfo = + if !primitive_flag && optci = None then Some projinfo + else None + in let cie = { const_entry_body = Future.from_val (proj,Declareops.no_seff); const_entry_secctx = None; const_entry_type = Some projtyp; + const_entry_polymorphic = poly; + const_entry_universes = ctx; + const_entry_proj = projinfo; const_entry_opaque = false; const_entry_inline_code = false; const_entry_feedback = None; @@ -204,15 +275,18 @@ let declare_projections indsp ?(kind=StructureComponent) ?name coers fieldimpls with Type_errors.TypeError (ctx,te) -> raise (NotDefinable (BadTypedProj (fid,ctx,te))) in let refi = ConstRef kn in - let constr_fi = mkConst kn in Impargs.maybe_declare_manual_implicits false refi impls; if coe then begin let cl = Class.class_of_global (IndRef indsp) in - Class.try_add_new_coercion_with_source refi ~local:false ~source:cl + Class.try_add_new_coercion_with_source refi ~local:false poly ~source:cl end; - let proj_args = (*Rel 1 refers to "x"*) paramargs@[mkRel 1] in - let constr_fip = applist (constr_fi,proj_args) in - (Some kn::sp_projs, Projection constr_fip::subst) + let constr_fip = + if !primitive_flag then mkProj (kn,mkRel 1) + else + let proj_args = (*Rel 1 refers to "x"*) paramargs@[mkRel 1] in + applist (mkConstU (kn,u),proj_args) + in + (Some kn::sp_projs, Projection constr_fip::subst) with NotDefinable why -> warning_or_error coe indsp why; (None::sp_projs,NoProjection fi::subst) in @@ -238,7 +312,7 @@ let structure_signature ctx = open Typeclasses -let declare_structure finite infer id idbuild paramimpls params arity fieldimpls fields +let declare_structure finite infer poly ctx id idbuild paramimpls params arity fieldimpls fields ?(kind=StructureComponent) ?name is_coe coers sign = let nparams = List.length params and nfields = List.length fields in let args = Termops.extended_rel_list nfields params in @@ -256,20 +330,23 @@ let declare_structure finite infer id idbuild paramimpls params arity fieldimpls begin match finite with | BiFinite -> if Termops.dependent (mkRel (nparams+1)) (it_mkProd_or_LetIn mkProp fields) then - error "Records declared with the keyword Record or Structure cannot be recursive. You can, however, define recursive records using the Inductive or CoInductive command." + error ("Records declared with the keyword Record or Structure cannot be recursive." ^ + "You can, however, define recursive records using the Inductive or CoInductive command.") | _ -> () end; let mie = { mind_entry_params = List.map degenerate_decl params; mind_entry_record = true; mind_entry_finite = finite != CoFinite; - mind_entry_inds = [mie_ind] } in + mind_entry_inds = [mie_ind]; + mind_entry_polymorphic = poly; + mind_entry_universes = ctx } in let kn = Command.declare_mutual_inductive_with_eliminations KernelVerbose mie [(paramimpls,[])] in let rsp = (kn,0) in (* This is ind path of idstruc *) let cstr = (rsp,1) in let kinds,sp_projs = declare_projections rsp ~kind ?name coers fieldimpls fields in let build = ConstructRef cstr in - let () = if is_coe then Class.try_add_new_coercion build ~local:false in + let () = if is_coe then Class.try_add_new_coercion build ~local:false poly in Recordops.declare_structure(rsp,cstr,List.rev kinds,List.rev sp_projs); rsp @@ -282,43 +359,34 @@ let implicits_of_context ctx = in ExplByPos (i, explname), (true, true, true)) 1 (List.rev (Anonymous :: (List.map pi1 ctx))) -let declare_class finite def infer id idbuild paramimpls params arity fieldimpls fields +let declare_class finite def infer poly ctx id idbuild paramimpls params arity fieldimpls fields ?(kind=StructureComponent) ?name is_coe coers priorities sign = let fieldimpls = - (* Make the class and all params implicits in the projections *) - let ctx_impls = implicits_of_context params in - let len = succ (List.length params) in - List.map (fun x -> ctx_impls @ Impargs.lift_implicits len x) fieldimpls + (* Make the class implicit in the projections, and the params if applicable. *) + (* if def then *) + let len = List.length params in + let impls = implicits_of_context params in + List.map (fun x -> impls @ Impargs.lift_implicits (succ len) x) fieldimpls + (* else List.map (fun x -> (ExplByPos (1, None), (true, true, true)) :: *) + (* Impargs.lift_implicits 1 x) fieldimpls *) in let impl, projs = match fields with | [(Name proj_name, _, field)] when def -> let class_body = it_mkLambda_or_LetIn field params in - let class_type = Option.map (fun ar -> it_mkProd_or_LetIn ar params) arity in - let class_entry = - { const_entry_body = - Future.from_val (class_body,Declareops.no_seff); - const_entry_secctx = None; - const_entry_type = class_type; - const_entry_opaque = false; - const_entry_inline_code = false; - const_entry_feedback = None; - } in + let _class_type = it_mkProd_or_LetIn arity params in + let class_entry = + Declare.definition_entry (* ?types:class_type *) ~poly ~univs:ctx class_body in let cst = Declare.declare_constant (snd id) (DefinitionEntry class_entry, IsDefinition Definition) in - let inst_type = appvectc (mkConst cst) (Termops.rel_vect 0 (List.length params)) in - let proj_type = it_mkProd_or_LetIn (mkProd(Name (snd id), inst_type, lift 1 field)) params in - let proj_body = it_mkLambda_or_LetIn (mkLambda (Name (snd id), inst_type, mkRel 1)) params in - let proj_entry = - { const_entry_body = - Future.from_val (proj_body,Declareops.no_seff); - const_entry_secctx = None; - const_entry_type = Some proj_type; - const_entry_opaque = false; - const_entry_inline_code = false; - const_entry_feedback = None; - } in + let cstu = (cst, if poly then Univ.UContext.instance ctx else Univ.Instance.empty) in + let inst_type = appvectc (mkConstU cstu) (Termops.rel_vect 0 (List.length params)) in + let proj_type = + it_mkProd_or_LetIn (mkProd(Name (snd id), inst_type, lift 1 field)) params in + let proj_body = + it_mkLambda_or_LetIn (mkLambda (Name (snd id), inst_type, mkRel 1)) params in + let proj_entry = Declare.definition_entry ~types:proj_type ~poly ~univs:ctx proj_body in let proj_cst = Declare.declare_constant proj_name (DefinitionEntry proj_entry, IsDefinition Definition) in @@ -326,16 +394,20 @@ let declare_class finite def infer id idbuild paramimpls params arity fieldimpls Impargs.declare_manual_implicits false cref [paramimpls]; Impargs.declare_manual_implicits false (ConstRef proj_cst) [List.hd fieldimpls]; Classes.set_typeclass_transparency (EvalConstRef cst) false false; - let sub = match List.hd coers with Some b -> Some ((if b then Backward else Forward), List.hd priorities) | None -> None in + let sub = match List.hd coers with + | Some b -> Some ((if b then Backward else Forward), List.hd priorities) + | None -> None + in cref, [Name proj_name, sub, Some proj_cst] | _ -> let idarg = Namegen.next_ident_away (snd id) (Termops.ids_of_context (Global.env())) in - let ind = declare_structure BiFinite infer (snd id) idbuild paramimpls - params (Option.default (Termops.new_Type ()) arity) fieldimpls fields + let ind = declare_structure BiFinite infer poly ctx (snd id) idbuild paramimpls + params arity fieldimpls fields ~kind:Method ~name:idarg false (List.map (fun _ -> false) fields) sign in let coers = List.map2 (fun coe pri -> - Option.map (fun b -> if b then Backward, pri else Forward, pri) coe) + Option.map (fun b -> + if b then Backward, pri else Forward, pri) coe) coers priorities in IndRef ind, (List.map3 (fun (id, _, _) b y -> (id, b, y)) @@ -344,7 +416,7 @@ let declare_class finite def infer id idbuild paramimpls params arity fieldimpls let ctx_context = List.map (fun (na, b, t) -> match Typeclasses.class_of_constr t with - | Some (_, (cl, _)) -> Some (cl.cl_impl, true) (*List.exists (fun (_, n) -> n = na) supnames)*) + | Some (_, ((cl,_), _)) -> Some (cl.cl_impl, true) (*FIXME: ignore universes?*) | None -> None) params, params in @@ -359,19 +431,12 @@ let declare_class finite def infer id idbuild paramimpls params arity fieldimpls (* k.cl_projs coers priorities; *) add_class k; impl -let interp_and_check_sort sort = - Option.map (fun sort -> - let env = Global.env() and sigma = Evd.empty in - let s = interp_constr sigma env sort in - if isSort (Reductionops.whd_betadeltaiota env sigma s) then s - else user_err_loc (constr_loc sort,"", str"Sort expected.")) sort - open Vernacexpr (* [fs] corresponds to fields and [ps] to parameters; [coers] is a list telling if the corresponding fields must me declared as coercions or subinstances *) -let definition_structure (kind,finite,infer,(is_coe,(loc,idstruc)),ps,cfs,idbuild,s) = +let definition_structure (kind,poly,finite,infer,(is_coe,(loc,idstruc)),ps,cfs,idbuild,s) = let cfs,notations = List.split cfs in let cfs,priorities = List.split cfs in let coers,fs = List.split cfs in @@ -386,20 +451,20 @@ let definition_structure (kind,finite,infer,(is_coe,(loc,idstruc)),ps,cfs,idbuil if isnot_class && List.exists (fun opt -> not (Option.is_empty opt)) priorities then error "Priorities only allowed for type class substructures"; (* Now, younger decl in params and fields is on top *) - let sc = interp_and_check_sort s in - let implpars, params, implfs, fields = + let ctx, arity, implpars, params, implfs, fields = States.with_state_protection (fun () -> - typecheck_params_and_fields idstruc sc ps notations fs) () in + typecheck_params_and_fields (kind = Class true) idstruc s ps notations fs) () in let sign = structure_signature (fields@params) in match kind with | Class def -> - let gr = declare_class finite def infer (loc,idstruc) idbuild - implpars params sc implfs fields is_coe coers priorities sign in + let gr = declare_class finite def infer poly ctx (loc,idstruc) idbuild + implpars params arity implfs fields is_coe coers priorities sign in gr | _ -> - let arity = Option.default (Termops.new_Type ()) sc in let implfs = List.map - (fun impls -> implpars @ Impargs.lift_implicits (succ (List.length params)) impls) implfs in - let ind = declare_structure finite infer idstruc idbuild implpars params arity implfs + (fun impls -> implpars @ Impargs.lift_implicits + (succ (List.length params)) impls) implfs in + let ind = declare_structure finite infer poly ctx idstruc + idbuild implpars params arity implfs fields is_coe (List.map (fun coe -> not (Option.is_empty coe)) coers) sign in IndRef ind diff --git a/toplevel/record.mli b/toplevel/record.mli index 018366667..dac8636cb 100644 --- a/toplevel/record.mli +++ b/toplevel/record.mli @@ -14,6 +14,8 @@ open Constrexpr open Impargs open Globnames +val primitive_flag : bool ref + (** [declare_projections ref name coers params fields] declare projections of record [ref] (if allowed) using the given [name] as argument, and put them as coercions accordingly to [coers]; it returns the absolute names of projections *) @@ -24,7 +26,8 @@ val declare_projections : (Name.t * bool) list * constant option list val declare_structure : Decl_kinds.recursivity_kind -> - bool (**infer?*) -> Id.t -> Id.t -> + bool (**infer?*) -> bool (** polymorphic?*) -> Univ.universe_context -> + Id.t -> Id.t -> manual_explicitation list -> rel_context -> (** params *) constr -> (** arity *) Impargs.manual_explicitation list list -> rel_context -> (** fields *) ?kind:Decl_kinds.definition_object_kind -> ?name:Id.t -> @@ -34,6 +37,6 @@ val declare_structure : Decl_kinds.recursivity_kind -> inductive val definition_structure : - inductive_kind * Decl_kinds.recursivity_kind * bool(**infer?*)* lident with_coercion * local_binder list * + inductive_kind * Decl_kinds.polymorphic * Decl_kinds.recursivity_kind * bool(**infer?*)* lident with_coercion * local_binder list * (local_decl_expr with_instance with_priority with_notation) list * Id.t * constr_expr option -> global_reference diff --git a/toplevel/search.ml b/toplevel/search.ml index 38717850c..1535ae617 100644 --- a/toplevel/search.ml +++ b/toplevel/search.ml @@ -45,7 +45,7 @@ module SearchBlacklist = let iter_constructors indsp fn env nconstr = for i = 1 to nconstr do - let typ = Inductiveops.type_of_constructor env (indsp, i) in + let typ, _ = Inductiveops.type_of_constructor_in_ctx env (indsp, i) in fn (ConstructRef (indsp, i)) env typ done @@ -60,14 +60,15 @@ let iter_declarations (fn : global_reference -> env -> constr -> unit) = with Not_found -> (* we are in a section *) () end | "CONSTANT" -> let cst = Global.constant_of_delta_kn kn in - let typ = Typeops.type_of_constant env cst in + let typ, _ = Environ.constant_type_in_ctx env cst in fn (ConstRef cst) env typ | "INDUCTIVE" -> let mind = Global.mind_of_delta_kn kn in let mib = Global.lookup_mind mind in let iter_packet i mip = let ind = (mind, i) in - let typ = Inductiveops.type_of_inductive env ind in + let i = (ind, Univ.UContext.instance mib.mind_universes) in + let typ = Inductiveops.type_of_inductive env i in let () = fn (IndRef ind) env typ in let len = Array.length mip.mind_user_lc in iter_constructors ind fn env len diff --git a/toplevel/usage.ml b/toplevel/usage.ml index 73a509577..9851cfe87 100644 --- a/toplevel/usage.ml +++ b/toplevel/usage.ml @@ -66,6 +66,7 @@ let print_usage_channel co command = \n -dump-glob f dump globalizations in file f (to be used by coqdoc)\ \n -with-geoproof (yes|no) to (de)activate special functions for Geoproof within Coqide (default is yes)\ \n -impredicative-set set sort Set impredicative\ +\n -indices-matter levels of indices (and nonuniform parameters) contribute to the level of inductives\ \n -force-load-proofs load opaque proofs in memory initially\ \n -lazy-load-proofs load opaque proofs in memory by necessity (default)\ diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index d5559f976..2e9bfedc7 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -252,11 +252,7 @@ let print_namespace ns = print_list pr_id qn in let print_constant k body = - let t = - match body.Declarations.const_type with - | Declarations.PolymorphicArity (ctx,a) -> mkArity (ctx, Term.Type a.Declarations.poly_level) - | Declarations.NonPolymorphicType t -> t - in + let t = body.Declarations.const_type in print_kn k ++ str":" ++ spc() ++ Printer.pr_type t in let matches mp = match match_modulepath ns mp with @@ -457,22 +453,22 @@ let start_proof_and_print k l hook = let no_hook _ _ = () -let vernac_definition_hook = function -| Coercion -> Class.add_coercion_hook -| CanonicalStructure -> (fun _ -> Recordops.declare_canonical_structure) -| SubClass -> Class.add_subclass_hook +let vernac_definition_hook p = function +| Coercion -> Class.add_coercion_hook p +| CanonicalStructure -> fun _ -> Recordops.declare_canonical_structure +| SubClass -> Class.add_subclass_hook p | _ -> no_hook -let vernac_definition locality (local,k) (loc,id as lid) def = +let vernac_definition locality p (local,k) (loc,id as lid) def = let local = enforce_locality_exp locality local in - let hook = vernac_definition_hook k in + let hook = vernac_definition_hook p k in let () = match local with | Discharge -> Dumpglob.dump_definition lid true "var" | Local | Global -> Dumpglob.dump_definition lid false "def" in (match def with | ProveBody (bl,t) -> (* local binders, typ *) - start_proof_and_print (local,DefinitionBody Definition) + start_proof_and_print (local,p,DefinitionBody Definition) [Some lid, (bl,t,None)] no_hook | DefineBody (bl,red_option,c,typ_opt) -> let red_option = match red_option with @@ -480,9 +476,9 @@ let vernac_definition locality (local,k) (loc,id as lid) def = | Some r -> let (evc,env)= get_current_context () in Some (snd (interp_redexp env evc r)) in - do_definition id (local,k) bl red_option c typ_opt hook) + do_definition id (local,p,k) bl red_option c typ_opt hook) -let vernac_start_proof kind l lettop = +let vernac_start_proof p kind l lettop = if Dumpglob.dump () then List.iter (fun (id, _) -> match id with @@ -492,7 +488,7 @@ let vernac_start_proof kind l lettop = if lettop then errorlabstrm "Vernacentries.StartProof" (str "Let declarations can only be used in proof editing mode."); - start_proof_and_print (Global, Proof kind) l no_hook + start_proof_and_print (Global, p, Proof kind) l no_hook let qed_display_script = ref true @@ -512,10 +508,10 @@ let vernac_exact_proof c = save_proof (Vernacexpr.Proved(true,None)); if not status then Pp.feedback Interface.AddedAxiom -let vernac_assumption locality (local, kind) l nl = +let vernac_assumption locality poly (local, kind) l nl = let local = enforce_locality_exp locality local in let global = local == Global in - let kind = local, kind in + let kind = local, poly, kind in List.iter (fun (is_coe,(idl,c)) -> if Dumpglob.dump () then List.iter (fun lid -> @@ -524,7 +520,7 @@ let vernac_assumption locality (local, kind) l nl = let status = do_assumptions kind nl l in if not status then Pp.feedback Interface.AddedAxiom -let vernac_record k finite infer struc binders sort nameopt cfs = +let vernac_record k poly finite infer struc binders sort nameopt cfs = let const = match nameopt with | None -> add_prefix "Build_" (snd (snd struc)) | Some (_,id as lid) -> @@ -535,9 +531,9 @@ let vernac_record k finite infer struc binders sort nameopt cfs = match x with | Vernacexpr.AssumExpr ((loc, Name id), _) -> Dumpglob.dump_definition (loc,id) false "proj" | _ -> ()) cfs); - ignore(Record.definition_structure (k,finite,infer,struc,binders,cfs,const,sort)) + ignore(Record.definition_structure (k,poly,finite,infer,struc,binders,cfs,const,sort)) -let vernac_inductive finite infer indl = +let vernac_inductive poly finite infer indl = if Dumpglob.dump () then List.iter (fun (((coe,lid), _, _, _, cstrs), _) -> match cstrs with @@ -550,13 +546,13 @@ let vernac_inductive finite infer indl = match indl with | [ ( id , bl , c , b, RecordDecl (oc,fs) ), [] ] -> vernac_record (match b with Class true -> Class false | _ -> b) - finite infer id bl c oc fs + poly finite infer id bl c oc fs | [ ( id , bl , c , Class true, Constructors [l]), _ ] -> let f = let (coe, ((loc, id), ce)) = l in let coe' = if coe then Some true else None in (((coe', AssumExpr ((loc, Name id), ce)), None), []) - in vernac_record (Class true) finite infer id bl c None [f] + in vernac_record (Class true) poly finite infer id bl c None [f] | [ ( id , bl , c , Class true, _), _ ] -> Errors.error "Definitional classes must have a single method" | [ ( id , bl , c , Class false, Constructors _), _ ] -> @@ -568,19 +564,19 @@ let vernac_inductive finite infer indl = | _ -> Errors.error "Cannot handle mutually (co)inductive records." in let indl = List.map unpack indl in - do_mutual_inductive indl (finite != CoFinite) + do_mutual_inductive indl poly (finite != CoFinite) -let vernac_fixpoint locality local l = +let vernac_fixpoint locality poly local l = let local = enforce_locality_exp locality local in if Dumpglob.dump () then List.iter (fun ((lid, _, _, _, _), _) -> Dumpglob.dump_definition lid false "def") l; - do_fixpoint local l + do_fixpoint local poly l -let vernac_cofixpoint locality local l = +let vernac_cofixpoint locality poly local l = let local = enforce_locality_exp locality local in if Dumpglob.dump () then List.iter (fun ((lid, _, _, _), _) -> Dumpglob.dump_definition lid false "def") l; - do_cofixpoint local l + do_cofixpoint local poly l let vernac_scheme l = if Dumpglob.dump () then @@ -766,27 +762,26 @@ let vernac_require import qidl = let vernac_canonical r = Recordops.declare_canonical_structure (smart_global r) -let vernac_coercion locality local ref qids qidt = +let vernac_coercion locality poly local ref qids qidt = let local = enforce_locality locality local in let target = cl_of_qualid qidt in let source = cl_of_qualid qids in let ref' = smart_global ref in - Class.try_add_new_coercion_with_target ref' ~local ~source ~target; + Class.try_add_new_coercion_with_target ref' ~local poly ~source ~target; if_verbose msg_info (pr_global ref' ++ str " is now a coercion") -let vernac_identity_coercion locality local id qids qidt = +let vernac_identity_coercion locality poly local id qids qidt = let local = enforce_locality locality local in let target = cl_of_qualid qidt in let source = cl_of_qualid qids in - Class.try_add_new_identity_coercion id ~local ~source ~target + Class.try_add_new_identity_coercion id ~local poly ~source ~target (* Type classes *) -let vernac_instance abst locality sup inst props pri = +let vernac_instance abst locality poly sup inst props pri = let global = not (make_section_locality locality) in Dumpglob.dump_constraint inst false "inst"; - ignore(Classes.new_instance - ~abstract:abst ~global sup inst props pri) + ignore(Classes.new_instance ~abstract:abst ~global poly sup inst props pri) let vernac_context l = if not (Classes.context l) then Pp.feedback Interface.AddedAxiom @@ -909,9 +904,9 @@ let vernac_remove_hints locality dbs ids = let local = make_module_locality locality in Auto.remove_hints local dbs (List.map Smartlocate.global_with_alias ids) -let vernac_hints locality local lb h = +let vernac_hints locality poly local lb h = let local = enforce_module_locality locality local in - Auto.add_hints local lb (Auto.interp_hints h) + Auto.add_hints local lb (Auto.interp_hints poly h) let vernac_syntactic_definition locality lid x local y = Dumpglob.dump_definition lid false "syndef"; @@ -938,7 +933,8 @@ let vernac_declare_arguments locality r l nargs flags = then error "Arguments names must be distinct."; let sr = smart_global r in let inf_names = - Impargs.compute_implicits_names (Global.env()) (Global.type_of_global sr) in + let ty = Global.type_of_global_unsafe sr in + Impargs.compute_implicits_names (Global.env ()) ty in let string_of_name = function Anonymous -> "_" | Name id -> Id.to_string id in let rec check li ld ls = match li, ld, ls with | [], [], [] -> () @@ -1051,7 +1047,7 @@ let default_env () = { let vernac_reserve bl = let sb_decl = (fun (idl,c) -> - let t = Constrintern.interp_type Evd.empty (Global.env()) c in + let t,ctx = Constrintern.interp_type Evd.empty (Global.env()) c in let t = Detyping.detype false [] [] t in let t = Notation_ops.notation_constr_of_glob_constr (default_env ()) t in Reserve.declare_reserved_type idl t) @@ -1218,6 +1214,15 @@ let _ = declare_bool_option { optsync = true; optdepr = false; + optname = "universe polymorphism"; + optkey = ["Universe"; "Polymorphism"]; + optread = Flags.is_universe_polymorphism; + optwrite = Flags.make_universe_polymorphism } + +let _ = + declare_bool_option + { optsync = true; + optdepr = false; optname = "use of virtual machine inside the kernel"; optkey = ["Virtual";"Machine"]; optread = (fun () -> Vconv.use_vm ()); @@ -1378,7 +1383,10 @@ let get_current_context_of_args = function let vernac_check_may_eval redexp glopt rc = let (sigma, env) = get_current_context_of_args glopt in let sigma', c = interp_open_constr sigma env rc in - Evarconv.check_problems_are_solved sigma'; + let sigma' = Evarconv.consider_remaining_unif_problems env sigma' in + Evarconv.check_problems_are_solved env sigma'; + let sigma',nf = Evarutil.nf_evars_and_universes sigma' in + let c = nf c in let j = try Evarutil.check_evars env sigma sigma' c; @@ -1402,8 +1410,9 @@ let vernac_declare_reduction locality s r = let vernac_global_check c = let evmap = Evd.empty in let env = Global.env() in - let c = interp_constr evmap env c in + let c,ctx = interp_constr evmap env c in let senv = Global.safe_env() in + let senv = Safe_typing.add_constraints (snd ctx) senv in let j = Safe_typing.typing senv c in msg_notice (print_safe_judgment env j) @@ -1453,7 +1462,7 @@ let vernac_print = function dump_global qid; msg_notice (print_impargs qid) | PrintAssumptions (o,t,r) -> (* Prints all the axioms and section variables used by a term *) - let cstr = constr_of_global (smart_global r) in + let cstr = printable_constr_of_global (smart_global r) in let st = Conv_oracle.get_transp_state (Environ.oracle (Global.env())) in let nassums = Assumptions.assumptions st ~add_opaque:o ~add_transparent:t cstr in @@ -1522,7 +1531,7 @@ let vernac_register id r = error "Register inline: a constant is expected"; let kn = destConst t in match r with - | RegisterInline -> Global.register_inline kn + | RegisterInline -> Global.register_inline (Univ.out_punivs kn) (********************) (* Proof management *) @@ -1651,7 +1660,7 @@ let vernac_load interp fname = (* "locality" is the prefix "Local" attribute, while the "local" component * is the outdated/deprecated "Local" attribute of some vernacular commands * still parsed as the obsolete_locality grammar entry for retrocompatibility *) -let interp ?proof locality c = +let interp ?proof locality poly c = prerr_endline ("interpreting: " ^ Pp.string_of_ppcmds (Ppvernac.pr_vernac c)); match c with (* Done later in this file *) @@ -1678,14 +1687,14 @@ let interp ?proof locality c = vernac_notation locality local c infpl sc (* Gallina *) - | VernacDefinition (k,lid,d) -> vernac_definition locality k lid d - | VernacStartTheoremProof (k,l,top) -> vernac_start_proof k l top + | VernacDefinition (k,lid,d) -> vernac_definition locality poly k lid d + | VernacStartTheoremProof (k,l,top) -> vernac_start_proof poly k l top | VernacEndProof e -> vernac_end_proof ?proof e | VernacExactProof c -> vernac_exact_proof c - | VernacAssumption (stre,nl,l) -> vernac_assumption locality stre l nl - | VernacInductive (finite,infer,l) -> vernac_inductive finite infer l - | VernacFixpoint (local, l) -> vernac_fixpoint locality local l - | VernacCoFixpoint (local, l) -> vernac_cofixpoint locality local l + | VernacAssumption (stre,nl,l) -> vernac_assumption locality poly stre l nl + | VernacInductive (finite,infer,l) -> vernac_inductive poly finite infer l + | VernacFixpoint (local, l) -> vernac_fixpoint locality poly local l + | VernacCoFixpoint (local, l) -> vernac_cofixpoint locality poly local l | VernacScheme l -> vernac_scheme l | VernacCombinedScheme (id, l) -> vernac_combined_scheme id l @@ -1706,13 +1715,13 @@ let interp ?proof locality c = | VernacRequire (export, qidl) -> vernac_require export qidl | VernacImport (export,qidl) -> vernac_import export qidl | VernacCanonical qid -> vernac_canonical qid - | VernacCoercion (local,r,s,t) -> vernac_coercion locality local r s t + | VernacCoercion (local,r,s,t) -> vernac_coercion locality poly local r s t | VernacIdentityCoercion (local,(_,id),s,t) -> - vernac_identity_coercion locality local id s t + vernac_identity_coercion locality poly local id s t (* Type classes *) | VernacInstance (abst, sup, inst, props, pri) -> - vernac_instance abst locality sup inst props pri + vernac_instance abst locality poly sup inst props pri | VernacContext sup -> vernac_context sup | VernacDeclareInstances (ids, pri) -> vernac_declare_instances locality ids pri | VernacDeclareClass id -> vernac_declare_class id @@ -1744,7 +1753,7 @@ let interp ?proof locality c = | VernacCreateHintDb (dbname,b) -> vernac_create_hintdb locality dbname b | VernacRemoveHints (dbnames,ids) -> vernac_remove_hints locality dbnames ids | VernacHints (local,dbnames,hints) -> - vernac_hints locality local dbnames hints + vernac_hints locality poly local dbnames hints | VernacSyntacticDefinition (id,c,local,b) -> vernac_syntactic_definition locality id c local b | VernacDeclareImplicits (qid,l) -> @@ -1772,7 +1781,7 @@ let interp ?proof locality c = | VernacNop -> () (* Proof management *) - | VernacGoal t -> vernac_start_proof Theorem [None,([],t,None)] false + | VernacGoal t -> vernac_start_proof poly Theorem [None,([],t,None)] false | VernacAbort id -> anomaly (str "VernacAbort not handled by Stm") | VernacAbortAll -> anomaly (str "VernacAbortAll not handled by Stm") | VernacRestart -> anomaly (str "VernacRestart not handled by Stm") @@ -1801,6 +1810,7 @@ let interp ?proof locality c = (* Handled elsewhere *) | VernacProgram _ + | VernacPolymorphic _ | VernacLocal _ -> assert false (* Vernaculars that take a locality flag *) @@ -1827,6 +1837,24 @@ let check_vernac_supports_locality c l = | VernacExtend _ ) -> () | Some _, _ -> Errors.error "This command does not support Locality" +(* Vernaculars that take a polymorphism flag *) +let check_vernac_supports_polymorphism c p = + match p, c with + | None, _ -> () + | Some _, ( + VernacDefinition _ | VernacFixpoint _ | VernacCoFixpoint _ + | VernacAssumption _ | VernacInductive _ + | VernacStartTheoremProof _ + | VernacCoercion _ | VernacIdentityCoercion _ + | VernacInstance _ | VernacDeclareInstances _ + | VernacHints _ + | VernacExtend _ ) -> () + | Some _, _ -> Errors.error "This command does not support Polymorphism" + +let enforce_polymorphism = function + | None -> Flags.is_universe_polymorphism () + | Some b -> b + (** A global default timeout, controled by option "Set Default Timeout n". Use "Unset Default Timeout" to deactivate it (or set it to 0). *) @@ -1883,13 +1911,17 @@ exception HasFailed of string let interp ?(verbosely=true) ?proof (loc,c) = let orig_program_mode = Flags.is_program_mode () in - let rec aux ?locality isprogcmd = function - | VernacProgram c when not isprogcmd -> aux ?locality true c + let rec aux ?locality ?polymorphism isprogcmd = function + | VernacProgram c when not isprogcmd -> aux ?locality ?polymorphism true c | VernacProgram _ -> Errors.error "Program mode specified twice" - | VernacLocal (b, c) when Option.is_empty locality -> aux ~locality:b isprogcmd c + | VernacLocal (b, c) when Option.is_empty locality -> + aux ~locality:b ?polymorphism isprogcmd c + | VernacPolymorphic (b, c) when polymorphism = None -> + aux ?locality ~polymorphism:b isprogcmd c + | VernacPolymorphic (b, c) -> Errors.error "Polymorphism specified twice" | VernacLocal _ -> Errors.error "Locality specified twice" - | VernacStm (Command c) -> aux ?locality isprogcmd c - | VernacStm (PGLast c) -> aux ?locality isprogcmd c + | VernacStm (Command c) -> aux ?locality ?polymorphism isprogcmd c + | VernacStm (PGLast c) -> aux ?locality ?polymorphism isprogcmd c | VernacStm _ -> assert false (* Done by Stm *) | VernacFail v -> begin try @@ -1899,7 +1931,7 @@ let interp ?(verbosely=true) ?proof (loc,c) = Future.purify (fun v -> try - aux ?locality isprogcmd v; + aux ?locality ?polymorphism isprogcmd v; raise HasNotFailed with | HasNotFailed as e -> raise e @@ -1919,10 +1951,10 @@ let interp ?(verbosely=true) ?proof (loc,c) = end | VernacTimeout (n,v) -> current_timeout := Some n; - aux ?locality isprogcmd v + aux ?locality ?polymorphism isprogcmd v | VernacTime v -> let tstart = System.get_time() in - aux ?locality isprogcmd v; + aux ?locality ?polymorphism isprogcmd v; let tend = System.get_time() in let msg = if !Flags.time then "" else "Finished transaction in " in msg_info (str msg ++ System.fmt_time_difference tstart tend) @@ -1930,11 +1962,13 @@ let interp ?(verbosely=true) ?proof (loc,c) = | VernacLoad (_,fname) -> vernac_load (aux false) fname | c -> check_vernac_supports_locality c locality; + check_vernac_supports_polymorphism c polymorphism; + let poly = enforce_polymorphism polymorphism in Obligations.set_program_mode isprogcmd; let psh = default_set_timeout () in try - if verbosely then Flags.verbosely (interp ?proof locality) c - else Flags.silently (interp ?proof locality) c; + if verbosely then Flags.verbosely (interp ?proof locality poly) c + else Flags.silently (interp ?proof locality poly) c; restore_timeout psh; if orig_program_mode || not !Flags.program_mode || isprogcmd then Flags.program_mode := orig_program_mode diff --git a/toplevel/whelp.ml4 b/toplevel/whelp.ml4 index 79673df32..2da4058c8 100644 --- a/toplevel/whelp.ml4 +++ b/toplevel/whelp.ml4 @@ -126,9 +126,9 @@ let uri_params f = function let get_discharged_hyp_names sp = List.map basename (get_discharged_hyps sp) let section_parameters = function - | GRef (_,(ConstructRef ((induri,_),_) | IndRef (induri,_))) -> + | GRef (_,(ConstructRef ((induri,_),_) | IndRef (induri,_)),_) -> get_discharged_hyp_names (path_of_global (IndRef(induri,0))) - | GRef (_,(ConstRef cst as ref)) -> + | GRef (_,(ConstRef cst as ref),_) -> get_discharged_hyp_names (path_of_global ref) | _ -> [] @@ -141,10 +141,10 @@ let merge vl al = let rec uri_of_constr c = match c with | GVar (_,id) -> url_id id - | GRef (_,ref) -> uri_of_global ref + | GRef (_,ref,_) -> uri_of_global ref | GHole _ | GEvar _ -> url_string "?" | GSort (_,s) -> url_string (whelp_of_glob_sort s) - | _ -> url_paren (fun () -> match c with + | GProj _ -> assert false | GApp (_,f,args) -> let inst,rest = merge (section_parameters f) args in uri_of_constr f; url_char ' '; uri_params uri_of_constr inst; @@ -164,10 +164,10 @@ let rec uri_of_constr c = uri_of_constr c; url_string ":"; uri_of_constr t | GRec _ | GIf _ | GLetTuple _ | GCases _ -> error "Whelp does not support pattern-matching and (co-)fixpoint." - | GVar _ | GRef _ | GHole _ | GEvar _ | GSort _ | GCast (_,_, CastCoerce) -> + | GCast (_,_, CastCoerce) -> anomaly (Pp.str "Written w/o parenthesis") | GPatVar _ -> - anomaly (Pp.str "Found constructors not supported in constr")) () + anomaly (Pp.str "Found constructors not supported in constr") let make_string f x = Buffer.reset b; f x; Buffer.contents b |