diff options
author | Benjamin Barenblat <bbaren@debian.org> | 2018-12-29 14:31:27 -0500 |
---|---|---|
committer | Benjamin Barenblat <bbaren@debian.org> | 2018-12-29 14:31:27 -0500 |
commit | 9043add656177eeac1491a73d2f3ab92bec0013c (patch) | |
tree | 2b0092c84bfbf718eca10c81f60b2640dc8cab05 /plugins/funind | |
parent | a4c7f8bd98be2a200489325ff7c5061cf80ab4f3 (diff) |
Imported Upstream version 8.8.2upstream/8.8.2
Diffstat (limited to 'plugins/funind')
-rw-r--r-- | plugins/funind/FunInd.v | 12 | ||||
-rw-r--r-- | plugins/funind/Recdef.v | 12 | ||||
-rw-r--r-- | plugins/funind/functional_principles_proofs.ml | 413 | ||||
-rw-r--r-- | plugins/funind/functional_principles_proofs.mli | 11 | ||||
-rw-r--r-- | plugins/funind/functional_principles_types.ml | 207 | ||||
-rw-r--r-- | plugins/funind/functional_principles_types.mli | 28 | ||||
-rw-r--r-- | plugins/funind/g_indfun.ml4 | 80 | ||||
-rw-r--r-- | plugins/funind/glob_term_to_relation.ml | 529 | ||||
-rw-r--r-- | plugins/funind/glob_term_to_relation.mli | 4 | ||||
-rw-r--r-- | plugins/funind/glob_termops.ml | 621 | ||||
-rw-r--r-- | plugins/funind/glob_termops.mli | 44 | ||||
-rw-r--r-- | plugins/funind/indfun.ml | 450 | ||||
-rw-r--r-- | plugins/funind/indfun.mli | 12 | ||||
-rw-r--r-- | plugins/funind/indfun_common.ml | 168 | ||||
-rw-r--r-- | plugins/funind/indfun_common.mli | 65 | ||||
-rw-r--r-- | plugins/funind/invfun.ml | 323 | ||||
-rw-r--r-- | plugins/funind/invfun.mli | 19 | ||||
-rw-r--r-- | plugins/funind/merge.ml | 1009 | ||||
-rw-r--r-- | plugins/funind/recdef.ml | 473 | ||||
-rw-r--r-- | plugins/funind/recdef.mli | 15 | ||||
-rw-r--r-- | plugins/funind/recdef_plugin.mlpack | 1 | ||||
-rw-r--r-- | plugins/funind/vo.itarget | 1 |
22 files changed, 1797 insertions, 2700 deletions
diff --git a/plugins/funind/FunInd.v b/plugins/funind/FunInd.v new file mode 100644 index 00000000..12458c10 --- /dev/null +++ b/plugins/funind/FunInd.v @@ -0,0 +1,12 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +Require Coq.extraction.Extraction. +Declare ML Module "recdef_plugin". diff --git a/plugins/funind/Recdef.v b/plugins/funind/Recdef.v index e4433247..d94e62b4 100644 --- a/plugins/funind/Recdef.v +++ b/plugins/funind/Recdef.v @@ -1,13 +1,15 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) +Require Export Coq.funind.FunInd. Require Import PeanoNat. - Require Compare_dec. Require Wf_nat. diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index b0ffc775..d04887a4 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -1,14 +1,14 @@ open Printer open CErrors open Util -open Term +open Constr +open EConstr open Vars open Namegen open Names open Pp open Tacmach open Termops -open Proof_type open Tacticals open Tactics open Indfun_common @@ -16,6 +16,8 @@ open Libnames open Globnames open Context.Rel.Declaration +module RelDecl = Context.Rel.Declaration + (* let msgnl = Pp.msgnl *) (* @@ -42,6 +44,10 @@ let observe_tac s tac g = observe_tac_stream (str s) tac g *) +let pr_leconstr_fp = + let sigma, env = Pfedit.get_current_context () in + Printer.pr_leconstr_env env sigma + let debug_queue = Stack.create () let rec print_debug_queue e = @@ -93,6 +99,7 @@ let list_chop ?(msg="") n l = with Failure (msg') -> failwith (msg ^ msg') +let pop t = Vars.lift (-1) t let make_refl_eq constructor type_of_t t = (* let refl_equal_term = Lazy.force refl_equal in *) @@ -101,7 +108,7 @@ let make_refl_eq constructor type_of_t t = type pte_info = { - proving_tac : (Id.t list -> Tacmach.tactic); + proving_tac : (Id.t list -> Tacmach.tactic); is_valid : constr -> bool } @@ -129,16 +136,16 @@ let refine c = let thin l = Proofview.V82.of_tactic (Tactics.clear l) -let eq_constr u v = eq_constr_nounivs u v +let eq_constr sigma u v = EConstr.eq_constr_nounivs sigma u v -let is_trivial_eq t = +let is_trivial_eq sigma t = let res = try begin - match kind_of_term t with - | App(f,[|_;t1;t2|]) when eq_constr f (Lazy.force eq) -> - eq_constr t1 t2 - | App(f,[|t1;a1;t2;a2|]) when eq_constr f (jmeq ()) -> - eq_constr t1 t2 && eq_constr a1 a2 + match EConstr.kind sigma t with + | App(f,[|_;t1;t2|]) when eq_constr sigma f (Lazy.force eq) -> + eq_constr sigma t1 t2 + | App(f,[|t1;a1;t2;a2|]) when eq_constr sigma f (jmeq ()) -> + eq_constr sigma t1 t2 && eq_constr sigma a1 a2 | _ -> false end with e when CErrors.noncritical e -> false @@ -146,30 +153,30 @@ let is_trivial_eq t = (* observe (str "is_trivial_eq " ++ Printer.pr_lconstr t ++ (if res then str " true" else str " false")); *) res -let rec incompatible_constructor_terms t1 t2 = - let c1,arg1 = decompose_app t1 - and c2,arg2 = decompose_app t2 +let rec incompatible_constructor_terms sigma t1 t2 = + let c1,arg1 = decompose_app sigma t1 + and c2,arg2 = decompose_app sigma t2 in - (not (eq_constr t1 t2)) && - isConstruct c1 && isConstruct c2 && + (not (eq_constr sigma t1 t2)) && + isConstruct sigma c1 && isConstruct sigma c2 && ( - not (eq_constr c1 c2) || - List.exists2 incompatible_constructor_terms arg1 arg2 + not (eq_constr sigma c1 c2) || + List.exists2 (incompatible_constructor_terms sigma) arg1 arg2 ) -let is_incompatible_eq t = +let is_incompatible_eq sigma t = let res = try - match kind_of_term t with - | App(f,[|_;t1;t2|]) when eq_constr f (Lazy.force eq) -> - incompatible_constructor_terms t1 t2 - | App(f,[|u1;t1;u2;t2|]) when eq_constr f (jmeq ()) -> - (eq_constr u1 u2 && - incompatible_constructor_terms t1 t2) + match EConstr.kind sigma t with + | App(f,[|_;t1;t2|]) when eq_constr sigma f (Lazy.force eq) -> + incompatible_constructor_terms sigma t1 t2 + | App(f,[|u1;t1;u2;t2|]) when eq_constr sigma f (jmeq ()) -> + (eq_constr sigma u1 u2 && + incompatible_constructor_terms sigma t1 t2) | _ -> false with e when CErrors.noncritical e -> false in - if res then observe (str "is_incompatible_eq " ++ Printer.pr_lconstr t); + if res then observe (str "is_incompatible_eq " ++ pr_leconstr_fp t); res let change_hyp_with_using msg hyp_id t tac : tactic = @@ -206,40 +213,41 @@ 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 env c) in - match kind_of_term t with +let find_rectype env sigma c = + let (t, l) = decompose_app sigma (Reductionops.whd_betaiotazeta sigma c) in + match EConstr.kind sigma t with | Ind ind -> (t, l) | Construct _ -> (t,l) | _ -> raise Not_found -let isAppConstruct ?(env=Global.env ()) t = +let isAppConstruct ?(env=Global.env ()) sigma t = try - let t',l = find_rectype (Global.env ()) t in - observe (str "isAppConstruct : " ++ Printer.pr_lconstr t ++ str " -> " ++ Printer.pr_lconstr (applist (t',l))); + let t',l = find_rectype env sigma t in + observe (str "isAppConstruct : " ++ Printer.pr_leconstr_env env sigma t ++ str " -> " ++ + Printer.pr_leconstr_env env sigma (applist (t',l))); true with Not_found -> false let nf_betaiotazeta = (* Reductionops.local_strong Reductionops.whd_betaiotazeta *) - let clos_norm_flags flgs env sigma t = - CClosure.norm_val (CClosure.create_clos_infos flgs env) (CClosure.inject (Reductionops.nf_evar sigma t)) in - clos_norm_flags CClosure.betaiotazeta Environ.empty_env Evd.empty + Reductionops.clos_norm_flags CClosure.betaiotazeta Environ.empty_env Evd.empty +exception NoChange -let change_eq env sigma hyp_id (context:Context.Rel.t) x t end_of_type = +let change_eq env sigma hyp_id (context:rel_context) x t end_of_type = let nochange ?t' msg = begin - observe (str ("Not treating ( "^msg^" )") ++ pr_lconstr t ++ str " " ++ match t' with None -> str "" | Some t -> Printer.pr_lconstr t ); - failwith "NoChange"; + observe (str ("Not treating ( "^msg^" )") ++ pr_leconstr_env env sigma t ++ str " " ++ + match t' with None -> str "" | Some t -> Printer.pr_leconstr_env env sigma t ); + raise NoChange; end in - let eq_constr = Evarconv.e_conv env (ref sigma) in - if not (noccurn 1 end_of_type) + let eq_constr c1 c2 = Evarconv.e_conv env (ref sigma) c1 c2 in + if not (noccurn sigma 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"; - let f_eq,args = destApp t in + if not (isApp sigma t) then nochange "not an equality"; + let f_eq,args = destApp sigma t in let constructor,t1,t2,t1_typ = try if (eq_constr f_eq (Lazy.force eq)) @@ -256,42 +264,42 @@ let change_eq env sigma hyp_id (context:Context.Rel.t) x t end_of_type = else nochange "not an equality" with e when CErrors.noncritical e -> nochange "not an equality" in - if not ((closed0 (fst t1)) && (closed0 (snd t1)))then nochange "not a closed lhs"; + if not ((closed0 sigma (fst t1)) && (closed0 sigma (snd t1)))then nochange "not a closed lhs"; let rec compute_substitution sub t1 t2 = (* observe (str "compute_substitution : " ++ pr_lconstr t1 ++ str " === " ++ pr_lconstr t2); *) - if isRel t2 + if isRel sigma t2 then - let t2 = destRel t2 in + let t2 = destRel sigma t2 in begin try let t1' = Int.Map.find t2 sub in if not (eq_constr t1 t1') then nochange "twice bound variable"; sub with Not_found -> - assert (closed0 t1); + assert (closed0 sigma t1); Int.Map.add t2 t1 sub end - else if isAppConstruct t1 && isAppConstruct t2 + else if isAppConstruct sigma t1 && isAppConstruct sigma t2 then begin - let c1,args1 = find_rectype env t1 - and c2,args2 = find_rectype env t2 + let c1,args1 = find_rectype env sigma t1 + and c2,args2 = find_rectype env sigma t2 in if not (eq_constr c1 c2) then nochange "cannot solve (diff)"; List.fold_left2 compute_substitution sub args1 args2 end else - if (eq_constr t1 t2) then sub else nochange ~t':(make_refl_eq constructor (Reduction.whd_all env t1) t2) "cannot solve (diff)" + if (eq_constr t1 t2) then sub else nochange ~t':(make_refl_eq constructor (Reductionops.whd_all env sigma t1) t2) "cannot solve (diff)" in let sub = compute_substitution Int.Map.empty (snd t1) (snd t2) in let sub = compute_substitution sub (fst t1) (fst t2) in - let end_of_type_with_pop = Termops.pop end_of_type in (*the equation will be removed *) + let end_of_type_with_pop = pop end_of_type in (*the equation will be removed *) let new_end_of_type = (* Ugly hack to prevent Map.fold order change between ocaml-3.08.3 and ocaml-3.08.4 Can be safely replaced by the next comment for Ocaml >= 3.08.4 *) let sub = Int.Map.bindings sub in - List.fold_left (fun end_of_type (i,t) -> lift 1 (substnl [t] (i-1) end_of_type)) + List.fold_left (fun end_of_type (i,t) -> liftn 1 i (substnl [t] (i-1) end_of_type)) end_of_type_with_pop sub in @@ -307,7 +315,7 @@ let change_eq env sigma hyp_id (context:Context.Rel.t) x t end_of_type = try let witness = Int.Map.find i sub in if is_local_def decl then anomaly (Pp.str "can not redefine a rel!"); - (Termops.pop end_of_type,ctxt_size,mkLetIn (get_name decl, witness, get_type decl, witness_fun)) + (pop end_of_type,ctxt_size,mkLetIn (RelDecl.get_name decl, witness, RelDecl.get_type decl, witness_fun)) with Not_found -> (mkProd_or_LetIn decl end_of_type, ctxt_size + 1, mkLambda_or_LetIn decl witness_fun) ) @@ -316,9 +324,9 @@ let change_eq env sigma hyp_id (context:Context.Rel.t) x t end_of_type = context in let new_type_of_hyp = - Reductionops.nf_betaiota Evd.empty new_type_of_hyp in + Reductionops.nf_betaiota env sigma new_type_of_hyp in let new_ctxt,new_end_of_type = - decompose_prod_n_assum ctxt_size new_type_of_hyp + decompose_prod_n_assum sigma ctxt_size new_type_of_hyp in let prove_new_hyp : tactic = tclTHEN @@ -351,21 +359,21 @@ let change_eq env sigma hyp_id (context:Context.Rel.t) x t end_of_type = new_ctxt,new_end_of_type,simpl_eq_tac -let is_property (ptes_info:ptes_info) t_x full_type_of_hyp = - if isApp t_x +let is_property sigma (ptes_info:ptes_info) t_x full_type_of_hyp = + if isApp sigma t_x then - let pte,args = destApp t_x in - if isVar pte && Array.for_all closed0 args + let pte,args = destApp sigma t_x in + if isVar sigma pte && Array.for_all (closed0 sigma) args then try - let info = Id.Map.find (destVar pte) ptes_info in + let info = Id.Map.find (destVar sigma pte) ptes_info in info.is_valid full_type_of_hyp with Not_found -> false else false else false -let isLetIn t = - match kind_of_term t with +let isLetIn sigma t = + match EConstr.kind sigma t with | LetIn _ -> true | _ -> false @@ -385,15 +393,16 @@ let rewrite_until_var arg_num eq_ids : tactic = will break the Guard when trying to save the Lemma. *) let test_var g = - let _,args = destApp (pf_concl g) in - not ((isConstruct args.(arg_num)) || isAppConstruct args.(arg_num)) + let sigma = project g in + let _,args = destApp sigma (pf_concl g) in + not ((isConstruct sigma args.(arg_num)) || isAppConstruct sigma args.(arg_num)) in let rec do_rewrite eq_ids g = if test_var g then tclIDTAC g else match eq_ids with - | [] -> anomaly (Pp.str "Cannot find a way to prove recursive property"); + | [] -> anomaly (Pp.str "Cannot find a way to prove recursive property."); | eq_id::eq_ids -> tclTHEN (tclTRY (Proofview.V82.of_tactic (Equality.rewriteRL (mkVar eq_id)))) @@ -405,30 +414,30 @@ let rewrite_until_var arg_num eq_ids : tactic = let rec_pte_id = Id.of_string "Hrec" let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = - let coq_False = Coqlib.build_coq_False () in - let coq_True = Coqlib.build_coq_True () in - let coq_I = Coqlib.build_coq_I () in + let coq_False = EConstr.of_constr (Universes.constr_of_global @@ Coqlib.build_coq_False ()) in + let coq_True = EConstr.of_constr (Universes.constr_of_global @@ Coqlib.build_coq_True ()) in + let coq_I = EConstr.of_constr (Universes.constr_of_global @@ Coqlib.build_coq_I ()) in let rec scan_type context type_of_hyp : tactic = - if isLetIn type_of_hyp then + if isLetIn sigma type_of_hyp then let real_type_of_hyp = it_mkProd_or_LetIn type_of_hyp context in let reduced_type_of_hyp = nf_betaiotazeta real_type_of_hyp in (* length of context didn't change ? *) let new_context,new_typ_of_hyp = - decompose_prod_n_assum (List.length context) reduced_type_of_hyp + decompose_prod_n_assum sigma (List.length context) reduced_type_of_hyp in tclTHENLIST [ h_reduce_with_zeta (Locusops.onHyp hyp_id); scan_type new_context new_typ_of_hyp ] - else if isProd type_of_hyp + else if isProd sigma type_of_hyp then begin - let (x,t_x,t') = destProd type_of_hyp in + let (x,t_x,t') = destProd sigma type_of_hyp in let actual_real_type_of_hyp = it_mkProd_or_LetIn t' context in - if is_property ptes_infos t_x actual_real_type_of_hyp then + if is_property sigma ptes_infos t_x actual_real_type_of_hyp then begin - let pte,pte_args = (destApp t_x) in - let (* fix_info *) prove_rec_hyp = (Id.Map.find (destVar pte) ptes_infos).proving_tac in - let popped_t' = Termops.pop t' in + let pte,pte_args = (destApp sigma t_x) in + let (* fix_info *) prove_rec_hyp = (Id.Map.find (destVar sigma pte) ptes_infos).proving_tac in + let popped_t' = pop t' in let real_type_of_hyp = it_mkProd_or_LetIn popped_t' context in let prove_new_type_of_hyp = let context_length = List.length context in @@ -465,20 +474,20 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = scan_type context popped_t' ] end - else if eq_constr t_x coq_False then + else if eq_constr sigma t_x coq_False then begin (* observe (str "Removing : "++ Ppconstr.pr_id hyp_id++ *) (* str " since it has False in its preconds " *) (* ); *) raise TOREMOVE; (* False -> .. useless *) end - else if is_incompatible_eq t_x then raise TOREMOVE (* t_x := C1 ... = C2 ... *) - else if eq_constr t_x coq_True (* Trivial => we remove this precons *) + else if is_incompatible_eq sigma t_x then raise TOREMOVE (* t_x := C1 ... = C2 ... *) + else if eq_constr sigma t_x coq_True (* Trivial => we remove this precons *) then (* observe (str "In "++Ppconstr.pr_id hyp_id++ *) (* str " removing useless precond True" *) (* ); *) - let popped_t' = Termops.pop t' in + let popped_t' = pop t' in let real_type_of_hyp = it_mkProd_or_LetIn popped_t' context in @@ -504,15 +513,15 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = ((* observe_tac "prove_trivial" *) prove_trivial); scan_type context popped_t' ] - else if is_trivial_eq t_x + else if is_trivial_eq sigma t_x then (* t_x := t = t => we remove this precond *) - let popped_t' = Termops.pop t' in + let popped_t' = pop t' in let real_type_of_hyp = it_mkProd_or_LetIn popped_t' context in - let hd,args = destApp t_x in + let hd,args = destApp sigma t_x in let get_args hd args = - if eq_constr hd (Lazy.force eq) + if eq_constr sigma hd (Lazy.force eq) then (Lazy.force refl_equal,args.(0),args.(1)) else (jmeq_refl (),args.(0),args.(1)) in @@ -533,7 +542,7 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = tclTHEN tac (scan_type new_context new_t') - with Failure "NoChange" -> + with NoChange -> (* Last thing todo : push the rel in the context and continue *) scan_type (LocalAssum (x,t_x) :: context) t' end @@ -584,7 +593,7 @@ let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos = tclTHENLIST [ (* We first introduce the variables *) - tclDO nb_first_intro (Proofview.V82.of_tactic (intro_avoiding dyn_infos.rec_hyps)); + tclDO nb_first_intro (Proofview.V82.of_tactic (intro_avoiding (Id.Set.of_list dyn_infos.rec_hyps))); (* Then the equation itself *) Proofview.V82.of_tactic (intro_using heq_id); onLastHypId (fun heq_id -> tclTHENLIST [ @@ -595,18 +604,18 @@ let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos = let new_term_value_eq = pf_unsafe_type_of g' (mkVar heq_id) in (* compute the new value of the body *) let new_term_value = - match kind_of_term new_term_value_eq with + match EConstr.kind (project g') new_term_value_eq with | App(f,[| _;_;args2 |]) -> args2 | _ -> observe (str "cannot compute new term value : " ++ pr_gls g' ++ fnl () ++ str "last hyp is" ++ - pr_lconstr_env (pf_env g') Evd.empty new_term_value_eq + pr_leconstr_env (pf_env g') (project g') new_term_value_eq ); - anomaly (Pp.str "cannot compute new term value") + anomaly (Pp.str "cannot compute new term value.") in let fun_body = mkLambda(Anonymous, pf_unsafe_type_of g' term, - Termops.replace_term term (mkRel 1) dyn_infos.info + Termops.replace_term (project g') term (mkRel 1) dyn_infos.info ) in let new_body = pf_nf_betaiota g' (mkApp(fun_body,[| new_term_value |])) in @@ -683,34 +692,36 @@ let instanciate_hyps_with_args (do_prove:Id.t list -> tactic) hyps args_id = let build_proof (interactive_proof:bool) - (fnames:constant list) + (fnames:Constant.t list) ptes_infos dyn_infos : tactic = let rec build_proof_aux do_finalize dyn_infos : tactic = fun g -> + let env = pf_env g in + let sigma = project g in (* observe (str "proving on " ++ Printer.pr_lconstr_env (pf_env g) term);*) - match kind_of_term dyn_infos.info with + match EConstr.kind sigma dyn_infos.info with | Case(ci,ct,t,cb) -> let do_finalize_t dyn_info' = fun g -> let t = dyn_info'.info in let dyn_infos = {dyn_info' with info = mkCase(ci,ct,t,cb)} in - let g_nb_prod = nb_prod (pf_concl g) in + let g_nb_prod = nb_prod (project g) (pf_concl g) in let type_of_term = pf_unsafe_type_of g t in let term_eq = make_refl_eq (Lazy.force refl_equal) type_of_term t in - tclTHENSEQ + tclTHENLIST [ Proofview.V82.of_tactic (generalize (term_eq::(List.map mkVar dyn_infos.rec_hyps))); thin dyn_infos.rec_hyps; Proofview.V82.of_tactic (pattern_option [Locus.AllOccurrencesBut [1],t] None); (fun g -> observe_tac "toto" ( - tclTHENSEQ [Proofview.V82.of_tactic (Simple.case t); + tclTHENLIST [Proofview.V82.of_tactic (Simple.case t); (fun g' -> - let g'_nb_prod = nb_prod (pf_concl g') in + let g'_nb_prod = nb_prod (project g') (pf_concl g') in let nb_instanciate_partial = g'_nb_prod - g_nb_prod in observe_tac "treat_new_case" (treat_new_case @@ -730,7 +741,7 @@ let build_proof build_proof do_finalize_t {dyn_infos with info = t} g | Lambda(n,t,b) -> begin - match kind_of_term( pf_concl g) with + match EConstr.kind sigma (pf_concl g) with | Prod _ -> tclTHEN (Proofview.V82.of_tactic intro) @@ -760,9 +771,9 @@ let build_proof | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ -> do_finalize dyn_infos g | App(_,_) -> - let f,args = decompose_app dyn_infos.info in + let f,args = decompose_app sigma dyn_infos.info in begin - match kind_of_term f with + match EConstr.kind sigma 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 _ -> @@ -784,7 +795,7 @@ let build_proof do_finalize dyn_infos g | Lambda _ -> let new_term = - Reductionops.nf_beta Evd.empty dyn_infos.info in + Reductionops.nf_beta env sigma dyn_infos.info in build_proof do_finalize {dyn_infos with info = new_term} g | LetIn _ -> @@ -815,10 +826,11 @@ let build_proof build_proof new_finalize {dyn_infos with info = f } g end | Fix _ | CoFix _ -> - error ( "Anonymous local (co)fixpoints are not handled yet") + user_err Pp.(str ( "Anonymous local (co)fixpoints are not handled yet")) + - | Proj _ -> error "Prod" - | Prod _ -> error "Prod" + | Proj _ -> user_err Pp.(str "Prod") + | Prod _ -> do_finalize dyn_infos g | LetIn _ -> let new_infos = { dyn_infos with @@ -833,10 +845,10 @@ let build_proof h_reduce_with_zeta Locusops.onConcl; build_proof do_finalize new_infos ] g - | Rel _ -> anomaly (Pp.str "Free var in goal conclusion !") + | Rel _ -> anomaly (Pp.str "Free var in goal conclusion!") and build_proof do_finalize dyn_infos g = (* observe (str "proving with "++Printer.pr_lconstr dyn_infos.info++ str " on goal " ++ pr_gls g); *) - observe_tac_stream (str "build_proof with " ++ Printer.pr_lconstr dyn_infos.info ) (build_proof_aux do_finalize dyn_infos) g + observe_tac_stream (str "build_proof with " ++ pr_leconstr_fp dyn_infos.info ) (build_proof_aux do_finalize dyn_infos) g and build_proof_args do_finalize dyn_infos (* f_args' args *) :tactic = fun g -> let (f_args',args) = dyn_infos.info in @@ -902,7 +914,7 @@ let prove_rec_hyp_for_struct fix_info = (fun eq_hyps -> tclTHEN (rewrite_until_var (fix_info.idx) eq_hyps) (fun g -> - let _,pte_args = destApp (pf_concl g) in + let _,pte_args = destApp (project g) (pf_concl g) in let rec_hyp_proof = mkApp(mkVar fix_info.name,array_get_start pte_args) in @@ -923,10 +935,11 @@ let generalize_non_dep hyp g = let to_revert,_ = let open Context.Named.Declaration in Environ.fold_named_context_reverse (fun (clear,keep) decl -> + let decl = map_named_decl EConstr.of_constr decl in let hyp = get_id decl in if Id.List.mem hyp hyps - || List.exists (Termops.occur_var_in_decl env hyp) keep - || Termops.occur_var env hyp hyp_typ + || List.exists (Termops.occur_var_in_decl env (project g) hyp) keep + || Termops.occur_var env (project g) hyp hyp_typ || Termops.is_section_variable hyp (* should be dangerous *) then (clear,decl::keep) else (hyp::clear,keep)) @@ -938,8 +951,8 @@ let generalize_non_dep hyp g = ((* observe_tac "thin" *) (thin to_revert)) g -let id_of_decl decl = Nameops.out_name (get_name decl) -let var_of_decl decl = mkVar (id_of_decl decl) +let id_of_decl = RelDecl.get_name %> Nameops.Name.get_id +let var_of_decl = id_of_decl %> mkVar let revert idl = tclTHEN (Proofview.V82.of_tactic (generalize (List.map mkVar idl))) @@ -949,11 +962,12 @@ let generate_equation_lemma evd 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 (fst (destConst f)) in + let f_def = Global.lookup_constant (fst (destConst evd 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 (Global.body_of_constant_body f_def) in - let params,f_body_with_params = decompose_lam_n nb_params f_body in - let (_,num),(_,_,bodies) = destFix f_body_with_params in + let (f_body, _) = Option.get (Global.body_of_constant_body f_def) in + let f_body = EConstr.of_constr f_body in + let params,f_body_with_params = decompose_lam_n evd nb_params f_body in + let (_,num),(_,_,bodies) = destFix evd f_body_with_params in let fnames_with_params = let params = Array.init nb_params (fun i -> mkRel(nb_params - i)) in let fnames = List.rev (Array.to_list (Array.map (fun f -> mkApp(f,params)) fnames)) in @@ -968,20 +982,20 @@ let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num let (type_ctxt,type_of_f),evd = let evd,t = Typing.type_of ~refresh:true (Global.env ()) evd f in - decompose_prod_n_assum + decompose_prod_n_assum evd (nb_params + nb_args) t,evd 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 (* Pp.msgnl (str "lemma type " ++ Printer.pr_lconstr lemma_type ++ fnl () ++ str "f_body " ++ Printer.pr_lconstr f_body); *) - let f_id = Label.to_id (con_label (fst (destConst f))) in + let f_id = Label.to_id (Constant.label (fst (destConst evd f))) in let prove_replacement = - tclTHENSEQ + tclTHENLIST [ tclDO (nb_params + rec_args_num + 1) (Proofview.V82.of_tactic intro); observe_tac "" (fun g -> let rec_id = pf_nth_hyp_id g 1 in - tclTHENSEQ + tclTHENLIST [observe_tac "generalize_non_dep in generate_equation_lemma" (generalize_non_dep rec_id); observe_tac "h_case" (Proofview.V82.of_tactic (simplest_case (mkVar rec_id))); (Proofview.V82.of_tactic intros_reflexivity)] g @@ -1008,10 +1022,10 @@ let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num let do_replace (evd:Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num all_funs g = let equation_lemma = try - let finfos = find_Function_infos (fst (destConst f)) (*FIXME*) in + let finfos = find_Function_infos (fst (destConst !evd f)) (*FIXME*) in mkConst (Option.get finfos.equation_lemma) with (Not_found | Option.IsNone as e) -> - let f_id = Label.to_id (con_label (fst (destConst f))) in + let f_id = Label.to_id (Constant.label (fst (destConst !evd f))) in (*i The next call to mk_equation_id is valid since we will construct the lemma Ensures by: obvious i*) @@ -1020,12 +1034,12 @@ let do_replace (evd:Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num a let _ = match e with | Option.IsNone -> - let finfos = find_Function_infos (fst (destConst f)) in + let finfos = find_Function_infos (fst (destConst !evd f)) in update_Function {finfos with equation_lemma = Some (match Nametab.locate (qualid_of_ident equation_lemma_id) with ConstRef c -> c - | _ -> CErrors.anomaly (Pp.str "Not a constant") + | _ -> CErrors.anomaly (Pp.str "Not a constant.") ) } | _ -> () @@ -1036,11 +1050,12 @@ let do_replace (evd:Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num a (Global.env ()) !evd (Constrintern.locate_reference (qualid_of_ident equation_lemma_id)) in + let res = EConstr.of_constr res in evd:=evd'; let _ = Typing.e_type_of ~refresh:true (Global.env ()) evd res in res in - let nb_intro_to_do = nb_prod (pf_concl g) in + let nb_intro_to_do = nb_prod (project g) (pf_concl g) in tclTHEN (tclDO nb_intro_to_do (Proofview.V82.of_tactic intro)) ( @@ -1059,7 +1074,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam (* Pp.msgnl (str "princ_type " ++ Printer.pr_lconstr princ_type); *) (* Pp.msgnl (str "all_funs "); *) (* Array.iter (fun c -> Pp.msgnl (Printer.pr_lconstr c)) all_funs; *) - let princ_info = compute_elim_sig princ_type in + let princ_info = compute_elim_sig (project g) princ_type in let fresh_id = let avoid = ref (pf_ids_of_hyps g) in (fun na -> @@ -1072,7 +1087,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam (Name new_id) ) in - let fresh_decl = map_name fresh_id in + let fresh_decl = RelDecl.map_name fresh_id in let princ_info : elim_scheme = { princ_info with params = List.map fresh_decl princ_info.params; @@ -1083,16 +1098,16 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam in let get_body const = match Global.body_of_constant const with - | Some body -> + | Some (body, _) -> Tacred.cbv_norm_flags (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) (Global.env ()) (Evd.empty) - body - | None -> error ( "Cannot define a principle over an axiom ") + (EConstr.of_constr body) + | None -> user_err Pp.(str "Cannot define a principle over an axiom ") in let fbody = get_body fnames.(fun_num) in - let f_ctxt,f_body = decompose_lam fbody in + let f_ctxt,f_body = decompose_lam (project g) fbody in let f_ctxt_length = List.length f_ctxt in let diff_params = princ_info.nparams - f_ctxt_length in let full_params,princ_params,fbody_with_full_params = @@ -1119,27 +1134,27 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam ) in observe (str "full_params := " ++ - prlist_with_sep spc (fun decl -> Ppconstr.pr_id (Nameops.out_name (get_name decl))) + prlist_with_sep spc (RelDecl.get_name %> Nameops.Name.get_id %> Ppconstr.pr_id) full_params ); observe (str "princ_params := " ++ - prlist_with_sep spc (fun decl -> Ppconstr.pr_id (Nameops.out_name (get_name decl))) + prlist_with_sep spc (RelDecl.get_name %> Nameops.Name.get_id %> Ppconstr.pr_id) princ_params ); observe (str "fbody_with_full_params := " ++ - pr_lconstr fbody_with_full_params + pr_leconstr_env (Global.env ()) !evd fbody_with_full_params ); let all_funs_with_full_params = Array.map (fun f -> applist(f, List.rev_map var_of_decl full_params)) all_funs in let fix_offset = List.length princ_params in let ptes_to_fix,infos = - match kind_of_term fbody_with_full_params with + match EConstr.kind (project g) fbody_with_full_params with | Fix((idxs,i),(names,typess,bodies)) -> let bodies_with_all_params = Array.map (fun body -> - Reductionops.nf_betaiota Evd.empty + Reductionops.nf_betaiota (pf_env g) (project g) (applist(substl (List.rev (Array.to_list all_funs_with_full_params)) body, List.rev_map var_of_decl princ_params)) ) @@ -1148,14 +1163,14 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam let info_array = Array.mapi (fun i types -> - let types = prod_applist types (List.rev_map var_of_decl princ_params) in + let types = prod_applist (project g) types (List.rev_map var_of_decl princ_params) in { idx = idxs.(i) - fix_offset; - name = Nameops.out_name (fresh_id names.(i)); + name = Nameops.Name.get_id (fresh_id names.(i)); types = types; offset = fix_offset; nb_realargs = List.length - (fst (decompose_lam bodies.(i))) - fix_offset; + (fst (decompose_lam (project g) bodies.(i))) - fix_offset; body_with_param = bodies_with_all_params.(i); num_in_block = i } @@ -1165,24 +1180,24 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam let pte_to_fix,rev_info = List.fold_left_i (fun i (acc_map,acc_info) decl -> - let pte = get_name decl in + let pte = RelDecl.get_name decl in let infos = info_array.(i) in - let type_args,_ = decompose_prod infos.types in + let type_args,_ = decompose_prod (project g) infos.types in let nargs = List.length type_args in let f = applist(mkConst fnames.(i), List.rev_map var_of_decl princ_info.params) in let first_args = Array.init nargs (fun i -> mkRel (nargs -i)) in let app_f = mkApp(f,first_args) in let pte_args = (Array.to_list first_args)@[app_f] in - let app_pte = applist(mkVar (Nameops.out_name pte),pte_args) in + let app_pte = applist(mkVar (Nameops.Name.get_id pte),pte_args) in let body_with_param,num = let body = get_body fnames.(i) in let body_with_full_params = - Reductionops.nf_betaiota Evd.empty ( + Reductionops.nf_betaiota (pf_env g) (project g) ( applist(body,List.rev_map var_of_decl full_params)) in - match kind_of_term body_with_full_params with + match EConstr.kind (project g) body_with_full_params with | Fix((_,num),(_,_,bs)) -> - Reductionops.nf_betaiota Evd.empty + Reductionops.nf_betaiota (pf_env g) (project g) ( (applist (substl @@ -1191,7 +1206,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam bs.(num), List.rev_map var_of_decl princ_params)) ),num - | _ -> error "Not a mutual block" + | _ -> user_err Pp.(str "Not a mutual block") in let info = {infos with @@ -1200,9 +1215,9 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam num_in_block = num } in -(* observe (str "binding " ++ Ppconstr.pr_id (Nameops.out_name pte) ++ *) +(* observe (str "binding " ++ Ppconstr.pr_id (Nameops.Name.get_id pte) ++ *) (* str " to " ++ Ppconstr.pr_id info.name); *) - (Id.Map.add (Nameops.out_name pte) info acc_map,info::acc_info) + (Id.Map.add (Nameops.Name.get_id pte) info acc_map,info::acc_info) ) 0 (Id.Map.empty,[]) @@ -1215,7 +1230,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam let mk_fixes : tactic = let pre_info,infos = list_chop fun_num infos in match pre_info,infos with - | [],[] -> tclIDTAC + | _,[] -> tclIDTAC | _, this_fix_info::others_infos -> let other_fix_infos = List.map @@ -1231,10 +1246,9 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam else Proofview.V82.of_tactic (Tactics.mutual_fix this_fix_info.name (this_fix_info.idx + 1) other_fix_infos 0) - | _ -> anomaly (Pp.str "Not a valid information") in let first_tac : tactic = (* every operations until fix creations *) - tclTHENSEQ + tclTHENLIST [ observe_tac "introducing params" (Proofview.V82.of_tactic (intros_using (List.rev_map id_of_decl princ_info.params))); observe_tac "introducing predictes" (Proofview.V82.of_tactic (intros_using (List.rev_map id_of_decl princ_info.predicates))); observe_tac "introducing branches" (Proofview.V82.of_tactic (intros_using (List.rev_map id_of_decl princ_info.branches))); @@ -1243,16 +1257,16 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam in let intros_after_fixes : tactic = fun gl -> - let ctxt,pte_app = (decompose_prod_assum (pf_concl gl)) in - let pte,pte_args = (decompose_app pte_app) in + let ctxt,pte_app = (decompose_prod_assum (project gl) (pf_concl gl)) in + let pte,pte_args = (decompose_app (project gl) pte_app) in try let pte = - try destVar pte - with DestKO -> anomaly (Pp.str "Property is not a variable") + try destVar (project gl) pte + with DestKO -> anomaly (Pp.str "Property is not a variable.") in let fix_info = Id.Map.find pte ptes_to_fix in let nb_args = fix_info.nb_realargs in - tclTHENSEQ + tclTHENLIST [ (* observe_tac ("introducing args") *) (tclDO nb_args (Proofview.V82.of_tactic intro)); (fun g -> (* replacement of the function by its body *) @@ -1266,18 +1280,18 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam nb_rec_hyps = -100; rec_hyps = []; info = - Reductionops.nf_betaiota Evd.empty + Reductionops.nf_betaiota (pf_env g) (project g) (applist(fix_body,List.rev_map mkVar args_id)); eq_hyps = [] } in - tclTHENSEQ + tclTHENLIST [ observe_tac "do_replace" (do_replace evd full_params (fix_info.idx + List.length princ_params) - (args_id@(List.map (fun decl -> Nameops.out_name (get_name decl)) princ_params)) + (args_id@(List.map (RelDecl.get_name %> Nameops.Name.get_id) princ_params)) (all_funs.(fix_info.num_in_block)) fix_info.num_in_block all_funs @@ -1314,7 +1328,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam ] gl with Not_found -> let nb_args = min (princ_info.nargs) (List.length ctxt) in - tclTHENSEQ + tclTHENLIST [ tclDO nb_args (Proofview.V82.of_tactic intro); (fun g -> (* replacement of the function by its body *) @@ -1326,7 +1340,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam nb_rec_hyps = -100; rec_hyps = []; info = - Reductionops.nf_betaiota Evd.empty + Reductionops.nf_betaiota (pf_env g) Evd.empty (applist(fbody_with_full_params, (List.rev_map var_of_decl princ_params)@ (List.rev_map mkVar args_id) @@ -1334,8 +1348,8 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam eq_hyps = [] } in - let fname = destConst (fst (decompose_app (List.hd (List.rev pte_args)))) in - tclTHENSEQ + let fname = destConst (project g) (fst (decompose_app (project g) (List.hd (List.rev pte_args)))) in + tclTHENLIST [Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalConstRef (fst fname))]); let do_prove = build_proof @@ -1375,7 +1389,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam (* Proof of principles of general functions *) -(* let hrec_id = +(* let hrec_id = Recdef.hrec_id *) (* and acc_inv_id = Recdef.acc_inv_id *) (* and ltof_ref = Recdef.ltof_ref *) (* and acc_rel = Recdef.acc_rel *) @@ -1389,12 +1403,12 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam let prove_with_tcc tcc_lemma_constr eqs : tactic = match !tcc_lemma_constr with - | None -> anomaly (Pp.str "No tcc proof !!") - | Some lemma -> + | Undefined -> anomaly (Pp.str "No tcc proof !!") + | Value lemma -> fun gls -> (* let hid = next_ident_away_in_goal h_id (pf_ids_of_hyps gls) in *) (* let ids = hid::pf_ids_of_hyps gls in *) - tclTHENSEQ + tclTHENLIST [ (* generalize [lemma]; *) (* h_intro hid; *) @@ -1408,7 +1422,7 @@ let prove_with_tcc tcc_lemma_constr eqs : tactic = Proofview.V82.of_tactic (Eauto.gen_eauto (false,5) [] (Some [])) ] gls - + | Not_needed -> tclIDTAC let backtrack_eqs_until_hrec hrec eqs : tactic = fun gls -> @@ -1416,14 +1430,14 @@ let backtrack_eqs_until_hrec hrec eqs : tactic = let rewrite = tclFIRST (List.map (fun x -> Proofview.V82.of_tactic (Equality.rewriteRL x)) eqs ) in - let _,hrec_concl = decompose_prod (pf_unsafe_type_of gls (mkVar hrec)) in - let f_app = Array.last (snd (destApp hrec_concl)) in - let f = (fst (destApp f_app)) in + let _,hrec_concl = decompose_prod (project gls) (pf_unsafe_type_of gls (mkVar hrec)) in + let f_app = Array.last (snd (destApp (project gls) hrec_concl)) in + let f = (fst (destApp (project gls) f_app)) in let rec backtrack : tactic = fun g -> - let f_app = Array.last (snd (destApp (pf_concl g))) in - match kind_of_term f_app with - | App(f',_) when eq_constr f' f -> tclIDTAC g + let f_app = Array.last (snd (destApp (project g) (pf_concl g))) in + match EConstr.kind (project g) f_app with + | App(f',_) when eq_constr (project g) f' f -> tclIDTAC g | _ -> tclTHEN rewrite backtrack g in backtrack gls @@ -1449,13 +1463,13 @@ let rec rewrite_eqs_in_eqs eqs = let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic = fun gls -> - (tclTHENSEQ + (tclTHENLIST [ backtrack_eqs_until_hrec hrec eqs; (* observe_tac ("new_prove_with_tcc ( applying "^(Id.to_string hrec)^" )" ) *) (tclTHENS (* We must have exactly ONE subgoal !*) (Proofview.V82.of_tactic (apply (mkVar hrec))) - [ tclTHENSEQ + [ tclTHENLIST [ (Proofview.V82.of_tactic (keep (tcc_hyps@eqs))); (Proofview.V82.of_tactic (apply (Lazy.force acc_inv))); @@ -1474,7 +1488,7 @@ let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic = tclCOMPLETE( Eauto.eauto_with_bases (true,5) - [{ Tacexpr.delayed = fun _ sigma -> Sigma.here (Lazy.force refl_equal) sigma}] + [(fun _ sigma -> (sigma, Lazy.force refl_equal))] [Hints.Hint_db.empty empty_transparent_state false] ) ) @@ -1487,20 +1501,20 @@ let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic = gls -let is_valid_hypothesis predicates_name = +let is_valid_hypothesis sigma predicates_name = let predicates_name = List.fold_right Id.Set.add predicates_name Id.Set.empty in let is_pte typ = - if isApp typ + if isApp sigma typ then - let pte,_ = destApp typ in - if isVar pte - then Id.Set.mem (destVar pte) predicates_name + let pte,_ = destApp sigma typ in + if isVar sigma pte + then Id.Set.mem (destVar sigma pte) predicates_name else false else false in let rec is_valid_hypothesis typ = is_pte typ || - match kind_of_term typ with + match EConstr.kind sigma typ with | Prod(_,pte,typ') -> is_pte pte && is_valid_hypothesis typ' | _ -> false in @@ -1510,7 +1524,7 @@ let prove_principle_for_gen (f_ref,functional_ref,eq_ref) tcc_lemma_ref is_mes rec_arg_num rec_arg_type relation gl = let princ_type = pf_concl gl in - let princ_info = compute_elim_sig princ_type in + let princ_info = compute_elim_sig (project gl) princ_type in let fresh_id = let avoid = ref (pf_ids_of_hyps gl) in fun na -> @@ -1556,17 +1570,17 @@ let prove_principle_for_gen | _ -> assert false in (* observe (str "rec_arg_id := " ++ pr_lconstr (mkVar rec_arg_id)); *) - let subst_constrs = List.map (fun decl -> mkVar (Nameops.out_name (get_name decl))) (pre_rec_arg@princ_info.params) in + let subst_constrs = List.map (get_name %> Nameops.Name.get_id %> mkVar) (pre_rec_arg@princ_info.params) in let relation = substl subst_constrs relation in let input_type = substl subst_constrs rec_arg_type in - let wf_thm_id = Nameops.out_name (fresh_id (Name (Id.of_string "wf_R"))) in + let wf_thm_id = Nameops.Name.get_id (fresh_id (Name (Id.of_string "wf_R"))) in let acc_rec_arg_id = - Nameops.out_name (fresh_id (Name (Id.of_string ("Acc_"^(Id.to_string rec_arg_id))))) + Nameops.Name.get_id (fresh_id (Name (Id.of_string ("Acc_"^(Id.to_string rec_arg_id))))) in let revert l = tclTHEN (Proofview.V82.of_tactic (Tactics.generalize (List.map mkVar l))) (Proofview.V82.of_tactic (clear l)) in - let fix_id = Nameops.out_name (fresh_id (Name hrec_id)) in + let fix_id = Nameops.Name.get_id (fresh_id (Name hrec_id)) in let prove_rec_arg_acc g = ((* observe_tac "prove_rec_arg_acc" *) (tclCOMPLETE @@ -1584,11 +1598,12 @@ let prove_principle_for_gen ) g in - let args_ids = List.map (fun decl -> Nameops.out_name (get_name decl)) princ_info.args in + let args_ids = List.map (get_name %> Nameops.Name.get_id) princ_info.args in let lemma = match !tcc_lemma_ref with - | None -> error "No tcc proof !!" - | Some lemma -> lemma + | Undefined -> user_err Pp.(str "No tcc proof !!") + | Value lemma -> EConstr.of_constr lemma + | Not_needed -> EConstr.of_constr (Universes.constr_of_global @@ Coqlib.build_coq_I ()) in (* let rec list_diff del_list check_list = *) (* match del_list with *) @@ -1606,9 +1621,9 @@ let prove_principle_for_gen let hid = next_ident_away_in_goal (Id.of_string "prov") - hyps + (Id.Set.of_list hyps) in - tclTHENSEQ + tclTHENLIST [ Proofview.V82.of_tactic (generalize [lemma]); Proofview.V82.of_tactic (Simple.intro hid); @@ -1627,11 +1642,11 @@ let prove_principle_for_gen ] gls in - tclTHENSEQ + tclTHENLIST [ observe_tac "start_tac" start_tac; h_intros - (List.rev_map (fun decl -> Nameops.out_name (get_name decl)) + (List.rev_map (get_name %> Nameops.Name.get_id) (princ_info.args@princ_info.branches@princ_info.predicates@princ_info.params) ); (* observe_tac "" *) Proofview.V82.of_tactic (assert_by @@ -1648,7 +1663,7 @@ let prove_principle_for_gen Proofview.V82.of_tactic (Equality.rewriteLR (mkConst eq_ref)); (* observe_tac "finish" *) (fun gl' -> let body = - let _,args = destApp (pf_concl gl') in + let _,args = destApp (project gl') (pf_concl gl') in Array.last args in let body_info rec_hyps = @@ -1669,14 +1684,14 @@ let prove_principle_for_gen in let acc_inv = lazy (mkApp(Lazy.force acc_inv, [|mkVar acc_rec_arg_id|])) in let predicates_names = - List.map (fun decl -> Nameops.out_name (get_name decl)) princ_info.predicates + List.map (get_name %> Nameops.Name.get_id) princ_info.predicates in let pte_info = { proving_tac = (fun eqs -> (* msgnl (str "tcc_list := "++ prlist_with_sep spc Ppconstr.pr_id !tcc_list); *) -(* msgnl (str "princ_info.args := "++ prlist_with_sep spc Ppconstr.pr_id (List.map (fun (na,_,_) -> (Nameops.out_name na)) princ_info.args)); *) -(* msgnl (str "princ_info.params := "++ prlist_with_sep spc Ppconstr.pr_id (List.map (fun (na,_,_) -> (Nameops.out_name na)) princ_info.params)); *) +(* msgnl (str "princ_info.args := "++ prlist_with_sep spc Ppconstr.pr_id (List.map (fun (na,_,_) -> (Nameops.Name.get_id na)) princ_info.args)); *) +(* msgnl (str "princ_info.params := "++ prlist_with_sep spc Ppconstr.pr_id (List.map (fun (na,_,_) -> (Nameops.Name.get_id na)) princ_info.params)); *) (* msgnl (str "acc_rec_arg_id := "++ Ppconstr.pr_id acc_rec_arg_id); *) (* msgnl (str "eqs := "++ prlist_with_sep spc Ppconstr.pr_id eqs); *) @@ -1685,13 +1700,13 @@ let prove_principle_for_gen is_mes acc_inv fix_id (!tcc_list@(List.map - (fun decl -> (Nameops.out_name (get_name decl))) + (get_name %> Nameops.Name.get_id) (princ_info.args@princ_info.params) )@ ([acc_rec_arg_id])) eqs ) ); - is_valid = is_valid_hypothesis predicates_names + is_valid = is_valid_hypothesis (project gl') predicates_names } in let ptes_info : pte_info Id.Map.t = @@ -1714,7 +1729,7 @@ let prove_principle_for_gen (* observe_tac "instanciate_hyps_with_args" *) (instanciate_hyps_with_args make_proof - (List.map (fun decl -> Nameops.out_name (get_name decl)) princ_info.branches) + (List.map (get_name %> Nameops.Name.get_id) princ_info.branches) (List.rev args_ids) ) gl' diff --git a/plugins/funind/functional_principles_proofs.mli b/plugins/funind/functional_principles_proofs.mli index 34ce6696..64fbfaee 100644 --- a/plugins/funind/functional_principles_proofs.mli +++ b/plugins/funind/functional_principles_proofs.mli @@ -1,19 +1,18 @@ open Names -open Term val prove_princ_for_struct : Evd.evar_map ref -> bool -> - int -> constant array -> constr array -> int -> Tacmach.tactic + int -> Constant.t array -> EConstr.constr array -> int -> Tacmach.tactic val prove_principle_for_gen : - constant*constant*constant -> (* name of the function, the functional and the fixpoint equation *) - constr option ref -> (* a pointer to the obligation proofs lemma *) + Constant.t * Constant.t * Constant.t -> (* name of the function, the functional and the fixpoint equation *) + Indfun_common.tcc_lemma_value ref -> (* a pointer to the obligation proofs lemma *) bool -> (* is that function uses measure *) int -> (* the number of recursive argument *) - types -> (* the type of the recursive argument *) - constr -> (* the wf relation used to prove the function *) + EConstr.types -> (* the type of the recursive argument *) + EConstr.constr -> (* the wf relation used to prove the function *) Tacmach.tactic diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index 5e72b867..804548ce 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -1,7 +1,9 @@ open Printer open CErrors -open Util open Term +open Sorts +open Util +open Constr open Vars open Namegen open Names @@ -11,8 +13,8 @@ open Tactics open Context.Rel.Declaration open Indfun_common open Functional_principles_proofs -open Misctypes -open Sigma.Notations + +module RelDecl = Context.Rel.Declaration exception Toberemoved_with_rel of int*constr exception Toberemoved @@ -21,25 +23,28 @@ let observe s = if do_observe () then Feedback.msg_debug s +let pop t = Vars.lift (-1) t + (* Transform an inductive induction principle into a functional one *) let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = - let princ_type_info = compute_elim_sig princ_type in + let princ_type = EConstr.of_constr princ_type in + let princ_type_info = compute_elim_sig Evd.empty princ_type (** FIXME *) in let env = Global.env () in - let env_with_params = Environ.push_rel_context princ_type_info.params env in + let env_with_params = EConstr.push_rel_context princ_type_info.params env in let tbl = Hashtbl.create 792 in - let rec change_predicates_names (avoid:Id.t list) (predicates:Context.Rel.t) : Context.Rel.t = + let rec change_predicates_names (avoid:Id.t list) (predicates:EConstr.rel_context) : EConstr.rel_context = match predicates with | [] -> [] | decl :: predicates -> (match Context.Rel.Declaration.get_name decl with | Name x -> - let id = Namegen.next_ident_away x avoid in + let id = Namegen.next_ident_away x (Id.Set.of_list avoid) in Hashtbl.add tbl id x; - set_name (Name id) decl :: change_predicates_names (id::avoid) predicates - | Anonymous -> anomaly (Pp.str "Anonymous property binder ")) + RelDecl.set_name (Name id) decl :: change_predicates_names (id::avoid) predicates + | Anonymous -> anomaly (Pp.str "Anonymous property binder.")) in let avoid = (Termops.ids_of_context env_with_params ) in let princ_type_info = @@ -51,14 +56,14 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = (* observe (str "princ_infos : " ++ pr_elim_scheme princ_type_info); *) let change_predicate_sort i decl = let new_sort = sorts.(i) in - let args,_ = decompose_prod (get_type decl) in + let args,_ = decompose_prod (EConstr.Unsafe.to_constr (RelDecl.get_type decl)) in let real_args = if princ_type_info.indarg_in_concl then List.tl args else args in - Context.Named.Declaration.LocalAssum (Nameops.out_name (Context.Rel.Declaration.get_name decl), - compose_prod real_args (mkSort new_sort)) + Context.Named.Declaration.LocalAssum (Nameops.Name.get_id (Context.Rel.Declaration.get_name decl), + Term.compose_prod real_args (mkSort new_sort)) in let new_predicates = List.map_i @@ -70,18 +75,19 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = let rel_as_kn = fst (match princ_type_info.indref with | Some (Globnames.IndRef ind) -> ind - | _ -> error "Not a valid predicate" + | _ -> user_err Pp.(str "Not a valid predicate") ) in let ptes_vars = List.map Context.Named.Declaration.get_id new_predicates in let is_pte = let set = List.fold_right Id.Set.add ptes_vars Id.Set.empty in fun t -> - match kind_of_term t with + match Constr.kind t with | Var id -> Id.Set.mem id set | _ -> false in let pre_princ = + let open EConstr in it_mkProd_or_LetIn (it_mkProd_or_LetIn (Option.fold_right @@ -93,28 +99,31 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = ) princ_type_info.branches in + let pre_princ = EConstr.Unsafe.to_constr pre_princ in let pre_princ = substl (List.map mkVar ptes_vars) pre_princ in let is_dom c = - match kind_of_term c with + match Constr.kind c with | 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 + match Constr.kind c with | Ind((_,num),_) -> num | Construct(((_,num),_),_) -> num | _ -> assert false in let dummy_var = mkVar (Id.of_string "________") in let mk_replacement c i args = - let res = mkApp(rel_to_fun.(i), Array.map Termops.pop (array_get_start args)) in - observe (str "replacing " ++ pr_lconstr c ++ str " by " ++ pr_lconstr res); + let res = mkApp(rel_to_fun.(i), Array.map pop (array_get_start args)) in + observe (str "replacing " ++ + pr_lconstr_env env Evd.empty c ++ str " by " ++ + pr_lconstr_env env Evd.empty res); res in let rec compute_new_princ_type remove env pre_princ : types*(constr list) = let (new_princ_type,_) as res = - match kind_of_term pre_princ with + match Constr.kind pre_princ with | Rel n -> begin try match Environ.lookup_rel n env with @@ -143,13 +152,13 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = ([],[]) in let new_f,binders_to_remove_from_f = compute_new_princ_type remove env f in - applist(new_f, new_args), - list_union_eq eq_constr binders_to_remove_from_f binders_to_remove + applistc new_f new_args, + list_union_eq Constr.equal binders_to_remove_from_f binders_to_remove | LetIn(x,v,t,b) -> compute_new_princ_type_for_letin remove env x v t b | _ -> pre_princ,[] in -(* let _ = match kind_of_term pre_princ with *) +(* let _ = match Constr.kind pre_princ with *) (* | Prod _ -> *) (* observe(str "compute_new_princ_type for "++ *) (* pr_lconstr_env env pre_princ ++ *) @@ -165,26 +174,26 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = let new_x : Name.t = get_name (Termops.ids_of_context env) x in let new_env = Environ.push_rel (LocalAssum (x,t)) env in let new_b,binders_to_remove_from_b = compute_new_princ_type remove new_env b in - if List.exists (eq_constr (mkRel 1)) binders_to_remove_from_b - then (Termops.pop new_b), filter_map (eq_constr (mkRel 1)) Termops.pop binders_to_remove_from_b + if List.exists (Constr.equal (mkRel 1)) binders_to_remove_from_b + then (pop new_b), filter_map (Constr.equal (mkRel 1)) pop binders_to_remove_from_b else ( bind_fun(new_x,new_t,new_b), list_union_eq - eq_constr + Constr.equal binders_to_remove_from_t - (List.map Termops.pop binders_to_remove_from_b) + (List.map pop binders_to_remove_from_b) ) with | Toberemoved -> -(* observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *) +(* observe (str "Decl of "++Ppconstr.Name.print x ++ str " is removed "); *) let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [dummy_var] 1 b) in - new_b, List.map Termops.pop binders_to_remove_from_b + new_b, List.map pop binders_to_remove_from_b | Toberemoved_with_rel (n,c) -> -(* observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *) +(* observe (str "Decl of "++Ppconstr.Name.print x ++ str " is removed "); *) let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [c] n b) in - new_b, list_add_set_eq eq_constr (mkRel n) (List.map Termops.pop binders_to_remove_from_b) + new_b, list_add_set_eq Constr.equal (mkRel n) (List.map pop binders_to_remove_from_b) end and compute_new_princ_type_for_letin remove env x v t b = begin @@ -194,31 +203,31 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = let new_x : Name.t = get_name (Termops.ids_of_context env) x in let new_env = Environ.push_rel (LocalDef (x,v,t)) env in let new_b,binders_to_remove_from_b = compute_new_princ_type remove new_env b in - if List.exists (eq_constr (mkRel 1)) binders_to_remove_from_b - then (Termops.pop new_b),filter_map (eq_constr (mkRel 1)) Termops.pop binders_to_remove_from_b + if List.exists (Constr.equal (mkRel 1)) binders_to_remove_from_b + then (pop new_b),filter_map (Constr.equal (mkRel 1)) pop binders_to_remove_from_b else ( mkLetIn(new_x,new_v,new_t,new_b), list_union_eq - eq_constr - (list_union_eq eq_constr binders_to_remove_from_t binders_to_remove_from_v) - (List.map Termops.pop binders_to_remove_from_b) + Constr.equal + (list_union_eq Constr.equal binders_to_remove_from_t binders_to_remove_from_v) + (List.map pop binders_to_remove_from_b) ) with | Toberemoved -> -(* observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *) +(* observe (str "Decl of "++Ppconstr.Name.print x ++ str " is removed "); *) let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [dummy_var] 1 b) in - new_b, List.map Termops.pop binders_to_remove_from_b + new_b, List.map pop binders_to_remove_from_b | Toberemoved_with_rel (n,c) -> -(* observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *) +(* observe (str "Decl of "++Ppconstr.Name.print x ++ str " is removed "); *) let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [c] n b) in - new_b, list_add_set_eq eq_constr (mkRel n) (List.map Termops.pop binders_to_remove_from_b) + new_b, list_add_set_eq Constr.equal (mkRel n) (List.map pop binders_to_remove_from_b) end and compute_new_princ_type_with_acc remove env e (c_acc,to_remove_acc) = let new_e,to_remove_from_e = compute_new_princ_type remove env e in - new_e::c_acc,list_union_eq eq_constr to_remove_from_e to_remove_acc + new_e::c_acc,list_union_eq Constr.equal to_remove_from_e to_remove_acc in (* observe (str "Computing new principe from " ++ pr_lconstr_env env_with_params_and_predicates pre_princ); *) let pre_res,_ = @@ -235,20 +244,21 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = | Context.Named.Declaration.LocalDef (id,t,b) -> LocalDef (Name (Hashtbl.find tbl id), t, b)) new_predicates) ) - princ_type_info.params + (List.map (fun d -> Termops.map_rel_decl EConstr.Unsafe.to_constr d) princ_type_info.params) let change_property_sort evd toSort princ princName = let open Context.Rel.Declaration in - let princ_info = compute_elim_sig princ in + let princ = EConstr.of_constr princ in + let princ_info = compute_elim_sig evd princ in let change_sort_in_predicate decl = LocalAssum (get_name decl, - let args,ty = decompose_prod (get_type decl) in + let args,ty = decompose_prod (EConstr.Unsafe.to_constr (get_type decl)) 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) + Term.compose_prod args (mkSort toSort) ) in let evd,princName_as_constr = @@ -264,11 +274,11 @@ let change_property_sort evd toSort princ princName = (it_mkLambda_or_LetIn init (List.map change_sort_in_predicate princ_info.predicates) ) - princ_info.params + (List.map (fun d -> Termops.map_rel_decl EConstr.Unsafe.to_constr d) princ_info.params) let build_functional_principle (evd:Evd.evar_map ref) interactive_proof old_princ_type sorts funs i proof_tac hook = (* First we get the type of the old graph principle *) - let mutr_nparams = (compute_elim_sig old_princ_type).nparams in + let mutr_nparams = (compute_elim_sig !evd (EConstr.of_constr old_princ_type)).nparams in (* let time1 = System.get_time () in *) let new_principle_type = compute_new_princ_type_from_rel @@ -279,20 +289,21 @@ let build_functional_principle (evd:Evd.evar_map ref) interactive_proof old_prin (* let time2 = System.get_time () in *) (* Pp.msgnl (str "computing principle type := " ++ System.fmt_time_difference time1 time2); *) let new_princ_name = - next_ident_away_in_goal (Id.of_string "___________princ_________") [] + next_ident_away_in_goal (Id.of_string "___________princ_________") Id.Set.empty in - let _ = Typing.e_type_of ~refresh:true (Global.env ()) evd new_principle_type in + let _ = Typing.e_type_of ~refresh:true (Global.env ()) evd (EConstr.of_constr new_principle_type) in let hook = Lemmas.mk_hook (hook new_principle_type) in begin Lemmas.start_proof new_princ_name (Decl_kinds.Global,Flags.is_universe_polymorphism (),(Decl_kinds.Proof Decl_kinds.Theorem)) !evd - new_principle_type + (EConstr.of_constr new_principle_type) hook ; (* let _tim1 = System.get_time () in *) - ignore (Pfedit.by (Proofview.V82.tactic (proof_tac (Array.map mkConstU funs) mutr_nparams))); + let map (c, u) = EConstr.mkConstU (c, EConstr.EInstance.make u) in + ignore (Pfedit.by (Proofview.V82.tactic (proof_tac (Array.map map funs) mutr_nparams))); (* let _tim2 = System.get_time () in *) (* begin *) (* let dur1 = System.time_difference tim1 tim2 in *) @@ -321,8 +332,8 @@ let generate_functional_principle (evd: Evd.evar_map ref) match new_princ_name with | Some (id) -> id,id | None -> - let id_of_f = Label.to_id (con_label (fst f)) in - id_of_f,Indrec.make_elimination_ident id_of_f (family_of_sort type_sort) + let id_of_f = Label.to_id (Constant.label (fst f)) in + id_of_f,Indrec.make_elimination_ident id_of_f (Sorts.family type_sort) in let names = ref [new_princ_name] in let hook = @@ -331,13 +342,17 @@ let generate_functional_principle (evd: Evd.evar_map ref) then (* let id_of_f = Label.to_id (con_label f) in *) let register_with_sort fam_sort = - let evd' = Evd.from_env (Global.env ()) in - let evd',s = Evd.fresh_sort_in_family env evd' fam_sort in - let name = Indrec.make_elimination_ident base_new_princ_name fam_sort in - let evd',value = change_property_sort evd' s new_principle_type new_princ_name in - let evd' = fst (Typing.type_of ~refresh:true (Global.env ()) evd' value) in - (* Pp.msgnl (str "new principle := " ++ pr_lconstr value); *) - let ce = Declare.definition_entry ~poly:(Flags.is_universe_polymorphism ()) ~univs:(snd (Evd.universe_context evd')) value in + let evd' = Evd.from_env (Global.env ()) in + let evd',s = Evd.fresh_sort_in_family env evd' fam_sort in + let name = Indrec.make_elimination_ident base_new_princ_name fam_sort in + let evd',value = change_property_sort evd' s new_principle_type new_princ_name in + let evd' = fst (Typing.type_of ~refresh:true (Global.env ()) evd' (EConstr.of_constr value)) in + (* Pp.msgnl (str "new principle := " ++ pr_lconstr value); *) + let univs = + let poly = Flags.is_universe_polymorphism () in + Evd.const_univ_entry ~poly evd' + in + let ce = Declare.definition_entry ~univs value in ignore( Declare.declare_constant name @@ -362,12 +377,12 @@ let generate_functional_principle (evd: Evd.evar_map ref) begin begin try - let id = Pfedit.get_current_proof_name () in + let id = Proof_global.get_current_proof_name () in let s = Id.to_string id in let n = String.length "___________princ_________" in if String.length s >= n then if String.equal (String.sub s 0 n) "___________princ_________" - then Pfedit.delete_current_proof () + then Proof_global.discard_current () else () else () with e when CErrors.noncritical e -> () @@ -380,17 +395,17 @@ let generate_functional_principle (evd: Evd.evar_map ref) exception Not_Rec let get_funs_constant mp dp = - let get_funs_constant const e : (Names.constant*int) array = - match kind_of_term ((strip_lam e)) with + let get_funs_constant const e : (Names.Constant.t*int) array = + match Constr.kind ((strip_lam e)) with | Fix((_,(na,_,_))) -> Array.mapi (fun i na -> match na with | Name id -> - let const = make_con mp dp (Label.of_id id) in + let const = Constant.make3 mp dp (Label.of_id id) in const,i | Anonymous -> - anomaly (Pp.str "Anonymous fix") + anomaly (Pp.str "Anonymous fix.") ) na | _ -> [|const,0|] @@ -398,15 +413,16 @@ let get_funs_constant mp dp = function const -> let find_constant_body const = match Global.body_of_constant const with - | Some body -> + | Some (body, _) -> let body = Tacred.cbv_norm_flags (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) (Global.env ()) (Evd.from_env (Global.env ())) - body + (EConstr.of_constr body) in + let body = EConstr.Unsafe.to_constr body in body - | None -> error ( "Cannot define a principle over an axiom ") + | None -> user_err Pp.(str ( "Cannot define a principle over an axiom ")) in let f = find_constant_body const in let l_const = get_funs_constant const f in @@ -421,8 +437,8 @@ let get_funs_constant mp dp = let first_params = List.hd l_params in List.iter (fun params -> - if not (List.equal (fun (n1, c1) (n2, c2) -> Name.equal n1 n2 && eq_constr c1 c2) first_params params) - then error "Not a mutal recursive block" + if not (List.equal (fun (n1, c1) (n2, c2) -> Name.equal n1 n2 && Constr.equal c1 c2) first_params params) + then user_err Pp.(str "Not a mutal recursive block") ) l_params in @@ -430,21 +446,21 @@ let get_funs_constant mp dp = let _check_bodies = try let extract_info is_first body = - match kind_of_term body with + match Constr.kind body with | Fix((idxs,_),(na,ta,ca)) -> (idxs,na,ta,ca) | _ -> if is_first && Int.equal (List.length l_bodies) 1 then raise Not_Rec - else error "Not a mutal recursive block" + else user_err Pp.(str "Not a mutal recursive block") in let first_infos = extract_info true (List.hd l_bodies) in let check body = (* Hope this is correct *) let eq_infos (ia1, na1, ta1, ca1) (ia2, na2, ta2, ca2) = Array.equal Int.equal ia1 ia2 && Array.equal Name.equal na1 na2 && - Array.equal eq_constr ta1 ta2 && Array.equal eq_constr ca1 ca2 + Array.equal Constr.equal ta1 ta2 && Array.equal Constr.equal ca1 ca2 in if not (eq_infos first_infos (extract_info false body)) - then error "Not a mutal recursive block" + then user_err Pp.(str "Not a mutal recursive block") in List.iter check l_bodies with Not_Rec -> () @@ -454,7 +470,7 @@ let get_funs_constant mp dp = exception No_graph_found exception Found_type of int -let make_scheme evd (fas : (pconstant*glob_sort) list) : Safe_typing.private_constants definition_entry list = +let make_scheme evd (fas : (pconstant*Sorts.family) list) : Safe_typing.private_constants definition_entry list = let env = Global.env () in let funs = List.map fst fas in let first_fun = List.hd funs in @@ -486,12 +502,12 @@ let make_scheme evd (fas : (pconstant*glob_sort) list) : Safe_typing.private_con in let _ = evd := sigma in let l_schemes = - List.map (Typing.unsafe_type_of env sigma) schemes + List.map (EConstr.of_constr %> Typing.unsafe_type_of env sigma %> EConstr.Unsafe.to_constr) schemes in let i = ref (-1) in let sorts = List.rev_map (fun (_,x) -> - Evarutil.evd_comb1 (Evd.fresh_sort_in_family env) evd (Pretyping.interp_elimination_sort x) + Evarutil.evd_comb1 (Evd.fresh_sort_in_family env) evd x ) fas in @@ -514,12 +530,12 @@ let make_scheme evd (fas : (pconstant*glob_sort) list) : Safe_typing.private_con begin begin try - let id = Pfedit.get_current_proof_name () in + let id = Proof_global.get_current_proof_name () in let s = Id.to_string id in let n = String.length "___________princ_________" in if String.length s >= n then if String.equal (String.sub s 0 n) "___________princ_________" - then Pfedit.delete_current_proof () + then Proof_global.discard_current () else () else () with e when CErrors.noncritical e -> () @@ -555,7 +571,7 @@ let make_scheme evd (fas : (pconstant*glob_sort) list) : Safe_typing.private_con List.map (* we can now compute the other principles *) (fun scheme_type -> incr i; - observe (Printer.pr_lconstr scheme_type); + observe (Printer.pr_lconstr_env env sigma scheme_type); let type_concl = (strip_prod_assum scheme_type) in let applied_f = List.hd (List.rev (snd (decompose_app type_concl))) in let f = fst (decompose_app applied_f) in @@ -565,10 +581,10 @@ let make_scheme evd (fas : (pconstant*glob_sort) list) : Safe_typing.private_con let t = (strip_prod_assum t) in let applied_g = List.hd (List.rev (snd (decompose_app t))) in let g = fst (decompose_app applied_g) in - if eq_constr f g + if Constr.equal f g then raise (Found_type j); - observe (Printer.pr_lconstr f ++ str " <> " ++ - Printer.pr_lconstr g) + observe (Printer.pr_lconstr_env env sigma f ++ str " <> " ++ + Printer.pr_lconstr_env env sigma g) ) ta; @@ -609,19 +625,22 @@ let build_scheme fas = try Smartlocate.global_with_alias f with Not_found -> - errorlabstrm "FunInd.build_scheme" + user_err ~hdr:"FunInd.build_scheme" (str "Cannot find " ++ Libnames.pr_reference f) in - let evd',f = Evd.fresh_global (Global.env ()) !evd f_as_constant in + let evd',f = Evd.fresh_global (Global.env ()) !evd f_as_constant in let _ = evd := evd' in - let _ = Typing.e_type_of ~refresh:true (Global.env ()) evd f in - (destConst f,sort) + let _ = Typing.e_type_of ~refresh:true (Global.env ()) evd (EConstr.of_constr f) in + if isConst f + then (destConst f,sort) + else user_err Pp.(pr_constr_env (Global.env ()) !evd f ++spc () ++ str "should be the named of a globally defined function") ) fas ) in let bodies_types = make_scheme evd pconstants in + List.iter2 (fun (princ_id,_,_) def_entry -> ignore @@ -641,12 +660,12 @@ let build_case_scheme fa = (* in *) let funs = let (_,f,_) = fa in - try fst (Universes.unsafe_constr_of_global (Smartlocate.global_with_alias f)) + try fst (Global.constr_of_global_in_context (Global.env ()) (Smartlocate.global_with_alias f)) with Not_found -> - errorlabstrm "FunInd.build_case_scheme" + user_err ~hdr:"FunInd.build_case_scheme" (str "Cannot find " ++ Libnames.pr_reference f) in let first_fun,u = destConst funs in - let funs_mp,funs_dp,_ = Names.repr_con first_fun in + let funs_mp,funs_dp,_ = Constant.repr3 first_fun in let first_fun_kn = try fst (find_Function_infos first_fun).graph_ind with Not_found -> raise No_graph_found in let this_block_funs_indexes = get_funs_constant funs_mp funs_dp first_fun in let this_block_funs = Array.map (fun (c,_) -> (c,u)) this_block_funs_indexes in @@ -659,15 +678,13 @@ let build_case_scheme fa = let ind = first_fun_kn,funs_indexes in (ind,Univ.Instance.empty)(*FIXME*),prop_sort in - let sigma = Sigma.Unsafe.of_evar_map sigma in - let Sigma (scheme, sigma, _) = + let (sigma, scheme) = Indrec.build_case_analysis_scheme_default env sigma ind sf in - let sigma = Sigma.to_evar_map sigma in - let scheme_type = (Typing.unsafe_type_of env sigma ) scheme in + let scheme_type = EConstr.Unsafe.to_constr ((Typing.unsafe_type_of env sigma) (EConstr.of_constr scheme)) in let sorts = (fun (_,_,x) -> - Universes.new_sort_in_family (Pretyping.interp_elimination_sort x) + Universes.new_sort_in_family x ) fa in diff --git a/plugins/funind/functional_principles_types.mli b/plugins/funind/functional_principles_types.mli index 3fa2644c..33aeafef 100644 --- a/plugins/funind/functional_principles_types.mli +++ b/plugins/funind/functional_principles_types.mli @@ -1,14 +1,15 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) open Names -open Term -open Misctypes +open Constr val generate_functional_principle : Evd.evar_map ref -> @@ -17,7 +18,7 @@ val generate_functional_principle : (* induction principle on rel *) types -> (* *) - sorts array option -> + Sorts.t array option -> (* Name of the new principle *) (Id.t) option -> (* the compute functions to use *) @@ -27,18 +28,13 @@ val generate_functional_principle : (* The tactic to use to make the proof w.r the number of params *) - (constr array -> int -> Tacmach.tactic) -> + (EConstr.constr array -> int -> Tacmach.tactic) -> unit -val compute_new_princ_type_from_rel : constr array -> sorts array -> - types -> types - - exception No_graph_found val make_scheme : Evd.evar_map ref -> - (pconstant*glob_sort) list -> Safe_typing.private_constants Entries.definition_entry list - -val build_scheme : (Id.t*Libnames.reference*glob_sort) list -> unit -val build_case_scheme : (Id.t*Libnames.reference*glob_sort) -> unit + (pconstant*Sorts.family) list -> Safe_typing.private_constants Entries.definition_entry list +val build_scheme : (Id.t*Libnames.reference*Sorts.family) list -> unit +val build_case_scheme : (Id.t*Libnames.reference*Sorts.family) -> unit diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4 index 42e49031..90af20b4 100644 --- a/plugins/funind/g_indfun.ml4 +++ b/plugins/funind/g_indfun.ml4 @@ -1,47 +1,32 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) -(*i camlp4deps: "grammar/grammar.cma" i*) -open Compat +open Ltac_plugin open Util -open Term open Pp open Constrexpr open Indfun_common open Indfun open Genarg -open Constrarg +open Stdarg open Misctypes +open Pcoq open Pcoq.Prim open Pcoq.Constr -open Pcoq.Tactic +open Pltac DECLARE PLUGIN "recdef_plugin" -let pr_binding prc = function - | loc, NamedHyp id, c -> hov 1 (Ppconstr.pr_id id ++ str " := " ++ cut () ++ prc c) - | loc, AnonHyp n, c -> hov 1 (int n ++ str " := " ++ cut () ++ prc c) - -let pr_bindings prc prlc = function - | ImplicitBindings l -> - brk (1,1) ++ str "with" ++ brk (1,1) ++ - pr_sequence prc l - | ExplicitBindings l -> - brk (1,1) ++ str "with" ++ brk (1,1) ++ - pr_sequence (fun b -> str"(" ++ pr_binding prlc b ++ str")") l - | NoBindings -> mt () - -let pr_with_bindings prc prlc (c,bl) = - prc c ++ hv 0 (pr_bindings prc prlc bl) - let pr_fun_ind_using prc prlc _ opt_c = match opt_c with | None -> mt () - | Some b -> spc () ++ hov 2 (str "using" ++ spc () ++ pr_with_bindings prc prlc b) + | Some b -> spc () ++ hov 2 (str "using" ++ spc () ++ Miscprint.pr_with_bindings prc prlc b) (* Duplication of printing functions because "'a with_bindings" is (internally) not uniform in 'a: indeed constr_with_bindings at the @@ -49,16 +34,12 @@ let pr_fun_ind_using prc prlc _ opt_c = "constr with_bindings"; hence, its printer cannot be polymorphic in (prc,prlc)... *) -let pr_with_bindings_typed prc prlc (c,bl) = - prc c ++ - hv 0 (pr_bindings prc prlc bl) - let pr_fun_ind_using_typed prc prlc _ opt_c = match opt_c with | None -> mt () | Some b -> - let (b, _) = Tactics.run_delayed (Global.env ()) Evd.empty b in - spc () ++ hov 2 (str "using" ++ spc () ++ pr_with_bindings_typed prc prlc b) + let (_, b) = b (Global.env ()) Evd.empty in + spc () ++ hov 2 (str "using" ++ spc () ++ Miscprint.pr_with_bindings prc prlc b) ARGUMENT EXTEND fun_ind_using @@ -80,7 +61,6 @@ TACTIC EXTEND newfuninv ] END - let pr_intro_as_pat _prc _ _ pat = match pat with | Some pat -> @@ -88,16 +68,17 @@ let pr_intro_as_pat _prc _ _ pat = str"<simple_intropattern>" | None -> mt () -let out_disjunctive = function - | loc, IntroAction (IntroOrAndPattern l) -> (loc,l) - | _ -> CErrors.error "Disjunctive or conjunctive intro pattern expected." +let out_disjunctive = CAst.map (function + | IntroAction (IntroOrAndPattern l) -> l + | _ -> CErrors.user_err Pp.(str "Disjunctive or conjunctive intro pattern expected.")) ARGUMENT EXTEND with_names TYPED AS intropattern_opt PRINTED BY pr_intro_as_pat | [ "as" simple_intropattern(ipat) ] -> [ Some ipat ] | [] ->[ None ] END - +let functional_induction b c x pat = + Proofview.V82.tactic (functional_induction true c x (Option.map out_disjunctive pat)) TACTIC EXTEND newfunind @@ -106,9 +87,9 @@ TACTIC EXTEND newfunind let c = match cl with | [] -> assert false | [c] -> c - | c::cl -> applist(c,cl) + | c::cl -> EConstr.applist(c,cl) in - Extratactics.onSomeWithHoles (fun x -> Proofview.V82.tactic (functional_induction true c x (Option.map out_disjunctive pat))) princl ] + Extratactics.onSomeWithHoles (fun x -> functional_induction true c x pat) princl ] END (***** debug only ***) TACTIC EXTEND snewfunind @@ -117,9 +98,9 @@ TACTIC EXTEND snewfunind let c = match cl with | [] -> assert false | [c] -> c - | c::cl -> applist(c,cl) + | c::cl -> EConstr.applist(c,cl) in - Extratactics.onSomeWithHoles (fun x -> Proofview.V82.tactic (functional_induction false c x (Option.map out_disjunctive pat))) princl ] + Extratactics.onSomeWithHoles (fun x -> functional_induction false c x pat) princl ] END @@ -143,7 +124,7 @@ END module Gram = Pcoq.Gram module Vernac = Pcoq.Vernac_ -module Tactic = Pcoq.Tactic +module Tactic = Pltac type function_rec_definition_loc_argtype = (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) Loc.located @@ -157,15 +138,14 @@ GEXTEND Gram GLOBAL: function_rec_definition_loc ; function_rec_definition_loc: - [ [ g = Vernac.rec_definition -> !@loc, g ]] + [ [ g = Vernac.rec_definition -> Loc.tag ~loc:!@loc g ]] ; END let () = let raw_printer _ _ _ (loc,body) = Ppvernac.pr_rec_definition body in - let printer _ _ _ _ = str "<Unavailable printer for rec_definition>" in - Pptactic.declare_extra_genarg_pprule wit_function_rec_definition_loc raw_printer printer printer + Pptactic.declare_extra_vernac_genarg_pprule wit_function_rec_definition_loc raw_printer (* TASSI: n'importe quoi ! *) VERNAC COMMAND EXTEND Function @@ -175,7 +155,7 @@ VERNAC COMMAND EXTEND Function | _,((_,(_,CStructRec),_,_,_),_) -> false) recsl in match Vernac_classifier.classify_vernac - (Vernacexpr.VernacFixpoint(None, List.map snd recsl)) + (Vernacexpr.(VernacExpr([], VernacFixpoint(Decl_kinds.NoDischarge, List.map snd recsl)))) with | Vernacexpr.VtSideff ids, _ when hard -> Vernacexpr.(VtStartProof ("Classic", GuaranteesOpacity, ids), VtLater) @@ -184,13 +164,13 @@ VERNAC COMMAND EXTEND Function END let pr_fun_scheme_arg (princ_name,fun_name,s) = - Nameops.pr_id princ_name ++ str " :=" ++ spc() ++ str "Induction for " ++ + Names.Id.print princ_name ++ str " :=" ++ spc() ++ str "Induction for " ++ Libnames.pr_reference fun_name ++ spc() ++ str "Sort " ++ - Ppconstr.pr_glob_sort s + Termops.pr_sort_family s VERNAC ARGUMENT EXTEND fun_scheme_arg PRINTED BY pr_fun_scheme_arg -| [ ident(princ_name) ":=" "Induction" "for" reference(fun_name) "Sort" sort(s) ] -> [ (princ_name,fun_name,s) ] +| [ ident(princ_name) ":=" "Induction" "for" reference(fun_name) "Sort" sort_family(s) ] -> [ (princ_name,fun_name,s) ] END @@ -227,7 +207,7 @@ VERNAC COMMAND EXTEND NewFunctionalScheme ; try Functional_principles_types.build_scheme fas with Functional_principles_types.No_graph_found -> - CErrors.error ("Cannot generate induction principle(s)") + CErrors.user_err Pp.(str "Cannot generate induction principle(s)") | e when CErrors.noncritical e -> let names = List.map (fun (_,na,_) -> na) fas in warning_error names e diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index 52179ae5..04006453 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -1,7 +1,7 @@ open Printer open Pp open Names -open Term +open Constr open Vars open Glob_term open Glob_ops @@ -12,6 +12,9 @@ open Util open Glob_termops open Misctypes +module RelDecl = Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration + let observe strm = if do_observe () then Feedback.msg_debug strm @@ -29,6 +32,14 @@ type binder_type = type glob_context = (binder_type*glob_constr) list + +let rec solve_trivial_holes pat_as_term e = + match DAst.get pat_as_term, DAst.get e with + | GHole _,_ -> e + | GApp(fp,argsp),GApp(fe,argse) when glob_constr_eq fp fe -> + DAst.make (GApp((solve_trivial_holes fp fe),List.map2 solve_trivial_holes argsp argse)) + | _,_ -> pat_as_term + (* compose_glob_context [(bt_1,n_1,t_1);......] rt returns b_1(n_1,t_1,.....,bn(n_k,t_k,rt)) where the b_i's are the @@ -39,7 +50,7 @@ let compose_glob_context = match bt with | Lambda n -> mkGLambda(n,t,acc) | Prod n -> mkGProd(n,t,acc) - | LetIn n -> mkGLetIn(n,t,acc) + | LetIn n -> mkGLetIn(n,t,None,acc) in List.fold_right compose_binder @@ -109,13 +120,13 @@ let combine_args arg args = let ids_of_binder = function - | LetIn Anonymous | Prod Anonymous | Lambda Anonymous -> [] - | LetIn (Name id) | Prod (Name id) | Lambda (Name id) -> [id] + | LetIn Anonymous | Prod Anonymous | Lambda Anonymous -> Id.Set.empty + | LetIn (Name id) | Prod (Name id) | Lambda (Name id) -> Id.Set.singleton id let rec change_vars_in_binder mapping = function [] -> [] | (bt,t)::l -> - let new_mapping = List.fold_right Id.Map.remove (ids_of_binder bt) mapping in + let new_mapping = Id.Set.fold Id.Map.remove (ids_of_binder bt) mapping in (bt,change_vars mapping t):: (if Id.Map.is_empty new_mapping then l @@ -126,27 +137,27 @@ let rec replace_var_by_term_in_binder x_id term = function | [] -> [] | (bt,t)::l -> (bt,replace_var_by_term x_id term t):: - if Id.List.mem x_id (ids_of_binder bt) + if Id.Set.mem x_id (ids_of_binder bt) then l else replace_var_by_term_in_binder x_id term l -let add_bt_names bt = List.append (ids_of_binder bt) +let add_bt_names bt = Id.Set.union (ids_of_binder bt) let apply_args ctxt body args = let need_convert_id avoid id = - List.exists (is_free_in id) args || Id.List.mem id avoid + List.exists (is_free_in id) args || Id.Set.mem id avoid in let need_convert avoid bt = - List.exists (need_convert_id avoid) (ids_of_binder bt) + Id.Set.exists (need_convert_id avoid) (ids_of_binder bt) in - let next_name_away (na:Name.t) (mapping: Id.t Id.Map.t) (avoid: Id.t list) = + let next_name_away (na:Name.t) (mapping: Id.t Id.Map.t) (avoid: Id.Set.t) = match na with - | Name id when Id.List.mem id avoid -> + | Name id when Id.Set.mem id avoid -> let new_id = Namegen.next_ident_away id avoid in - Name new_id,Id.Map.add id new_id mapping,new_id::avoid + Name new_id,Id.Map.add id new_id mapping,Id.Set.add new_id avoid | _ -> na,mapping,avoid in - let next_bt_away bt (avoid:Id.t list) = + let next_bt_away bt (avoid:Id.Set.t) = match bt with | LetIn na -> let new_na,mapping,new_avoid = next_name_away na Id.Map.empty avoid in @@ -171,15 +182,15 @@ let apply_args ctxt body args = let new_avoid,new_ctxt',new_body,new_id = if need_convert_id avoid id then - let new_avoid = id::avoid in + let new_avoid = Id.Set.add id avoid in let new_id = Namegen.next_ident_away id new_avoid in - let new_avoid' = new_id :: new_avoid in + let new_avoid' = Id.Set.add new_id new_avoid in let mapping = Id.Map.add id new_id Id.Map.empty in let new_ctxt' = change_vars_in_binder mapping ctxt' in let new_body = change_vars mapping body in new_avoid',new_ctxt',new_body,new_id else - id::avoid,ctxt',body,id + Id.Set.add id avoid,ctxt',body,id in let new_body = replace_var_by_term new_id arg new_body in let new_ctxt' = replace_var_by_term_in_binder new_id arg new_ctxt' in @@ -203,7 +214,7 @@ let apply_args ctxt body args = in (new_bt,t)::new_ctxt',new_body in - do_apply [] ctxt body args + do_apply Id.Set.empty ctxt body args let combine_app f args = @@ -223,7 +234,12 @@ let combine_lam n t b = compose_glob_context b.context b.value ) } - +let combine_prod2 n t b = + { + context = []; + value = mkGProd(n, compose_glob_context t.context t.value, + compose_glob_context b.context b.value ) + } let combine_prod n t b = { context = t.context@((Prod n,t.value)::b.context); value = b.value} @@ -245,10 +261,10 @@ let mk_result ctxt value avoid = **************************************************) let coq_True_ref = - lazy (Coqlib.gen_reference "" ["Init";"Logic"] "True") + lazy (Coqlib.coq_reference "" ["Init";"Logic"] "True") let coq_False_ref = - lazy (Coqlib.gen_reference "" ["Init";"Logic"] "False") + lazy (Coqlib.coq_reference "" ["Init";"Logic"] "False") (* [make_discr_match_el \[e1,...en\]] builds match e1,...,en with @@ -271,10 +287,10 @@ let make_discr_match_el = *) let make_discr_match_brl i = List.map_i - (fun j (_,idl,patl,_) -> + (fun j {CAst.v=(idl,patl,_)} -> CAst.make @@ if Int.equal j i - then (Loc.ghost,idl,patl, mkGRef (Lazy.force coq_True_ref)) - else (Loc.ghost,idl,patl, mkGRef (Lazy.force coq_False_ref)) + then (idl,patl, mkGRef (Lazy.force coq_True_ref)) + else (idl,patl, mkGRef (Lazy.force coq_False_ref)) ) 0 (* @@ -333,27 +349,28 @@ let raw_push_named (na,raw_value,raw_typ) env = match na with | Anonymous -> env | Name id -> - let value = Option.map (fun x-> fst (Pretyping.understand env (Evd.from_env env) x)) raw_value in - let typ,ctx = Pretyping.understand env (Evd.from_env env) ~expected_type:Pretyping.IsType raw_typ in - let open Context.Named.Declaration in - Environ.push_named (of_tuple (id,value,typ)) env + let typ,_ = Pretyping.understand env (Evd.from_env env) ~expected_type:Pretyping.IsType raw_typ in + (match raw_value with + | None -> + EConstr.push_named (NamedDecl.LocalAssum (id,typ)) env + | Some value -> + EConstr.push_named (NamedDecl.LocalDef (id, value, typ)) env) let add_pat_variables pat typ env : Environ.env = let rec add_pat_variables env pat typ : Environ.env = - let open Context.Rel.Declaration in observe (str "new rel env := " ++ Printer.pr_rel_context_of env (Evd.from_env env)); - match pat with - | PatVar(_,na) -> Environ.push_rel (LocalAssum (na,typ)) env - | PatCstr(_,c,patl,na) -> + match DAst.get pat with + | PatVar na -> Environ.push_rel (RelDecl.LocalAssum (na,typ)) env + | PatCstr(c,patl,na) -> let Inductiveops.IndType(indf,indargs) = - try Inductiveops.find_rectype env (Evd.from_env env) typ + try Inductiveops.find_rectype env (Evd.from_env env) (EConstr.of_constr typ) 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 (fst cs.Inductiveops.cs_cstr)) (Array.to_list constructors) in - let cs_args_types :types list = List.map get_type constructor.Inductiveops.cs_args in + let cs_args_types :types list = List.map RelDecl.get_type constructor.Inductiveops.cs_args in List.fold_left2 add_pat_variables env patl (List.rev cs_args_types) in let new_env = add_pat_variables env pat typ in @@ -361,21 +378,30 @@ let add_pat_variables pat typ env : Environ.env = fst ( Context.Rel.fold_outside (fun decl (env,ctxt) -> - let _,v,t = Context.Rel.Declaration.to_tuple decl in - match Context.Rel.Declaration.get_name decl with - | Anonymous -> assert false - | Name id -> - let new_t = substl ctxt t in - let new_v = Option.map (substl ctxt) v in - observe (str "for variable " ++ Ppconstr.pr_id id ++ fnl () ++ - str "old type := " ++ Printer.pr_lconstr t ++ fnl () ++ - str "new type := " ++ Printer.pr_lconstr new_t ++ fnl () ++ - Option.fold_right (fun v _ -> str "old value := " ++ Printer.pr_lconstr v ++ fnl ()) v (mt ()) ++ - Option.fold_right (fun v _ -> str "new value := " ++ Printer.pr_lconstr v ++ fnl ()) new_v (mt ()) - ); - let open Context.Named.Declaration in - (Environ.push_named (of_tuple (id,new_v,new_t)) env,mkVar id::ctxt) - ) + let open Context.Rel.Declaration in + let sigma, _ = Pfedit.get_current_context () in + match decl with + | LocalAssum (Anonymous,_) | LocalDef (Anonymous,_,_) -> assert false + | LocalAssum (Name id, t) -> + let new_t = substl ctxt t in + observe (str "for variable " ++ Ppconstr.pr_id id ++ fnl () ++ + str "old type := " ++ Printer.pr_lconstr_env env sigma t ++ fnl () ++ + str "new type := " ++ Printer.pr_lconstr_env env sigma new_t ++ fnl () + ); + let open Context.Named.Declaration in + (Environ.push_named (LocalAssum (id,new_t)) env,mkVar id::ctxt) + | LocalDef (Name id, v, t) -> + let new_t = substl ctxt t in + let new_v = substl ctxt v in + observe (str "for variable " ++ Ppconstr.pr_id id ++ fnl () ++ + str "old type := " ++ Printer.pr_lconstr_env env sigma t ++ fnl () ++ + str "new type := " ++ Printer.pr_lconstr_env env sigma new_t ++ fnl () ++ + str "old value := " ++ Printer.pr_lconstr_env env sigma v ++ fnl () ++ + str "new value := " ++ Printer.pr_lconstr_env env sigma new_v ++ fnl () + ); + let open Context.Named.Declaration in + (Environ.push_named (LocalDef (id,new_v,new_t)) env,mkVar id::ctxt) + ) (Environ.rel_context new_env) ~init:(env,[]) ) @@ -386,31 +412,30 @@ let add_pat_variables pat typ env : Environ.env = -let rec pattern_to_term_and_type env typ = function - | PatVar(loc,Anonymous) -> assert false - | PatVar(loc,Name id) -> +let rec pattern_to_term_and_type env typ = DAst.with_val (function + | PatVar Anonymous -> assert false + | PatVar (Name id) -> mkGVar id - | PatCstr(loc,constr,patternl,_) -> + | PatCstr(constr,patternl,_) -> let cst_narg = Inductiveops.constructor_nallargs_env (Global.env ()) constr in let Inductiveops.IndType(indf,indargs) = - try Inductiveops.find_rectype env (Evd.from_env env) typ + try Inductiveops.find_rectype env (Evd.from_env env) (EConstr.of_constr typ) with Not_found -> assert false in let constructors = Inductiveops.get_constructors env indf in let constructor = List.find (fun cs -> eq_constructor (fst cs.Inductiveops.cs_cstr) constr) (Array.to_list constructors) in - let open Context.Rel.Declaration in - let cs_args_types :types list = List.map get_type constructor.Inductiveops.cs_args in + let cs_args_types :types list = List.map RelDecl.get_type constructor.Inductiveops.cs_args in let _,cstl = Inductiveops.dest_ind_family indf in let csta = Array.of_list cstl in let implicit_args = Array.to_list (Array.init (cst_narg - List.length patternl) - (fun i -> Detyping.detype false [] env (Evd.from_env env) csta.(i)) + (fun i -> Detyping.detype Detyping.Now false Id.Set.empty env (Evd.from_env env) (EConstr.of_constr csta.(i))) ) in let patl_as_term = @@ -419,6 +444,7 @@ let rec pattern_to_term_and_type env typ = function mkGApp(mkGRef(ConstructRef constr), implicit_args@patl_as_term ) + ) (* [build_entry_lc funnames avoid rt] construct the list (in fact a build_entry_return) of constructors corresponding to [rt] when replacing calls to [funnames] by calls to the @@ -452,13 +478,14 @@ let rec pattern_to_term_and_type env typ = function *) -let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = - observe (str " Entering : " ++ Printer.pr_glob_constr rt); - match rt with - | GRef _ | GVar _ | GEvar _ | GPatVar _ | GSort _ | GHole _ -> +let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = + observe (str " Entering : " ++ Printer.pr_glob_constr_env env rt); + let open CAst in + match DAst.get rt with + | GRef _ | GVar _ | GEvar _ | GPatVar _ | GSort _ | GHole _ -> (* do nothing (except changing type of course) *) mk_result [] rt avoid - | GApp(_,_,_) -> + | GApp(_,_) -> let f,args = glob_decompose_app rt in let args_res : (glob_constr list) build_entry_return = List.fold_right (* create the arguments lists of constructors and combine them *) @@ -470,20 +497,20 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = (mk_result [] [] avoid) in begin - match f with + match DAst.get f with | GLambda _ -> let rec aux t l = match l with | [] -> t - | u::l -> - match t with - | GLambda(loc,na,_,nat,b) -> - GLetIn(Loc.ghost,na,u,aux b l) + | u::l -> DAst.make @@ + match DAst.get t with + | GLambda(na,_,nat,b) -> + GLetIn(na,u,None,aux b l) | _ -> - GApp(Loc.ghost,t,l) + GApp(t,l) in build_entry_lc env funnames avoid (aux f args) - | GVar(_,id) when Id.Set.mem id funnames -> + | GVar id when Id.Set.mem id funnames -> (* if we have [f t1 ... tn] with [f]$\in$[fnames] then we create a fresh variable [res], add [res] and its "value" (i.e. [res v1 ... vn]) to each @@ -492,8 +519,8 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = The "value" of this branch is then simply [res] *) let rt_as_constr,ctx = Pretyping.understand env (Evd.from_env env) rt in - let rt_typ = Typing.unsafe_type_of env (Evd.from_env env) rt_as_constr in - let res_raw_type = Detyping.detype false [] env (Evd.from_env env) rt_typ in + let rt_typ = Typing.unsafe_type_of env (Evd.from_env env) rt_as_constr in + let res_raw_type = Detyping.detype Detyping.Now false Id.Set.empty env (Evd.from_env env) rt_typ in let res = fresh_id args_res.to_avoid "_res" in let new_avoid = res::args_res.to_avoid in let res_rt = mkGVar res in @@ -524,7 +551,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = args_res.result } | GApp _ -> assert false (* we have collected all the app in [glob_decompose_app] *) - | GLetIn(_,n,t,b) -> + | GLetIn(n,v,t,b) -> (* if we have [(let x := v in b) t1 ... tn] , we discard our work and compute the list of constructor for [let x = v in (b t1 ... tn)] up to alpha conversion @@ -533,12 +560,12 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = match n with | Name id when List.exists (is_free_in id) args -> (* need to alpha-convert the name *) - let new_id = Namegen.next_ident_away id avoid in + let new_id = Namegen.next_ident_away id (Id.Set.of_list avoid) in let new_avoid = id:: avoid in let new_b = replace_var_by_term id - (GVar(Loc.ghost,id)) + (DAst.make @@ GVar id) b in (Name new_id,new_b,new_avoid) @@ -548,7 +575,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = env funnames avoid - (mkGLetIn(new_n,t,mkGApp(new_b,args))) + (mkGLetIn(new_n,v,t,mkGApp(new_b,args))) | GCases _ | GIf _ | GLetTuple _ -> (* we have [(match e1, ...., en with ..... end) t1 tn] we first compute the result from the case and @@ -556,18 +583,18 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = *) let f_res = build_entry_lc env funnames args_res.to_avoid f in combine_results combine_app f_res args_res - | GCast(_,b,_) -> + | GCast(b,_) -> (* for an applied cast we just trash the cast part and restart the work. WARNING: We need to restart since [b] itself should be an application term *) build_entry_lc env funnames avoid (mkGApp(b,args)) - | GRec _ -> error "Not handled GRec" - | GProd _ -> error "Cannot apply a type" + | GRec _ -> user_err Pp.(str "Not handled GRec") + | GProd _ -> user_err Pp.(str "Cannot apply a type") end (* end of the application treatement *) - | GLambda(_,n,_,t,b) -> + | GLambda(n,_,t,b) -> (* we first compute the list of constructor corresponding to the body of the function, then the one corresponding to the type @@ -582,7 +609,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = let new_env = raw_push_named (new_n,None,t) env in let b_res = build_entry_lc new_env funnames avoid b in combine_results (combine_lam new_n) t_res b_res - | GProd(_,n,_,t,b) -> + | GProd(n,_,t,b) -> (* we first compute the list of constructor corresponding to the body of the function, then the one corresponding to the type @@ -591,45 +618,47 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = let t_res = build_entry_lc env funnames avoid t in let new_env = raw_push_named (n,None,t) env in let b_res = build_entry_lc new_env funnames avoid b in - combine_results (combine_prod n) t_res b_res - | GLetIn(_,n,v,b) -> + if List.length t_res.result = 1 && List.length b_res.result = 1 + then combine_results (combine_prod2 n) t_res b_res + else combine_results (combine_prod n) t_res b_res + | GLetIn(n,v,typ,b) -> (* we first compute the list of constructor corresponding to the body of the function, then the one corresponding to the value [t] and combine the two result *) + let v = match typ with None -> v | Some t -> DAst.make ?loc:rt.loc @@ GCast (v,CastConv t) in let v_res = build_entry_lc env funnames avoid v in let v_as_constr,ctx = Pretyping.understand env (Evd.from_env env) v in - let v_type = Typing.unsafe_type_of env (Evd.from_env env) v_as_constr in + let v_type = Typing.unsafe_type_of env (Evd.from_env env) v_as_constr in let new_env = - let open Context.Named.Declaration in match n with Anonymous -> env - | Name id -> Environ.push_named (of_tuple (id,Some v_as_constr,v_type)) env + | Name id -> EConstr.push_named (NamedDecl.LocalDef (id,v_as_constr,v_type)) env in let b_res = build_entry_lc new_env funnames avoid b in combine_results (combine_letin n) v_res b_res - | GCases(_,_,_,el,brl) -> + | GCases(_,_,el,brl) -> (* we create the discrimination function and treat the case itself *) 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) -> + | GIf(b,(na,e_option),lhs,rhs) -> let b_as_constr,ctx = Pretyping.understand env (Evd.from_env env) b in - let b_typ = Typing.unsafe_type_of env (Evd.from_env env) b_as_constr in + let b_typ = Typing.unsafe_type_of env (Evd.from_env env) b_as_constr in let (ind,_) = try Inductiveops.find_inductive env (Evd.from_env env) b_typ with Not_found -> - errorlabstrm "" (str "Cannot find the inductive associated to " ++ - Printer.pr_glob_constr b ++ str " in " ++ - Printer.pr_glob_constr rt ++ str ". try again with a cast") + user_err (str "Cannot find the inductive associated to " ++ + Printer.pr_glob_constr_env env b ++ str " in " ++ + Printer.pr_glob_constr_env env rt ++ str ". try again with a cast") in let case_pats = build_constructors_of_type (fst ind) [] in assert (Int.equal (Array.length case_pats) 2); let brl = List.map_i - (fun i x -> (Loc.ghost,[],[case_pats.(i)],x)) + (fun i x -> CAst.make ([],[case_pats.(i)],x)) 0 [lhs;rhs] in @@ -638,7 +667,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = in (* Pp.msgnl (str "new case := " ++ Printer.pr_glob_constr match_expr); *) build_entry_lc env funnames avoid match_expr - | GLetTuple(_,nal,_,b,e) -> + | GLetTuple(nal,_,b,e) -> begin let nal_as_glob_constr = List.map @@ -649,25 +678,23 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = nal in let b_as_constr,ctx = Pretyping.understand env (Evd.from_env env) b in - let b_typ = Typing.unsafe_type_of env (Evd.from_env env) b_as_constr in + let b_typ = Typing.unsafe_type_of env (Evd.from_env env) b_as_constr in let (ind,_) = try Inductiveops.find_inductive env (Evd.from_env env) b_typ with Not_found -> - errorlabstrm "" (str "Cannot find the inductive associated to " ++ - Printer.pr_glob_constr b ++ str " in " ++ - Printer.pr_glob_constr rt ++ str ". try again with a cast") + user_err (str "Cannot find the inductive associated to " ++ + Printer.pr_glob_constr_env env b ++ str " in " ++ + Printer.pr_glob_constr_env env rt ++ str ". try again with a cast") 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) - in + let br = CAst.make ([],[case_pats.(0)],e) in let match_expr = mkGCases(None,[b,(Anonymous,None)],[br]) in build_entry_lc env funnames avoid match_expr end - | GRec _ -> error "Not handled GRec" - | GCast(_,b,_) -> + | GRec _ -> user_err Pp.(str "Not handled GRec") + | GCast(b,_) -> build_entry_lc env funnames avoid b and build_entry_lc_from_case env funname make_discr (el:tomatch_tuples) @@ -696,7 +723,7 @@ and build_entry_lc_from_case env funname make_discr let types = List.map (fun (case_arg,_) -> let case_arg_as_constr,ctx = Pretyping.understand env (Evd.from_env env) case_arg in - Typing.unsafe_type_of env (Evd.from_env env) case_arg_as_constr + EConstr.Unsafe.to_constr (Typing.unsafe_type_of env (Evd.from_env env) case_arg_as_constr) ) el in (****** The next works only if the match is not dependent ****) @@ -727,7 +754,7 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve | [] -> (* computed_branches *) {result = [];to_avoid = avoid} | br::brl' -> (* alpha conversion to prevent name clashes *) - let _,idl,patl,return = alpha_br avoid br in + let {CAst.v=(idl,patl,return)} = alpha_br avoid br in let new_avoid = idl@avoid in (* for now we can no more use idl as an identifier *) (* building a list of precondition stating that we are not in this branch (will be used in the following recursive calls) @@ -743,10 +770,10 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve List.fold_right (fun id acc -> let typ_of_id = - Typing.unsafe_type_of env_with_pat_ids (Evd.from_env env) (mkVar id) + Typing.unsafe_type_of env_with_pat_ids (Evd.from_env env) (EConstr.mkVar id) in let raw_typ_of_id = - Detyping.detype false [] + Detyping.detype Detyping.Now false Id.Set.empty env_with_pat_ids (Evd.from_env env) typ_of_id in mkGProd (Name id,raw_typ_of_id,acc)) @@ -791,15 +818,22 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve List.map3 (fun pat e typ_as_constr -> let this_pat_ids = ids_of_pat pat in - let typ = Detyping.detype false [] new_env (Evd.from_env env) typ_as_constr in + let typ_as_constr = EConstr.of_constr typ_as_constr in + let typ = Detyping.detype Detyping.Now false Id.Set.empty new_env (Evd.from_env env) typ_as_constr in let pat_as_term = pattern_to_term pat in + (* removing trivial holes *) + let pat_as_term = solve_trivial_holes pat_as_term e in + (* observe (str "those_pattern_preconds" ++ spc () ++ *) + (* str "pat" ++ spc () ++ pr_glob_constr pat_as_term ++ spc ()++ *) + (* str "e" ++ spc () ++ pr_glob_constr e ++spc ()++ *) + (* str "typ_as_constr" ++ spc () ++ pr_lconstr typ_as_constr); *) List.fold_right (fun id acc -> if Id.Set.mem id this_pat_ids then (Prod (Name id), - let typ_of_id = Typing.unsafe_type_of new_env (Evd.from_env env) (mkVar id) in + let typ_of_id = Typing.unsafe_type_of new_env (Evd.from_env env) (EConstr.mkVar id) in let raw_typ_of_id = - Detyping.detype false [] new_env (Evd.from_env env) typ_of_id + Detyping.detype Detyping.Now false Id.Set.empty new_env (Evd.from_env env) typ_of_id in raw_typ_of_id )::acc @@ -841,37 +875,45 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve { brl'_res with result = this_branch_res@brl'_res.result } -let is_res id = - try +let is_res r = match DAst.get r with +| GVar id -> + begin try String.equal (String.sub (Id.to_string id) 0 4) "_res" - with Invalid_argument _ -> false + with Invalid_argument _ -> false end +| _ -> false +let is_gr c gr = match DAst.get c with +| GRef (r, _) -> Globnames.eq_gr r gr +| _ -> false +let is_gvar c = match DAst.get c with +| GVar id -> true +| _ -> false let same_raw_term rt1 rt2 = - match rt1,rt2 with - | GRef(_,r1,_), GRef (_,r2,_) -> Globnames.eq_gr r1 r2 + match DAst.get rt1, DAst.get rt2 with + | GRef(r1,_), GRef (r2,_) -> Globnames.eq_gr r1 r2 | GHole _, GHole _ -> true | _ -> false let decompose_raw_eq lhs rhs = - let rec decompose_raw_eq lhs rhs acc = - observe (str "decomposing eq for " ++ pr_glob_constr lhs ++ str " " ++ pr_glob_constr rhs); - let (rhd,lrhs) = glob_decompose_app rhs in - let (lhd,llhs) = glob_decompose_app lhs in - observe (str "lhd := " ++ pr_glob_constr lhd); - observe (str "rhd := " ++ pr_glob_constr rhd); + let _, env = Pfedit.get_current_context () in + let rec decompose_raw_eq lhs rhs acc = + observe (str "decomposing eq for " ++ pr_glob_constr_env env lhs ++ str " " ++ pr_glob_constr_env env rhs); + let (rhd,lrhs) = glob_decompose_app rhs in + let (lhd,llhs) = glob_decompose_app lhs in + observe (str "lhd := " ++ pr_glob_constr_env env lhd); + observe (str "rhd := " ++ pr_glob_constr_env env rhd); observe (str "llhs := " ++ int (List.length llhs)); observe (str "lrhs := " ++ int (List.length lrhs)); - let sllhs = List.length llhs in - let slrhs = List.length lrhs in - if same_raw_term lhd rhd && Int.equal sllhs slrhs + let sllhs = List.length llhs in + let slrhs = List.length lrhs in + if same_raw_term lhd rhd && Int.equal sllhs slrhs then (* let _ = assert false in *) List.fold_right2 decompose_raw_eq llhs lrhs acc else (lhs,rhs)::acc in decompose_raw_eq lhs rhs [] - exception Continue (* @@ -880,28 +922,30 @@ exception Continue eliminates some meaningless equalities, applies some rewrites...... *) let rec rebuild_cons env nb_args relname args crossed_types depth rt = - observe (str "rebuilding : " ++ pr_glob_constr rt); + observe (str "rebuilding : " ++ pr_glob_constr_env env rt); let open Context.Rel.Declaration in - match rt with - | GProd(_,n,k,t,b) -> + let open CAst in + match DAst.get rt with + | GProd(n,k,t,b) -> let not_free_in_t id = not (is_free_in id t) in let new_crossed_types = t::crossed_types in begin - match t with - | GApp(_,(GVar(_,res_id) as res_rt),args') when is_res res_id -> + match DAst.get t with + | GApp(res_rt ,args') when is_res res_rt -> begin - match args' with - | (GVar(_,this_relname))::args' -> + let arg = List.hd args' in + match DAst.get arg with + | GVar this_relname -> (*i The next call to mk_rel_id is valid since we are constructing the graph Ensures by: obvious i*) let new_t = - mkGApp(mkGVar(mk_rel_id this_relname),args'@[res_rt]) + mkGApp(mkGVar(mk_rel_id this_relname),List.tl args'@[res_rt]) in let t',ctx = Pretyping.understand env (Evd.from_env env) new_t in - let new_env = Environ.push_rel (LocalAssum (n,t')) env in + let new_env = EConstr.push_rel (LocalAssum (n,t')) env in let new_b,id_to_exclude = rebuild_cons new_env nb_args relname @@ -913,12 +957,16 @@ 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]) - when Globnames.eq_gr eq_as_ref (Lazy.force Coqlib.coq_eq_ref) && n == Anonymous + | GApp(eq_as_ref,[ty; id ;rt]) + when is_gvar id && is_gr eq_as_ref (Lazy.force Coqlib.coq_eq_ref) && n == Anonymous -> + let loc1 = rt.CAst.loc in + let loc2 = eq_as_ref.CAst.loc in + let loc3 = id.CAst.loc in + let id = match DAst.get id with GVar id -> id | _ -> assert false in begin try - observe (str "computing new type for eq : " ++ pr_glob_constr rt); + observe (str "computing new type for eq : " ++ pr_glob_constr_env env rt); let t' = try fst (Pretyping.understand env (Evd.from_env env) t)(*FIXME*) with e when CErrors.noncritical e -> raise Continue @@ -932,7 +980,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = let subst_b = if is_in_b then b else replace_var_by_term id rt b in - let new_env = Environ.push_rel (LocalAssum (n,t')) env in + let new_env = EConstr.push_rel (LocalAssum (n,t')) env in let new_b,id_to_exclude = rebuild_cons new_env @@ -942,51 +990,50 @@ 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 (fst (destInd (jmeq ()))) in + let jmeq = Globnames.IndRef (fst (EConstr.destInd Evd.empty (jmeq ()))) in let ty',ctx = Pretyping.understand env (Evd.from_env env) ty in - let ind,args' = Inductive.find_inductive env ty' in + let ind,args' = Inductiveops.find_inductive env Evd.(from_env env) ty' 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 (fst ind),None), + let rt_typ = DAst.make @@ + GApp(DAst.make @@ GRef (Globnames.IndRef (fst ind),None), (List.map - (fun p -> Detyping.detype false [] + (fun p -> Detyping.detype Detyping.Now false Id.Set.empty env (Evd.from_env env) - p) params)@(Array.to_list + (EConstr.of_constr p)) params)@(Array.to_list (Array.make (List.length args' - nparam) (mkGHole ())))) in let eq' = - GApp(loc1,GRef(loc2,jmeq,None),[ty;GVar(loc3,id);rt_typ;rt]) + DAst.make ?loc:loc1 @@ GApp(DAst.make ?loc:loc2 @@GRef(jmeq,None),[ty;DAst.make ?loc:loc3 @@ GVar id;rt_typ;rt]) in - observe (str "computing new type for jmeq : " ++ pr_glob_constr eq'); + observe (str "computing new type for jmeq : " ++ pr_glob_constr_env env eq'); let eq'_as_constr,ctx = Pretyping.understand env (Evd.from_env env) eq' in observe (str " computing new type for jmeq : done") ; + let sigma = Evd.(from_env env) in let new_args = - match kind_of_term eq'_as_constr with + match EConstr.kind sigma eq'_as_constr with | App(_,[|_;_;ty;_|]) -> - let ty = Array.to_list (snd (destApp ty)) in + let ty = Array.to_list (snd (EConstr.destApp sigma ty)) in let ty' = snd (Util.List.chop nparam ty) in List.fold_left2 (fun acc var_as_constr arg -> if isRel var_as_constr then - let open Context.Rel.Declaration in - let na = get_name (Environ.lookup_rel (destRel var_as_constr) env) in + let na = RelDecl.get_name (Environ.lookup_rel (destRel var_as_constr) env) in match na with | Anonymous -> acc | Name id' -> - (id',Detyping.detype false [] + (id',Detyping.detype Detyping.Now false Id.Set.empty env (Evd.from_env env) arg)::acc else if isVar var_as_constr - then (destVar var_as_constr,Detyping.detype false [] + then (destVar var_as_constr,Detyping.detype Detyping.Now false Id.Set.empty env (Evd.from_env env) arg)::acc @@ -1015,7 +1062,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = in let new_env = let t',ctx = Pretyping.understand env (Evd.from_env env) eq' in - Environ.push_rel (LocalAssum (n,t')) env + EConstr.push_rel (LocalAssum (n,t')) env in let new_b,id_to_exclude = rebuild_cons @@ -1031,8 +1078,8 @@ 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]) - when Globnames.eq_gr eq_as_ref (Lazy.force Coqlib.coq_eq_ref) && n == Anonymous + | GApp(eq_as_ref,[ty;rt1;rt2]) + when is_gr eq_as_ref (Lazy.force Coqlib.coq_eq_ref) && n == Anonymous -> begin try @@ -1043,7 +1090,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = List.fold_left (fun acc (lhs,rhs) -> mkGProd(Anonymous, - mkGApp(mkGRef(eq_as_ref),[mkGHole ();lhs;rhs]),acc) + mkGApp(mkGRef(Lazy.force Coqlib.coq_eq_ref),[mkGHole ();lhs;rhs]),acc) ) b l @@ -1051,9 +1098,9 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = rebuild_cons env nb_args relname args crossed_types depth new_rt else raise Continue with Continue -> - observe (str "computing new type for prod : " ++ pr_glob_constr rt); + observe (str "computing new type for prod : " ++ pr_glob_constr_env env rt); let t',ctx = Pretyping.understand env (Evd.from_env env) t in - let new_env = Environ.push_rel (LocalAssum (n,t')) env in + let new_env = EConstr.push_rel (LocalAssum (n,t')) env in let new_b,id_to_exclude = rebuild_cons new_env nb_args relname @@ -1067,9 +1114,9 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = | _ -> mkGProd(n,t,new_b),Id.Set.filter not_free_in_t id_to_exclude end | _ -> - observe (str "computing new type for prod : " ++ pr_glob_constr rt); + observe (str "computing new type for prod : " ++ pr_glob_constr_env env rt); let t',ctx = Pretyping.understand env (Evd.from_env env) t in - let new_env = Environ.push_rel (LocalAssum (n,t')) env in + let new_env = EConstr.push_rel (LocalAssum (n,t')) env in let new_b,id_to_exclude = rebuild_cons new_env nb_args relname @@ -1082,15 +1129,15 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = (Id.Set.filter not_free_in_t id_to_exclude) | _ -> mkGProd(n,t,new_b),Id.Set.filter not_free_in_t id_to_exclude end - | GLambda(_,n,k,t,b) -> + | GLambda(n,k,t,b) -> begin 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); + observe (str "computing new type for lambda : " ++ pr_glob_constr_env env rt); let t',ctx = Pretyping.understand env (Evd.from_env env) t in match n with | Name id -> - let new_env = Environ.push_rel (LocalAssum (n,t')) env in + let new_env = EConstr.push_rel (LocalAssum (n,t')) env in let new_b,id_to_exclude = rebuild_cons new_env nb_args relname @@ -1101,18 +1148,21 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = then new_b, Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude) else - GProd(Loc.ghost,n,k,t,new_b),Id.Set.filter not_free_in_t id_to_exclude - | _ -> anomaly (Pp.str "Should not have an anonymous function here") + DAst.make @@ GProd(n,k,t,new_b),Id.Set.filter not_free_in_t id_to_exclude + | _ -> anomaly (Pp.str "Should not have an anonymous function here.") (* We have renamed all the anonymous functions during alpha_renaming phase *) end - | GLetIn(_,n,t,b) -> + | GLetIn(n,v,t,b) -> begin + let t = match t with None -> v | Some t -> DAst.make ?loc:rt.loc @@ GCast (v,CastConv t) in let not_free_in_t id = not (is_free_in id t) in let evd = (Evd.from_env env) in let t',ctx = Pretyping.understand env evd t in let evd = Evd.from_ctx ctx in - let type_t' = Typing.unsafe_type_of env evd t' in + let type_t' = Typing.unsafe_type_of env evd t' in + let t' = EConstr.Unsafe.to_constr t' in + let type_t' = EConstr.Unsafe.to_constr type_t' in let new_env = Environ.push_rel (LocalDef (n,t',type_t')) env in let new_b,id_to_exclude = rebuild_cons new_env @@ -1122,10 +1172,10 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = match n with | Name id when Id.Set.mem id id_to_exclude && depth >= nb_args -> new_b,Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude) - | _ -> GLetIn(Loc.ghost,n,t,new_b), + | _ -> DAst.make @@ GLetIn(n,t,None,new_b), (* HOPING IT WOULD WORK *) Id.Set.filter not_free_in_t id_to_exclude end - | GLetTuple(_,nal,(na,rto),t,b) -> + | GLetTuple(nal,(na,rto),t,b) -> assert (Option.is_empty rto); begin let not_free_in_t id = not (is_free_in id t) in @@ -1137,7 +1187,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = depth t in let t',ctx = Pretyping.understand env (Evd.from_env env) new_t in - let new_env = Environ.push_rel (LocalAssum (na,t')) env in + let new_env = EConstr.push_rel (LocalAssum (na,t')) env in let new_b,id_to_exclude = rebuild_cons new_env nb_args relname @@ -1148,7 +1198,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = (* | Name id when Id.Set.mem id id_to_exclude -> *) (* new_b,Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude) *) (* | _ -> *) - GLetTuple(Loc.ghost,nal,(na,None),t,new_b), + DAst.make @@ GLetTuple(nal,(na,None),t,new_b), Id.Set.filter not_free_in_t (Id.Set.union id_to_exclude id_to_exclude') end @@ -1174,31 +1224,39 @@ let rebuild_cons env nb_args relname args crossed_types rt = TODO: Find a valid way to deal with implicit arguments here! *) -let rec compute_cst_params relnames params = function +let rec compute_cst_params relnames params gt = DAst.with_val (function | GRef _ | GVar _ | GEvar _ | GPatVar _ -> params - | GApp(_,GVar(_,relname'),rtl) when Id.Set.mem relname' relnames -> - compute_cst_params_from_app [] (params,rtl) - | GApp(_,f,args) -> + | GApp(f,args) -> + begin match DAst.get f with + | GVar relname' when Id.Set.mem relname' relnames -> + compute_cst_params_from_app [] (params,args) + | _ -> List.fold_left (compute_cst_params relnames) params (f::args) - | GLambda(_,_,_,t,b) | GProd(_,_,_,t,b) | GLetIn(_,_,t,b) | GLetTuple(_,_,_,t,b) -> + end + | GLambda(_,_,t,b) | GProd(_,_,t,b) | GLetTuple(_,_,t,b) -> let t_params = compute_cst_params relnames params t in compute_cst_params relnames t_params b + | GLetIn(_,v,t,b) -> + let v_params = compute_cst_params relnames params v in + let t_params = Option.fold_left (compute_cst_params relnames) v_params t in + compute_cst_params relnames t_params b | GCases _ -> params (* If there is still cases at this point they can only be discrimination ones *) | GSort _ -> params | GHole _ -> params | GIf _ | GRec _ | GCast _ -> - raise (UserError("compute_cst_params", str "Not handled case")) + raise (UserError(Some "compute_cst_params", str "Not handled case")) + ) gt and compute_cst_params_from_app acc (params,rtl) = + let is_gid id c = match DAst.get c with GVar id' -> Id.equal id id' | _ -> false in match params,rtl with | _::_,[] -> assert false (* the rel has at least nargs + 1 arguments ! *) - | ((Name id,_,is_defined) as param)::params',(GVar(_,id'))::rtl' - when Id.compare id id' == 0 && not is_defined -> + | ((Name id,_,None) as param)::params', c::rtl' when is_gid id c -> compute_cst_params_from_app (param::acc) (params',rtl') | _ -> List.rev acc -let compute_params_name relnames (args : (Name.t * Glob_term.glob_constr * bool) list array) csts = +let compute_params_name relnames (args : (Name.t * Glob_term.glob_constr * glob_constr option) list array) csts = let rels_params = Array.mapi (fun i args -> @@ -1213,11 +1271,11 @@ let compute_params_name relnames (args : (Name.t * Glob_term.glob_constr * bool) let _ = try List.iteri - (fun i ((n,nt,is_defined) as param) -> + (fun i ((n,nt,typ) as param) -> if Array.for_all (fun l -> - let (n',nt',is_defined') = List.nth l i in - Name.equal n n' && glob_constr_eq nt nt' && (is_defined : bool) == is_defined') + let (n',nt',typ') = List.nth l i in + Name.equal n n' && glob_constr_eq nt nt' && Option.equal glob_constr_eq typ typ') rels_params then l := param::!l @@ -1229,18 +1287,18 @@ let compute_params_name relnames (args : (Name.t * Glob_term.glob_constr * bool) List.rev !l let rec rebuild_return_type rt = - match rt with - | Constrexpr.CProdN(loc,n,t') -> - Constrexpr.CProdN(loc,n,rebuild_return_type t') - | Constrexpr.CLetIn(loc,na,t,t') -> - Constrexpr.CLetIn(loc,na,t,rebuild_return_type t') - | _ -> Constrexpr.CProdN(Loc.ghost,[[Loc.ghost,Anonymous], - Constrexpr.Default Decl_kinds.Explicit,rt], - Constrexpr.CSort(Loc.ghost,GType [])) - + let loc = rt.CAst.loc in + match rt.CAst.v with + | Constrexpr.CProdN(n,t') -> + CAst.make ?loc @@ Constrexpr.CProdN(n,rebuild_return_type t') + | Constrexpr.CLetIn(na,v,t,t') -> + CAst.make ?loc @@ Constrexpr.CLetIn(na,v,t,rebuild_return_type t') + | _ -> CAst.make ?loc @@ Constrexpr.CProdN([Constrexpr.CLocalAssum ([CAst.make Anonymous], + Constrexpr.Default Decl_kinds.Explicit, rt)], + CAst.make @@ Constrexpr.CSort(GType [])) let do_build_inductive - evd (funconstants: Term.pconstant list) (funsargs: (Name.t * glob_constr * bool) list list) + evd (funconstants: pconstant list) (funsargs: (Name.t * glob_constr * glob_constr option) list list) returned_types (rtl:glob_constr list) = let _time1 = System.get_time () in @@ -1262,36 +1320,41 @@ let do_build_inductive let open Context.Named.Declaration in let evd,env = Array.fold_right2 - (fun id c (evd,env) -> - let evd,t = Typing.type_of env evd (mkConstU c) in + (fun id (c, u) (evd,env) -> + let u = EConstr.EInstance.make u in + let evd,t = Typing.type_of env evd (EConstr.mkConstU (c, u)) in + let t = EConstr.Unsafe.to_constr t in evd, Environ.push_named (LocalAssum (id,t)) - (* try *) - (* Typing.e_type_of env evd (mkConstU c) *) - (* with Not_found -> *) - (* raise (UserError("do_build_inductive", str "Cannot handle partial fixpoint")) *) env ) funnames (Array.of_list funconstants) (evd,Global.env ()) in - let resa = Array.map (build_entry_lc env funnames_as_set []) rta in + (* we solve and replace the implicits *) + let rta = + Array.mapi (fun i rt -> + let _,t = Typing.type_of env evd (EConstr.of_constr (mkConstU ((Array.of_list funconstants).(i)))) in + resolve_and_replace_implicits ~expected_type:(Pretyping.OfType t) env evd rt + ) rta + in + let resa = Array.map (build_entry_lc env funnames_as_set []) rta in let env_with_graphs = let rel_arity i funargs = (* Rebuilding arities (with parameters) *) - let rel_first_args :(Name.t * Glob_term.glob_constr * bool ) list = + let rel_first_args :(Name.t * Glob_term.glob_constr * Glob_term.glob_constr option ) list = funargs in List.fold_right - (fun (n,t,is_defined) acc -> - if is_defined - then - Constrexpr.CLetIn(Loc.ghost,(Loc.ghost, n),with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t, + (fun (n,t,typ) acc -> + match typ with + | Some typ -> + CAst.make @@ Constrexpr.CLetIn((CAst.make n),with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t, + Some (with_full_print (Constrextern.extern_glob_constr Id.Set.empty) typ), acc) - else - Constrexpr.CProdN - (Loc.ghost, - [[(Loc.ghost,n)],Constrexpr_ops.default_binder_kind,with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t], + | None -> + CAst.make @@ Constrexpr.CProdN + ([Constrexpr.CLocalAssum([CAst.make n],Constrexpr_ops.default_binder_kind,with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t)], acc ) ) @@ -1304,8 +1367,9 @@ 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 (LocalAssum (rel_name, - fst (with_full_print (Constrintern.interp_constr env evd) rel_ar))) env) env relnames rel_arities + let rex = fst (with_full_print (Constrintern.interp_constr env evd) rel_ar) in + let rex = EConstr.Unsafe.to_constr rex in + Environ.push_named (LocalAssum (rel_name,rex)) env) env relnames rel_arities in (* and of the real constructors*) let constr i res = @@ -1346,19 +1410,19 @@ let do_build_inductive rel_constructors in let rel_arity i funargs = (* Reduilding arities (with parameters) *) - let rel_first_args :(Name.t * Glob_term.glob_constr * bool ) list = + let rel_first_args :(Name.t * Glob_term.glob_constr * Glob_term.glob_constr option ) list = (snd (List.chop nrel_params funargs)) in List.fold_right - (fun (n,t,is_defined) acc -> - if is_defined - then - Constrexpr.CLetIn(Loc.ghost,(Loc.ghost, n),with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t, + (fun (n,t,typ) acc -> + match typ with + | Some typ -> + CAst.make @@ Constrexpr.CLetIn((CAst.make n),with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t, + Some (with_full_print (Constrextern.extern_glob_constr Id.Set.empty) typ), acc) - else - Constrexpr.CProdN - (Loc.ghost, - [[(Loc.ghost,n)],Constrexpr_ops.default_binder_kind,with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t], + | None -> + CAst.make @@ Constrexpr.CProdN + ([Constrexpr.CLocalAssum([CAst.make n],Constrexpr_ops.default_binder_kind,with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t)], acc ) ) @@ -1382,20 +1446,21 @@ let do_build_inductive in let rel_params = List.map - (fun (n,t,is_defined) -> - if is_defined - then - Constrexpr.LocalRawDef((Loc.ghost,n), Constrextern.extern_glob_constr Id.Set.empty t) - else - Constrexpr.LocalRawAssum - ([(Loc.ghost,n)], Constrexpr_ops.default_binder_kind, Constrextern.extern_glob_constr Id.Set.empty t) + (fun (n,t,typ) -> + match typ with + | Some typ -> + Constrexpr.CLocalDef((CAst.make n), Constrextern.extern_glob_constr Id.Set.empty t, + Some (with_full_print (Constrextern.extern_glob_constr Id.Set.empty) typ)) + | None -> + Constrexpr.CLocalAssum + ([(CAst.make n)], Constrexpr_ops.default_binder_kind, Constrextern.extern_glob_constr Id.Set.empty t) ) rels_params in let ext_rels_constructors = Array.map (List.map (fun (id,t) -> - false,((Loc.ghost,id), + false,((CAst.make id), with_full_print (Constrextern.extern_glob_type Id.Set.empty) ((* zeta_normalize *) (alpha_rt rel_params_ids t)) ) @@ -1403,7 +1468,7 @@ let do_build_inductive (rel_constructors) in let rel_ind i ext_rel_constructors = - (((Loc.ghost,relnames.(i)), None), + (((CAst.make @@ relnames.(i)), None), rel_params, Some rel_arities.(i), ext_rel_constructors),[] @@ -1432,7 +1497,9 @@ let do_build_inductive (* in *) let _time2 = System.get_time () in try - with_full_print (Flags.silently (Command.do_mutual_inductive rel_inds (Flags.is_universe_polymorphism ()) false)) Decl_kinds.Finite + with_full_print + (Flags.silently (ComInductive.do_mutual_inductive rel_inds (Flags.is_universe_polymorphism ()) false false)) + Declarations.Finite with | UserError(s,msg) as e -> let _time3 = System.get_time () in @@ -1443,7 +1510,7 @@ let do_build_inductive in let msg = str "while trying to define"++ spc () ++ - Ppvernac.pr_vernac (Vernacexpr.VernacInductive(false,Decl_kinds.Finite,repacked_rel_inds)) + Ppvernac.pr_vernac Vernacexpr.(VernacExpr([], VernacInductive(GlobalNonCumulativity,false,Declarations.Finite,repacked_rel_inds))) ++ fnl () ++ msg in @@ -1458,7 +1525,7 @@ let do_build_inductive in let msg = str "while trying to define"++ spc () ++ - Ppvernac.pr_vernac (Vernacexpr.VernacInductive(false,Decl_kinds.Finite,repacked_rel_inds)) + Ppvernac.pr_vernac Vernacexpr.(VernacExpr([], VernacInductive(GlobalNonCumulativity,false,Declarations.Finite,repacked_rel_inds))) ++ fnl () ++ CErrors.print reraise in diff --git a/plugins/funind/glob_term_to_relation.mli b/plugins/funind/glob_term_to_relation.mli index 5bb1376e..ff0e98d0 100644 --- a/plugins/funind/glob_term_to_relation.mli +++ b/plugins/funind/glob_term_to_relation.mli @@ -11,8 +11,8 @@ val build_inductive : Id.t list -> (* The list of function name *) *) Evd.evar_map -> - Term.pconstant list -> - (Name.t*Glob_term.glob_constr*bool) list list -> (* The list of function args *) + Constr.pconstant list -> + (Name.t*Glob_term.glob_constr*Glob_term.glob_constr option) list list -> (* The list of function args *) Constrexpr.constr_expr list -> (* The list of function returned type *) Glob_term.glob_constr list -> (* the list of body *) unit diff --git a/plugins/funind/glob_termops.ml b/plugins/funind/glob_termops.ml index 01e5ef7f..769fcc1c 100644 --- a/plugins/funind/glob_termops.ml +++ b/plugins/funind/glob_termops.ml @@ -10,83 +10,26 @@ 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,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) -let mkGProd(n,t,b) = GProd(Loc.ghost,n,Explicit,t,b) -let mkGLetIn(n,t,b) = GLetIn(Loc.ghost,n,t,b) -let mkGCases(rto,l,brl) = GCases(Loc.ghost,Term.RegularStyle,rto,l,brl) -let mkGSort s = GSort(Loc.ghost,s) -let mkGHole () = GHole(Loc.ghost,Evar_kinds.BinderType Anonymous,Misctypes.IntroAnonymous,None) -let mkGCast(b,t) = GCast(Loc.ghost,b,CastConv t) +let mkGRef ref = DAst.make @@ GRef(ref,None) +let mkGVar id = DAst.make @@ GVar(id) +let mkGApp(rt,rtl) = DAst.make @@ GApp(rt,rtl) +let mkGLambda(n,t,b) = DAst.make @@ GLambda(n,Explicit,t,b) +let mkGProd(n,t,b) = DAst.make @@ GProd(n,Explicit,t,b) +let mkGLetIn(n,b,t,c) = DAst.make @@ GLetIn(n,b,t,c) +let mkGCases(rto,l,brl) = DAst.make @@ GCases(Term.RegularStyle,rto,l,brl) +let mkGHole () = DAst.make @@ GHole(Evar_kinds.BinderType Anonymous,Misctypes.IntroAnonymous,None) (* Some basic functions to decompose glob_constrs These are analogous to the ones constrs *) -let glob_decompose_prod = - let rec glob_decompose_prod args = function - | GProd(_,n,k,t,b) -> - glob_decompose_prod ((n,t)::args) b - | rt -> args,rt - in - glob_decompose_prod [] - -let glob_decompose_prod_or_letin = - let rec glob_decompose_prod args = function - | GProd(_,n,k,t,b) -> - glob_decompose_prod ((n,None,Some t)::args) b - | GLetIn(_,n,t,b) -> - glob_decompose_prod ((n,Some t,None)::args) b - | rt -> args,rt - in - glob_decompose_prod [] - -let glob_compose_prod = - List.fold_left (fun b (n,t) -> mkGProd(n,t,b)) - -let glob_compose_prod_or_letin = - List.fold_left ( - fun concl decl -> - match decl with - | (n,None,Some t) -> mkGProd(n,t,concl) - | (n,Some bdy,None) -> mkGLetIn(n,bdy,concl) - | _ -> assert false) - -let glob_decompose_prod_n n = - let rec glob_decompose_prod i args c = - if i<=0 then args,c - else - match c with - | GProd(_,n,_,t,b) -> - glob_decompose_prod (i-1) ((n,t)::args) b - | rt -> args,rt - in - glob_decompose_prod n [] - - -let glob_decompose_prod_or_letin_n n = - let rec glob_decompose_prod i args c = - if i<=0 then args,c - else - match c with - | GProd(_,n,_,t,b) -> - glob_decompose_prod (i-1) ((n,None,Some t)::args) b - | GLetIn(_,n,t,b) -> - glob_decompose_prod (i-1) ((n,Some t,None)::args) b - | rt -> args,rt - in - glob_decompose_prod n [] - - let glob_decompose_app = let rec decompose_rapp acc rt = (* msgnl (str "glob_decompose_app on : "++ Printer.pr_glob_constr rt); *) - match rt with - | GApp(_,rt,rtl) -> + match DAst.get rt with + | GApp(rt,rtl) -> decompose_rapp (List.fold_left (fun y x -> x::y) acc rtl) rt - | rt -> rt,List.rev acc + | _ -> rt,List.rev acc in decompose_rapp [] @@ -101,18 +44,6 @@ let glob_make_eq ?(typ= mkGHole ()) t1 t2 = let glob_make_neq t1 t2 = mkGApp(mkGRef (Lazy.force Coqlib.coq_not_ref),[glob_make_eq t1 t2]) -(* [glob_make_or P1 P2] build the glob_constr corresponding to [P1 \/ P2] *) -let glob_make_or t1 t2 = mkGApp (mkGRef(Lazy.force Coqlib.coq_or_ref),[t1;t2]) - -(* [glob_make_or_list [P1;...;Pn]] build the glob_constr corresponding - to [P1 \/ ( .... \/ Pn)] -*) -let rec glob_make_or_list = function - | [] -> invalid_arg "mk_or" - | [e] -> e - | e::l -> glob_make_or e (glob_make_or_list l) - - let remove_name_from_mapping mapping na = match na with | Anonymous -> mapping @@ -120,96 +51,93 @@ let remove_name_from_mapping mapping na = let change_vars = let rec change_vars mapping rt = - match rt with - | GRef _ -> rt - | GVar(loc,id) -> + DAst.map_with_loc (fun ?loc -> function + | GRef _ as x -> x + | GVar id -> let new_id = try Id.Map.find id mapping with Not_found -> id in - GVar(loc,new_id) - | GEvar _ -> rt - | GPatVar _ -> rt - | GApp(loc,rt',rtl) -> - GApp(loc, - change_vars mapping rt', + GVar(new_id) + | GEvar _ as x -> x + | GPatVar _ as x -> x + | GApp(rt',rtl) -> + GApp(change_vars mapping rt', List.map (change_vars mapping) rtl ) - | GLambda(loc,name,k,t,b) -> - GLambda(loc, - name, + | GLambda(name,k,t,b) -> + GLambda(name, k, change_vars mapping t, change_vars (remove_name_from_mapping mapping name) b ) - | GProd(loc,name,k,t,b) -> - GProd(loc, - name, + | GProd(name,k,t,b) -> + GProd( name, k, change_vars mapping t, change_vars (remove_name_from_mapping mapping name) b ) - | GLetIn(loc,name,def,b) -> - GLetIn(loc, - name, + | GLetIn(name,def,typ,b) -> + GLetIn(name, change_vars mapping def, + Option.map (change_vars mapping) typ, change_vars (remove_name_from_mapping mapping name) b ) - | GLetTuple(loc,nal,(na,rto),b,e) -> + | GLetTuple(nal,(na,rto),b,e) -> let new_mapping = List.fold_left remove_name_from_mapping mapping nal in - GLetTuple(loc, - nal, + GLetTuple(nal, (na, Option.map (change_vars mapping) rto), change_vars mapping b, change_vars new_mapping e ) - | GCases(loc,sty,infos,el,brl) -> - GCases(loc,sty, + | GCases(sty,infos,el,brl) -> + GCases(sty, infos, List.map (fun (e,x) -> (change_vars mapping e,x)) el, List.map (change_vars_br mapping) brl ) - | GIf(loc,b,(na,e_option),lhs,rhs) -> - GIf(loc, - change_vars mapping b, + | GIf(b,(na,e_option),lhs,rhs) -> + GIf(change_vars mapping b, (na,Option.map (change_vars mapping) e_option), change_vars mapping lhs, change_vars mapping rhs ) - | GRec _ -> error "Local (co)fixes are not supported" - | GSort _ -> rt - | GHole _ -> rt - | GCast(loc,b,c) -> - GCast(loc,change_vars mapping b, + | GRec _ -> user_err ?loc Pp.(str "Local (co)fixes are not supported") + | GSort _ as x -> x + | GHole _ as x -> x + | GCast(b,c) -> + GCast(change_vars mapping b, Miscops.map_cast_type (change_vars mapping) c) - and change_vars_br mapping ((loc,idl,patl,res) as br) = + ) rt + and change_vars_br mapping ({CAst.loc;v=(idl,patl,res)} as br) = let new_mapping = List.fold_right Id.Map.remove idl mapping in if Id.Map.is_empty new_mapping then br - else (loc,idl,patl,change_vars new_mapping res) + else CAst.make ?loc (idl,patl,change_vars new_mapping res) in change_vars let rec alpha_pat excluded pat = - match pat with - | PatVar(loc,Anonymous) -> + let loc = pat.CAst.loc in + match DAst.get pat with + | PatVar Anonymous -> let new_id = Indfun_common.fresh_id excluded "_x" in - PatVar(loc,Name new_id),(new_id::excluded),Id.Map.empty - | PatVar(loc,Name id) -> + (DAst.make ?loc @@ PatVar(Name new_id)),(new_id::excluded),Id.Map.empty + | PatVar(Name id) -> if Id.List.mem id excluded then - let new_id = Namegen.next_ident_away id excluded in - PatVar(loc,Name new_id),(new_id::excluded), + let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in + (DAst.make ?loc @@ PatVar(Name new_id)),(new_id::excluded), (Id.Map.add id new_id Id.Map.empty) - else pat,excluded,Id.Map.empty - | PatCstr(loc,constr,patl,na) -> + else pat, excluded,Id.Map.empty + | PatCstr(constr,patl,na) -> let new_na,new_excluded,map = match na with | Name id when Id.List.mem id excluded -> - let new_id = Namegen.next_ident_away id excluded in + let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in Name new_id,new_id::excluded, Id.Map.add id new_id Id.Map.empty | _ -> na,excluded,Id.Map.empty in @@ -222,7 +150,7 @@ let rec alpha_pat excluded pat = ([],new_excluded,map) patl in - PatCstr(loc,constr,List.rev new_patl,new_na),new_excluded,new_map + (DAst.make ?loc @@ PatCstr(constr,List.rev new_patl,new_na)),new_excluded,new_map let alpha_patl excluded patl = let patl,new_excluded,map = @@ -241,11 +169,11 @@ let alpha_patl excluded patl = let raw_get_pattern_id pat acc = let rec get_pattern_id pat = - match pat with - | PatVar(loc,Anonymous) -> assert false - | PatVar(loc,Name id) -> + match DAst.get pat with + | PatVar(Anonymous) -> assert false + | PatVar(Name id) -> [id] - | PatCstr(loc,constr,patternl,_) -> + | PatCstr(constr,patternl,_) -> List.fold_right (fun pat idl -> let idl' = get_pattern_id pat in @@ -259,28 +187,30 @@ let raw_get_pattern_id pat acc = let get_pattern_id pat = raw_get_pattern_id pat [] let rec alpha_rt excluded rt = - let new_rt = - match rt with - | GRef _ | GVar _ | GEvar _ | GPatVar _ -> rt - | GLambda(loc,Anonymous,k,t,b) -> - let new_id = Namegen.next_ident_away (Id.of_string "_x") excluded in + let loc = rt.CAst.loc in + let new_rt = DAst.make ?loc @@ + match DAst.get rt with + | GRef _ | GVar _ | GEvar _ | GPatVar _ as rt -> rt + | GLambda(Anonymous,k,t,b) -> + let new_id = Namegen.next_ident_away (Id.of_string "_x") (Id.Set.of_list excluded) in let new_excluded = new_id :: excluded in let new_t = alpha_rt new_excluded t in let new_b = alpha_rt new_excluded b in - GLambda(loc,Name new_id,k,new_t,new_b) - | GProd(loc,Anonymous,k,t,b) -> + GLambda(Name new_id,k,new_t,new_b) + | GProd(Anonymous,k,t,b) -> let new_t = alpha_rt excluded t in let new_b = alpha_rt excluded b in - GProd(loc,Anonymous,k,new_t,new_b) - | GLetIn(loc,Anonymous,t,b) -> - let new_t = alpha_rt excluded t in + GProd(Anonymous,k,new_t,new_b) + | GLetIn(Anonymous,b,t,c) -> let new_b = alpha_rt excluded b in - GLetIn(loc,Anonymous,new_t,new_b) - | GLambda(loc,Name id,k,t,b) -> - let new_id = Namegen.next_ident_away id excluded in + let new_t = Option.map (alpha_rt excluded) t in + let new_c = alpha_rt excluded c in + GLetIn(Anonymous,new_b,new_t,new_c) + | GLambda(Name id,k,t,b) -> + let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in let t,b = if Id.equal new_id id - then t,b + then t, b else let replace = change_vars (Id.Map.add id new_id Id.Map.empty) in (t,replace b) @@ -288,9 +218,9 @@ let rec alpha_rt excluded rt = let new_excluded = new_id::excluded in let new_t = alpha_rt new_excluded t in let new_b = alpha_rt new_excluded b in - GLambda(loc,Name new_id,k,new_t,new_b) - | GProd(loc,Name id,k,t,b) -> - let new_id = Namegen.next_ident_away id excluded in + GLambda(Name new_id,k,new_t,new_b) + | GProd(Name id,k,t,b) -> + let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in let new_excluded = new_id::excluded in let t,b = if Id.equal new_id id @@ -301,30 +231,27 @@ let rec alpha_rt excluded rt = in let new_t = alpha_rt new_excluded t in let new_b = alpha_rt new_excluded b in - GProd(loc,Name new_id,k,new_t,new_b) - | GLetIn(loc,Name id,t,b) -> - let new_id = Namegen.next_ident_away id excluded in - let t,b = - if Id.equal new_id id - then t,b - else - let replace = change_vars (Id.Map.add id new_id Id.Map.empty) in - (t,replace b) + GProd(Name new_id,k,new_t,new_b) + | GLetIn(Name id,b,t,c) -> + let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in + let c = + if Id.equal new_id id then c + else change_vars (Id.Map.add id new_id Id.Map.empty) c in let new_excluded = new_id::excluded in - let new_t = alpha_rt new_excluded t in let new_b = alpha_rt new_excluded b in - GLetIn(loc,Name new_id,new_t,new_b) - + let new_t = Option.map (alpha_rt new_excluded) t in + let new_c = alpha_rt new_excluded c in + GLetIn(Name new_id,new_b,new_t,new_c) - | GLetTuple(loc,nal,(na,rto),t,b) -> + | GLetTuple(nal,(na,rto),t,b) -> let rev_new_nal,new_excluded,mapping = List.fold_left (fun (nal,excluded,mapping) na -> match na with | Anonymous -> (na::nal,excluded,mapping) | Name id -> - let new_id = Namegen.next_ident_away id excluded in + let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in if Id.equal new_id id then na::nal,id::excluded,mapping @@ -344,85 +271,92 @@ let rec alpha_rt excluded rt = let new_t = alpha_rt new_excluded new_t in let new_b = alpha_rt new_excluded new_b in let new_rto = Option.map (alpha_rt new_excluded) new_rto in - GLetTuple(loc,new_nal,(na,new_rto),new_t,new_b) - | GCases(loc,sty,infos,el,brl) -> + GLetTuple(new_nal,(na,new_rto),new_t,new_b) + | GCases(sty,infos,el,brl) -> let new_el = List.map (function (rt,i) -> alpha_rt excluded rt, i) el in - GCases(loc,sty,infos,new_el,List.map (alpha_br excluded) brl) - | GIf(loc,b,(na,e_o),lhs,rhs) -> - GIf(loc,alpha_rt excluded b, + GCases(sty,infos,new_el,List.map (alpha_br excluded) brl) + | GIf(b,(na,e_o),lhs,rhs) -> + GIf(alpha_rt excluded b, (na,Option.map (alpha_rt excluded) e_o), alpha_rt excluded lhs, alpha_rt excluded rhs ) - | GRec _ -> error "Not handled GRec" - | GSort _ -> rt - | GHole _ -> rt - | GCast (loc,b,c) -> - GCast(loc,alpha_rt excluded b, + | GRec _ -> user_err Pp.(str "Not handled GRec") + | GSort _ + | GHole _ as rt -> rt + | GCast (b,c) -> + GCast(alpha_rt excluded b, Miscops.map_cast_type (alpha_rt excluded) c) - | GApp(loc,f,args) -> - GApp(loc, - alpha_rt excluded f, + | GApp(f,args) -> + GApp(alpha_rt excluded f, List.map (alpha_rt excluded) args ) in new_rt -and alpha_br excluded (loc,ids,patl,res) = +and alpha_br excluded {CAst.loc;v=(ids,patl,res)} = let new_patl,new_excluded,mapping = alpha_patl excluded patl in let new_ids = List.fold_right raw_get_pattern_id new_patl [] in let new_excluded = new_ids@excluded in let renamed_res = change_vars mapping res in let new_res = alpha_rt new_excluded renamed_res in - (loc,new_ids,new_patl,new_res) + CAst.make ?loc (new_ids,new_patl,new_res) (* [is_free_in id rt] checks if [id] is a free variable in [rt] *) let is_free_in id = - let rec is_free_in = function + let rec is_free_in x = DAst.with_loc_val (fun ?loc -> function | GRef _ -> false - | GVar(_,id') -> Id.compare id' id == 0 + | GVar id' -> Id.compare id' id == 0 | GEvar _ -> false | GPatVar _ -> false - | GApp(_,rt,rtl) -> List.exists is_free_in (rt::rtl) - | GLambda(_,n,_,t,b) | GProd(_,n,_,t,b) | GLetIn(_,n,t,b) -> + | GApp(rt,rtl) -> List.exists is_free_in (rt::rtl) + | GLambda(n,_,t,b) | GProd(n,_,t,b) -> let check_in_b = match n with | Name id' -> not (Id.equal id' id) | _ -> true in is_free_in t || (check_in_b && is_free_in b) - | GCases(_,_,_,el,brl) -> + | GLetIn(n,b,t,c) -> + let check_in_c = + match n with + | Name id' -> not (Id.equal id' id) + | _ -> true + in + is_free_in b || Option.cata is_free_in true t || (check_in_c && is_free_in c) + | GCases(_,_,el,brl) -> (List.exists (fun (e,_) -> is_free_in e) el) || List.exists is_free_in_br brl - | GLetTuple(_,nal,_,b,t) -> + | GLetTuple(nal,_,b,t) -> let check_in_nal = not (List.exists (function Name id' -> Id.equal id' id | _ -> false) nal) in is_free_in t || (check_in_nal && is_free_in b) - | GIf(_,cond,_,br1,br2) -> + | GIf(cond,_,br1,br2) -> is_free_in cond || is_free_in br1 || is_free_in br2 - | GRec _ -> raise (UserError("",str "Not handled GRec")) + | GRec _ -> user_err Pp.(str "Not handled GRec") | GSort _ -> false | GHole _ -> false - | GCast (_,b,(CastConv t|CastVM t|CastNative t)) -> is_free_in b || is_free_in t - | GCast (_,b,CastCoerce) -> is_free_in b - and is_free_in_br (_,ids,_,rt) = + | GCast (b,(CastConv t|CastVM t|CastNative t)) -> is_free_in b || is_free_in t + | GCast (b,CastCoerce) -> is_free_in b + ) x + and is_free_in_br {CAst.v=(ids,_,rt)} = (not (Id.List.mem id ids)) && is_free_in rt in is_free_in -let rec pattern_to_term = function - | PatVar(loc,Anonymous) -> assert false - | PatVar(loc,Name id) -> +let rec pattern_to_term pt = DAst.with_val (function + | PatVar Anonymous -> assert false + | PatVar(Name id) -> mkGVar id - | PatCstr(loc,constr,patternl,_) -> + | PatCstr(constr,patternl,_) -> let cst_narg = Inductiveops.constructor_nallargs_env (Global.env ()) @@ -441,77 +375,73 @@ let rec pattern_to_term = function mkGApp(mkGRef(Globnames.ConstructRef constr), implicit_args@patl_as_term ) - + ) pt let replace_var_by_term x_id term = - let rec replace_var_by_pattern rt = - match rt with - | GRef _ -> rt - | GVar(_,id) when Id.compare id x_id == 0 -> term - | GVar _ -> rt - | GEvar _ -> rt - | GPatVar _ -> rt - | GApp(loc,rt',rtl) -> - GApp(loc, - replace_var_by_pattern rt', + let rec replace_var_by_pattern x = DAst.map (function + | GVar id when Id.compare id x_id == 0 -> DAst.get term + | GRef _ + | GVar _ + | GEvar _ + | GPatVar _ as rt -> rt + | GApp(rt',rtl) -> + GApp(replace_var_by_pattern rt', List.map replace_var_by_pattern rtl ) - | GLambda(_,Name id,_,_,_) when Id.compare id x_id == 0 -> rt - | GLambda(loc,name,k,t,b) -> - GLambda(loc, - name, + | GLambda(Name id,_,_,_) as rt when Id.compare id x_id == 0 -> rt + | GLambda(name,k,t,b) -> + GLambda(name, k, replace_var_by_pattern t, replace_var_by_pattern b ) - | GProd(_,Name id,_,_,_) when Id.compare id x_id == 0 -> rt - | GProd(loc,name,k,t,b) -> - GProd(loc, - name, + | GProd(Name id,_,_,_) as rt when Id.compare id x_id == 0 -> rt + | GProd(name,k,t,b) -> + GProd( name, k, replace_var_by_pattern t, replace_var_by_pattern b ) - | GLetIn(_,Name id,_,_) when Id.compare id x_id == 0 -> rt - | GLetIn(loc,name,def,b) -> - GLetIn(loc, - name, + | GLetIn(Name id,_,_,_) as rt when Id.compare id x_id == 0 -> rt + | GLetIn(name,def,typ,b) -> + GLetIn(name, replace_var_by_pattern def, + Option.map (replace_var_by_pattern) typ, replace_var_by_pattern b ) - | GLetTuple(_,nal,_,_,_) + | GLetTuple(nal,_,_,_) as rt when List.exists (function Name id -> Id.equal id x_id | _ -> false) nal -> rt - | GLetTuple(loc,nal,(na,rto),def,b) -> - GLetTuple(loc, - nal, + | GLetTuple(nal,(na,rto),def,b) -> + GLetTuple(nal, (na,Option.map replace_var_by_pattern rto), replace_var_by_pattern def, replace_var_by_pattern b ) - | GCases(loc,sty,infos,el,brl) -> - GCases(loc,sty, + | GCases(sty,infos,el,brl) -> + GCases(sty, infos, List.map (fun (e,x) -> (replace_var_by_pattern e,x)) el, List.map replace_var_by_pattern_br brl ) - | GIf(loc,b,(na,e_option),lhs,rhs) -> - GIf(loc, replace_var_by_pattern b, + | GIf(b,(na,e_option),lhs,rhs) -> + GIf(replace_var_by_pattern b, (na,Option.map replace_var_by_pattern e_option), replace_var_by_pattern lhs, replace_var_by_pattern rhs ) - | GRec _ -> raise (UserError("",str "Not handled GRec")) - | GSort _ -> rt - | GHole _ -> rt - | GCast(loc,b,c) -> - GCast(loc,replace_var_by_pattern b, + | GRec _ -> raise (UserError(None,str "Not handled GRec")) + | GSort _ + | GHole _ as rt -> rt + | GCast(b,c) -> + GCast(replace_var_by_pattern b, Miscops.map_cast_type replace_var_by_pattern c) - and replace_var_by_pattern_br ((loc,idl,patl,res) as br) = + ) x + and replace_var_by_pattern_br ({CAst.loc;v=(idl,patl,res)} as br) = if List.exists (fun id -> Id.compare id x_id == 0) idl then br - else (loc,idl,patl,replace_var_by_pattern res) + else CAst.make ?loc (idl,patl,replace_var_by_pattern res) in replace_var_by_pattern @@ -523,16 +453,16 @@ exception NotUnifiable let rec are_unifiable_aux = function | [] -> () - | eq::eqs -> - match eq with - | PatVar _,_ | _,PatVar _ -> are_unifiable_aux eqs - | PatCstr(_,constructor1,cpl1,_),PatCstr(_,constructor2,cpl2,_) -> + | (l, r) ::eqs -> + match DAst.get l, DAst.get r with + | PatVar _ ,_ | _, PatVar _-> are_unifiable_aux eqs + | PatCstr(constructor1,cpl1,_), PatCstr(constructor2,cpl2,_) -> if not (eq_constructor constructor2 constructor1) then raise NotUnifiable else let eqs' = try (List.combine cpl1 cpl2) @ eqs - with Invalid_argument _ -> anomaly (Pp.str "are_unifiable_aux") + with Invalid_argument _ -> anomaly (Pp.str "are_unifiable_aux.") in are_unifiable_aux eqs' @@ -545,16 +475,16 @@ let are_unifiable pat1 pat2 = let rec eq_cases_pattern_aux = function | [] -> () - | eq::eqs -> - match eq with - | PatVar _,PatVar _ -> eq_cases_pattern_aux eqs - | PatCstr(_,constructor1,cpl1,_),PatCstr(_,constructor2,cpl2,_) -> + | (l, r) ::eqs -> + match DAst.get l, DAst.get r with + | PatVar _, PatVar _ -> eq_cases_pattern_aux eqs + | PatCstr(constructor1,cpl1,_), PatCstr(constructor2,cpl2,_) -> if not (eq_constructor constructor2 constructor1) then raise NotUnifiable else let eqs' = try (List.combine cpl1 cpl2) @ eqs - with Invalid_argument _ -> anomaly (Pp.str "eq_cases_pattern_aux") + with Invalid_argument _ -> anomaly (Pp.str "eq_cases_pattern_aux.") in eq_cases_pattern_aux eqs' | _ -> raise NotUnifiable @@ -568,143 +498,116 @@ let eq_cases_pattern pat1 pat2 = let ids_of_pat = - let rec ids_of_pat ids = function - | PatVar(_,Anonymous) -> ids - | PatVar(_,Name id) -> Id.Set.add id ids - | PatCstr(_,_,patl,_) -> List.fold_left ids_of_pat ids patl + let rec ids_of_pat ids = DAst.with_val (function + | PatVar Anonymous -> ids + | PatVar(Name id) -> Id.Set.add id ids + | PatCstr(_,patl,_) -> List.fold_left ids_of_pat ids patl + ) in ids_of_pat Id.Set.empty -let id_of_name = function - | Names.Anonymous -> Id.of_string "x" - | Names.Name x -> x - -(* TODO: finish Rec caes *) -let ids_of_glob_constr c = - let rec ids_of_glob_constr acc c = - let idof = id_of_name in - match c with - | GVar (_,id) -> id::acc - | GApp (loc,g,args) -> - ids_of_glob_constr [] g @ List.flatten (List.map (ids_of_glob_constr []) args) @ acc - | GLambda (loc,na,k,ty,c) -> idof na :: ids_of_glob_constr [] ty @ ids_of_glob_constr [] c @ acc - | GProd (loc,na,k,ty,c) -> idof na :: ids_of_glob_constr [] ty @ ids_of_glob_constr [] c @ acc - | GLetIn (loc,na,b,c) -> idof na :: ids_of_glob_constr [] b @ ids_of_glob_constr [] c @ acc - | GCast (loc,c,(CastConv t|CastVM t|CastNative t)) -> ids_of_glob_constr [] c @ ids_of_glob_constr [] t @ acc - | GCast (loc,c,CastCoerce) -> ids_of_glob_constr [] c @ acc - | GIf (loc,c,(na,po),b1,b2) -> ids_of_glob_constr [] c @ ids_of_glob_constr [] b1 @ ids_of_glob_constr [] b2 @ acc - | GLetTuple (_,nal,(na,po),b,c) -> - List.map idof nal @ ids_of_glob_constr [] b @ ids_of_glob_constr [] c @ acc - | 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" - | (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _) -> [] - in - (* build the set *) - List.fold_left (fun acc x -> Id.Set.add x acc) Id.Set.empty (ids_of_glob_constr [] c) - - - - - -let zeta_normalize = - let rec zeta_normalize_term rt = - match rt with - | GRef _ -> rt - | GVar _ -> rt - | GEvar _ -> rt - | GPatVar _ -> rt - | GApp(loc,rt',rtl) -> - GApp(loc, - zeta_normalize_term rt', - List.map zeta_normalize_term rtl - ) - | GLambda(loc,name,k,t,b) -> - GLambda(loc, - name, - k, - zeta_normalize_term t, - zeta_normalize_term b - ) - | GProd(loc,name,k,t,b) -> - GProd(loc, - name, - k, - zeta_normalize_term t, - zeta_normalize_term b - ) - | GLetIn(_,Name id,def,b) -> - zeta_normalize_term (replace_var_by_term id def b) - | GLetIn(loc,Anonymous,def,b) -> zeta_normalize_term b - | GLetTuple(loc,nal,(na,rto),def,b) -> - GLetTuple(loc, - nal, - (na,Option.map zeta_normalize_term rto), - zeta_normalize_term def, - zeta_normalize_term b - ) - | GCases(loc,sty,infos,el,brl) -> - GCases(loc,sty, - infos, - List.map (fun (e,x) -> (zeta_normalize_term e,x)) el, - List.map zeta_normalize_br brl - ) - | GIf(loc,b,(na,e_option),lhs,rhs) -> - GIf(loc, zeta_normalize_term b, - (na,Option.map zeta_normalize_term e_option), - zeta_normalize_term lhs, - zeta_normalize_term rhs - ) - | GRec _ -> raise (UserError("",str "Not handled GRec")) - | GSort _ -> rt - | GHole _ -> rt - | GCast(loc,b,c) -> - GCast(loc,zeta_normalize_term b, - Miscops.map_cast_type zeta_normalize_term c) - and zeta_normalize_br (loc,idl,patl,res) = - (loc,idl,patl,zeta_normalize_term res) - in - zeta_normalize_term - - - - let expand_as = - let rec add_as map pat = - match pat with + let rec add_as map rt = + match DAst.get rt with | PatVar _ -> map - | PatCstr(_,_,patl,Name id) -> - Id.Map.add id (pattern_to_term pat) (List.fold_left add_as map patl) - | PatCstr(_,_,patl,_) -> List.fold_left add_as map patl + | PatCstr(_,patl,Name id) -> + Id.Map.add id (pattern_to_term rt) (List.fold_left add_as map patl) + | PatCstr(_,patl,_) -> List.fold_left add_as map patl in - let rec expand_as map rt = - match rt with - | GRef _ | GEvar _ | GPatVar _ | GSort _ | GHole _ -> rt - | GVar(_,id) -> + let rec expand_as map = DAst.map (function + | GRef _ | GEvar _ | GPatVar _ | GSort _ | GHole _ as rt -> rt + | GVar id as rt -> begin try - Id.Map.find id map + DAst.get (Id.Map.find id map) with Not_found -> rt end - | GApp(loc,f,args) -> GApp(loc,expand_as map f,List.map (expand_as map) args) - | GLambda(loc,na,k,t,b) -> GLambda(loc,na,k,expand_as map t, expand_as map b) - | GProd(loc,na,k,t,b) -> GProd(loc,na,k,expand_as map t, expand_as map b) - | GLetIn(loc,na,v,b) -> GLetIn(loc,na, expand_as map v,expand_as map b) - | GLetTuple(loc,nal,(na,po),v,b) -> - GLetTuple(loc,nal,(na,Option.map (expand_as map) po), + | GApp(f,args) -> GApp(expand_as map f,List.map (expand_as map) args) + | GLambda(na,k,t,b) -> GLambda(na,k,expand_as map t, expand_as map b) + | GProd(na,k,t,b) -> GProd(na,k,expand_as map t, expand_as map b) + | GLetIn(na,v,typ,b) -> GLetIn(na, expand_as map v,Option.map (expand_as map) typ,expand_as map b) + | GLetTuple(nal,(na,po),v,b) -> + GLetTuple(nal,(na,Option.map (expand_as map) po), expand_as map v, expand_as map b) - | GIf(loc,e,(na,po),br1,br2) -> - GIf(loc,expand_as map e,(na,Option.map (expand_as map) po), + | GIf(e,(na,po),br1,br2) -> + GIf(expand_as map e,(na,Option.map (expand_as map) po), expand_as map br1, expand_as map br2) - | GRec _ -> error "Not handled GRec" - | GCast(loc,b,c) -> - GCast(loc,expand_as map b, + | GRec _ -> user_err Pp.(str "Not handled GRec") + | GCast(b,c) -> + GCast(expand_as map b, Miscops.map_cast_type (expand_as map) c) - | GCases(loc,sty,po,el,brl) -> - GCases(loc, sty, Option.map (expand_as map) po, List.map (fun (rt,t) -> expand_as map rt,t) el, + | GCases(sty,po,el,brl) -> + GCases(sty, Option.map (expand_as map) po, List.map (fun (rt,t) -> expand_as map rt,t) el, List.map (expand_as_br map) brl) - and expand_as_br map (loc,idl,cpl,rt) = - (loc,idl,cpl, expand_as (List.fold_left add_as map cpl) rt) + ) + and expand_as_br map {CAst.loc; v=(idl,cpl,rt)} = + CAst.make ?loc (idl,cpl, expand_as (List.fold_left add_as map cpl) rt) in expand_as Id.Map.empty + +(* [resolve_and_replace_implicits ?expected_type env sigma rt] solves implicits of [rt] w.r.t. [env] and [sigma] and then replace them by their solution + *) + +exception Found of Evd.evar_info +let resolve_and_replace_implicits ?(flags=Pretyping.all_and_fail_flags) ?(expected_type=Pretyping.WithoutTypeConstraint) env sigma rt = + let open Evd in + let open Evar_kinds in + (* we first (pseudo) understand [rt] and get back the computed evar_map *) + (* FIXME : JF (30/03/2017) I'm not completely sure to have split understand as needed. +If someone knows how to prevent solved existantial removal in understand, please do not hesitate to change the computation of [ctx] here *) + let ctx,_,_ = Pretyping.ise_pretype_gen flags env sigma Glob_ops.empty_lvar expected_type rt in + let ctx, f = Evarutil.nf_evars_and_universes ctx in + + (* then we map [rt] to replace the implicit holes by their values *) + let rec change rt = + match DAst.get rt with + | GHole(ImplicitArg(grk,pk,bk),_,_) -> (* we only want to deal with implicit arguments *) + ( + try (* we scan the new evar map to find the evar corresponding to this hole (by looking the source *) + Evd.fold (* to simulate an iter *) + (fun _ evi _ -> + match evi.evar_source with + | (loc_evi,ImplicitArg(gr_evi,p_evi,b_evi)) -> + if Globnames.eq_gr grk gr_evi && pk=p_evi && bk=b_evi && rt.CAst.loc = loc_evi + then raise (Found evi) + | _ -> () + ) + ctx + (); + (* the hole was not solved : we do nothing *) + rt + with Found evi -> (* we found the evar corresponding to this hole *) + match evi.evar_body with + | Evar_defined c -> + (* we just have to lift the solution in glob_term *) + Detyping.detype Detyping.Now false Id.Set.empty env ctx (EConstr.of_constr (f c)) + | Evar_empty -> rt (* the hole was not solved : we do nothing *) + ) + | (GHole(BinderType na,_,_)) -> (* we only want to deal with implicit arguments *) + ( + let res = + try (* we scan the new evar map to find the evar corresponding to this hole (by looking the source *) + Evd.fold (* to simulate an iter *) + (fun _ evi _ -> + match evi.evar_source with + | (loc_evi,BinderType na') -> + if Name.equal na na' && rt.CAst.loc = loc_evi then raise (Found evi) + | _ -> () + ) + ctx + (); + (* the hole was not solved : we do nothing *) + rt + with Found evi -> (* we found the evar corresponding to this hole *) + match evi.evar_body with + | Evar_defined c -> + (* we just have to lift the solution in glob_term *) + Detyping.detype Detyping.Now false Id.Set.empty env ctx (EConstr.of_constr (f c)) + | Evar_empty -> rt (* the hole was not solved : we d when falseo nothing *) + in + res + ) + | _ -> Glob_ops.map_glob_constr change rt + in + change rt diff --git a/plugins/funind/glob_termops.mli b/plugins/funind/glob_termops.mli index 179e8fe8..7088ae59 100644 --- a/plugins/funind/glob_termops.mli +++ b/plugins/funind/glob_termops.mli @@ -1,6 +1,5 @@ open Names open Glob_term -open Misctypes (* [get_pattern_id pat] returns a list of all the variable appearing in [pat] *) val get_pattern_id : cases_pattern -> Id.t list @@ -19,24 +18,13 @@ val mkGVar : Id.t -> glob_constr val mkGApp : glob_constr*(glob_constr list) -> glob_constr val mkGLambda : Name.t * glob_constr * glob_constr -> glob_constr val mkGProd : Name.t * glob_constr * glob_constr -> glob_constr -val mkGLetIn : Name.t * glob_constr * glob_constr -> glob_constr +val mkGLetIn : Name.t * glob_constr * glob_constr option * glob_constr -> glob_constr val mkGCases : glob_constr option * tomatch_tuples * cases_clauses -> glob_constr -val mkGSort : glob_sort -> glob_constr val mkGHole : unit -> glob_constr (* we only build Evd.BinderType Anonymous holes *) -val mkGCast : glob_constr* glob_constr -> glob_constr (* Some basic functions to decompose glob_constrs These are analogous to the ones constrs *) -val glob_decompose_prod : glob_constr -> (Name.t*glob_constr) list * glob_constr -val glob_decompose_prod_or_letin : - glob_constr -> (Name.t*glob_constr option*glob_constr option) list * glob_constr -val glob_decompose_prod_n : int -> glob_constr -> (Name.t*glob_constr) list * glob_constr -val glob_decompose_prod_or_letin_n : int -> glob_constr -> - (Name.t*glob_constr option*glob_constr option) list * glob_constr -val glob_compose_prod : glob_constr -> (Name.t*glob_constr) list -> glob_constr -val glob_compose_prod_or_letin: glob_constr -> - (Name.t*glob_constr option*glob_constr option) list -> glob_constr val glob_decompose_app : glob_constr -> glob_constr*(glob_constr list) @@ -44,14 +32,6 @@ val glob_decompose_app : glob_constr -> glob_constr*(glob_constr list) val glob_make_eq : ?typ:glob_constr -> glob_constr -> glob_constr -> glob_constr (* [glob_make_neq t1 t2] build the glob_constr corresponding to [t1 <> t2] *) val glob_make_neq : glob_constr -> glob_constr -> glob_constr -(* [glob_make_or P1 P2] build the glob_constr corresponding to [P1 \/ P2] *) -val glob_make_or : glob_constr -> glob_constr -> glob_constr - -(* [glob_make_or_list [P1;...;Pn]] build the glob_constr corresponding - to [P1 \/ ( .... \/ Pn)] -*) -val glob_make_or_list : glob_constr list -> glob_constr - (* alpha_conversion functions *) @@ -82,11 +62,8 @@ val alpha_rt : Id.t list -> glob_constr -> glob_constr (* same as alpha_rt but for case branches *) val alpha_br : Id.t list -> - Loc.t * Id.t list * Glob_term.cases_pattern list * - Glob_term.glob_constr -> - Loc.t * Id.t list * Glob_term.cases_pattern list * - Glob_term.glob_constr - + Glob_term.cases_clause -> + Glob_term.cases_clause (* Reduction function *) val replace_var_by_term : @@ -112,13 +89,10 @@ val eq_cases_pattern : cases_pattern -> cases_pattern -> bool *) val ids_of_pat : cases_pattern -> Id.Set.t -(* TODO: finish this function (Fix not treated) *) -val ids_of_glob_constr: glob_constr -> Id.Set.t - -(* - removing let_in construction in a glob_constr -*) -val zeta_normalize : Glob_term.glob_constr -> Glob_term.glob_constr - - val expand_as : glob_constr -> glob_constr + +(* [resolve_and_replace_implicits ?expected_type env sigma rt] solves implicits of [rt] w.r.t. [env] and [sigma] and then replace them by their solution + *) +val resolve_and_replace_implicits : + ?flags:Pretyping.inference_flags -> + ?expected_type:Pretyping.typing_constraint -> Environ.env -> Evd.evar_map -> glob_constr -> glob_constr diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index 18817f50..57863ee6 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -1,8 +1,9 @@ -open Context.Rel.Declaration open CErrors +open Sorts open Util open Names -open Term +open Constr +open EConstr open Pp open Indfun_common open Libnames @@ -11,39 +12,42 @@ open Glob_term open Declarations open Misctypes open Decl_kinds -open Sigma.Notations -let is_rec_info scheme_info = +module RelDecl = Context.Rel.Declaration + +let is_rec_info sigma scheme_info = let test_branche min acc decl = acc || ( let new_branche = - it_mkProd_or_LetIn mkProp (fst (decompose_prod_assum (get_type decl))) in - let free_rels_in_br = Termops.free_rels new_branche in + it_mkProd_or_LetIn mkProp (fst (decompose_prod_assum sigma (RelDecl.get_type decl))) in + let free_rels_in_br = Termops.free_rels sigma new_branche in let max = min + scheme_info.Tactics.npredicates in Int.Set.exists (fun i -> i >= min && i< max) free_rels_in_br ) in List.fold_left_i test_branche 1 false (List.rev scheme_info.Tactics.branches) -let choose_dest_or_ind scheme_info = - Tactics.induction_destruct (is_rec_info scheme_info) false +let choose_dest_or_ind scheme_info args = + Proofview.tclBIND Proofview.tclEVARMAP (fun sigma -> + Tactics.induction_destruct (is_rec_info sigma scheme_info) false args) let functional_induction with_clean c princl pat = let res = - let f,args = decompose_app c in fun g -> + let sigma = Tacmach.project g in + let f,args = decompose_app sigma c in let princ,bindings, princ_type,g' = match princl with | None -> (* No principle is given let's find the good one *) begin - match kind_of_term f with + match EConstr.kind sigma f with | Const (c',u) -> let princ_option = let finfo = (* we first try to find out a graph on f *) try find_Function_infos c' with Not_found -> - errorlabstrm "" (str "Cannot find induction information on "++ - Printer.pr_lconstr (mkConst c') ) + user_err (str "Cannot find induction information on "++ + Printer.pr_leconstr_env (Tacmach.pf_env g) sigma (mkConst c') ) in match Tacticals.elimination_sort_of_goal g with | InProp -> finfo.prop_lemma @@ -61,7 +65,7 @@ let functional_induction with_clean c princl pat = (or f_rec, f_rect) i*) let princ_name = Indrec.make_elimination_ident - (Label.to_id (con_label c')) + (Label.to_id (Constant.label c')) (Tacticals.elimination_sort_of_goal g) in try @@ -70,30 +74,41 @@ let functional_induction with_clean c princl pat = (b,a) (* mkConst(const_of_id princ_name ),g (\* FIXME *\) *) with Not_found -> (* This one is neither defined ! *) - errorlabstrm "" (str "Cannot find induction principle for " - ++Printer.pr_lconstr (mkConst c') ) + user_err (str "Cannot find induction principle for " + ++ Printer.pr_leconstr_env (Tacmach.pf_env g) sigma (mkConst c') ) in - (princ,NoBindings, Tacmach.pf_unsafe_type_of g' princ,g') - | _ -> raise (UserError("",str "functional induction must be used with a function" )) + let princ = EConstr.of_constr princ in + (princ,NoBindings,Tacmach.pf_unsafe_type_of g' princ,g') + | _ -> raise (UserError(None,str "functional induction must be used with a function" )) end | Some ((princ,binding)) -> princ,binding,Tacmach.pf_unsafe_type_of g princ,g in - let princ_infos = Tactics.compute_elim_sig princ_type in + let sigma = Tacmach.project g' in + let princ_infos = Tactics.compute_elim_sig (Tacmach.project g') princ_type in let args_as_induction_constr = let c_list = if princ_infos.Tactics.farg_in_concl then [c] else [] in + if List.length args + List.length c_list = 0 + then user_err Pp.(str "Cannot recognize a valid functional scheme" ); let encoded_pat_as_patlist = - List.make (List.length args + List.length c_list - 1) None @ [pat] in - List.map2 (fun c pat -> ((None,Tacexpr.ElimOnConstr ({ Tacexpr.delayed = fun env sigma -> Sigma ((c,NoBindings), sigma, Sigma.refl) })),(None,pat),None)) - (args@c_list) encoded_pat_as_patlist + List.make (List.length args + List.length c_list - 1) None @ [pat] + in + List.map2 + (fun c pat -> + ((None, + Ltac_plugin.Tacexpr.ElimOnConstr (fun env sigma -> (sigma,(c,NoBindings)))), + (None,pat), + None)) + (args@c_list) + encoded_pat_as_patlist in let princ' = Some (princ,bindings) in let princ_vars = List.fold_right - (fun a acc -> try Id.Set.add (destVar a) acc with DestKO -> acc) + (fun a acc -> try Id.Set.add (destVar sigma a) acc with DestKO -> acc) args Id.Set.empty in @@ -128,15 +143,14 @@ let functional_induction with_clean c princl pat = let rec abstract_glob_constr c = function | [] -> c - | Constrexpr.LocalRawDef (x,b)::bl -> Constrexpr_ops.mkLetInC(x,b,abstract_glob_constr c bl) - | Constrexpr.LocalRawAssum (idl,k,t)::bl -> + | Constrexpr.CLocalDef (x,b,t)::bl -> Constrexpr_ops.mkLetInC(x,b,t,abstract_glob_constr c bl) + | Constrexpr.CLocalAssum (idl,k,t)::bl -> List.fold_right (fun x b -> Constrexpr_ops.mkLambdaC([x],k,t,b)) idl (abstract_glob_constr c bl) - | Constrexpr.LocalPattern _::bl -> assert false + | Constrexpr.CLocalPattern _::bl -> assert false let interp_casted_constr_with_implicits env sigma impls c = - Constrintern.intern_gen Pretyping.WithoutTypeConstraint env ~impls - ~allow_patvar:false c + Constrintern.intern_gen Pretyping.WithoutTypeConstraint env sigma ~impls c (* Construct a fixpoint as a Glob_term @@ -149,14 +163,14 @@ let build_newrecursive let sigma = Evd.from_env env0 in let (rec_sign,rec_impls) = List.fold_left - (fun (env,impls) (((_,recname),_),bl,arityc,_) -> - let arityc = Constrexpr_ops.prod_constr_expr arityc bl in + (fun (env,impls) (({CAst.v=recname},_),bl,arityc,_) -> + let arityc = Constrexpr_ops.mkCProdN bl arityc in let arity,ctx = Constrintern.interp_type env0 sigma arityc in - let evdref = ref (Evd.from_env env0) in - let _, (_, impls') = Constrintern.interp_context_evars env evdref bl in - let impl = Constrintern.compute_internalization_data env0 Constrintern.Recursive arity impls' in + let evd = Evd.from_env env0 in + let evd, (_, (_, impls')) = Constrintern.interp_context_evars env evd bl in + let impl = Constrintern.compute_internalization_data env0 evd Constrintern.Recursive arity impls' in let open Context.Named.Declaration in - (Environ.push_named (LocalAssum (recname,arity)) env, Id.Map.add recname impl impls)) + (EConstr.push_named (LocalAssum (recname,arity)) env, Id.Map.add recname impl impls)) (env0,Constrintern.empty_internalization_env) lnameargsardef in let recdef = (* Declare local notations *) @@ -175,37 +189,41 @@ let build_newrecursive l = match body_opt with | Some body -> (fixna,bll,ar,body) - | None -> user_err_loc (Loc.ghost,"Function",str "Body of Function must be given") + | None -> user_err ~hdr:"Function" (str "Body of Function must be given") ) l in build_newrecursive l' +let error msg = user_err Pp.(str msg) + (* Checks whether or not the mutual bloc is recursive *) let is_rec names = let names = List.fold_right Id.Set.add names Id.Set.empty in let check_id id names = Id.Set.mem id names in - let rec lookup names = function - | GVar(_,id) -> check_id id names + let rec lookup names gt = match DAst.get gt with + | GVar(id) -> check_id id names | GRef _ | GEvar _ | GPatVar _ | GSort _ | GHole _ -> false - | GCast(_,b,_) -> lookup names b + | GCast(b,_) -> lookup names b | GRec _ -> error "GRec not handled" - | GIf(_,b,_,lhs,rhs) -> + | GIf(b,_,lhs,rhs) -> (lookup names b) || (lookup names lhs) || (lookup names rhs) - | GLetIn(_,na,t,b) | GLambda(_,na,_,t,b) | GProd(_,na,_,t,b) -> - lookup names t || lookup (Nameops.name_fold Id.Set.remove na names) b - | GLetTuple(_,nal,_,t,b) -> lookup names t || + | GProd(na,_,t,b) | GLambda(na,_,t,b) -> + lookup names t || lookup (Nameops.Name.fold_right Id.Set.remove na names) b + | GLetIn(na,b,t,c) -> + lookup names b || Option.cata (lookup names) true t || lookup (Nameops.Name.fold_right Id.Set.remove na names) c + | GLetTuple(nal,_,t,b) -> lookup names t || lookup (List.fold_left - (fun acc na -> Nameops.name_fold Id.Set.remove na acc) + (fun acc na -> Nameops.Name.fold_right Id.Set.remove na acc) names nal ) b - | GApp(_,f,args) -> List.exists (lookup names) (f::args) - | GCases(_,_,_,el,brl) -> + | GApp(f,args) -> List.exists (lookup names) (f::args) + | GCases(_,_,el,brl) -> List.exists (fun (e,_) -> lookup names e) el || List.exists (lookup_br names) brl - and lookup_br names (_,idl,_,rt) = + and lookup_br names {CAst.v=(idl,_,rt)} = let new_names = List.fold_right Id.Set.remove idl names in lookup new_names rt in @@ -214,9 +232,9 @@ let is_rec names = let rec local_binders_length = function (* Assume that no `{ ... } contexts occur *) | [] -> 0 - | Constrexpr.LocalRawDef _::bl -> 1 + local_binders_length bl - | Constrexpr.LocalRawAssum (idl,_,_)::bl -> List.length idl + local_binders_length bl - | Constrexpr.LocalPattern _::bl -> assert false + | Constrexpr.CLocalDef _::bl -> 1 + local_binders_length bl + | Constrexpr.CLocalAssum (idl,_,_)::bl -> List.length idl + local_binders_length bl + | Constrexpr.CLocalPattern _::bl -> assert false let prepare_body ((name,_,args,types,_),_) rt = let n = local_binders_length args in @@ -242,7 +260,9 @@ let derive_inversion fix_names = let evd,c = Evd.fresh_global (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident id)) in - evd, destConst c::l + let c = EConstr.of_constr c in + let (cst, u) = destConst evd c in + evd, (cst, EInstance.kind evd u) :: l ) fix_names (evd',[]) @@ -262,14 +282,14 @@ let derive_inversion fix_names = (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident (mk_rel_id id))) in - evd,(fst (destInd id))::l + let id = EConstr.of_constr id in + evd,(fst (destInd evd id))::l ) fix_names (evd',[]) in Invfun.derive_correctness Functional_principles_types.make_scheme - functional_induction fix_names_as_constant lind; with e when CErrors.noncritical e -> @@ -321,7 +341,7 @@ let error_error names e = in match e with | Building_graph e -> - errorlabstrm "" + user_err (str "Cannot define graph(s) for " ++ h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++ e_explain e) @@ -329,9 +349,9 @@ let error_error names e = let generate_principle (evd:Evd.evar_map ref) pconstants on_error is_general do_built (fix_rec_l:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) recdefs interactive_proof - (continue_proof : int -> Names.constant array -> Term.constr array -> int -> + (continue_proof : int -> Names.Constant.t array -> EConstr.constr array -> int -> Tacmach.tactic) : unit = - let names = List.map (function (((_, name),_),_,_,_,_),_ -> name) fix_rec_l in + let names = List.map (function (({CAst.v=name},_),_,_,_,_),_ -> name) fix_rec_l in let fun_bodies = List.map2 prepare_body fix_rec_l recdefs in let funs_args = List.map fst fun_bodies in let funs_types = List.map (function ((_,_,_,types,_),_) -> types) fix_rec_l in @@ -344,7 +364,7 @@ let generate_principle (evd:Evd.evar_map ref) pconstants on_error (*i The next call to mk_rel_id is valid since we have just construct the graph Ensures by : do_built i*) - let f_R_mut = Ident (Loc.ghost,mk_rel_id (List.nth names 0)) in + let f_R_mut = CAst.make @@ Ident (mk_rel_id (List.nth names 0)) in let ind_kn = fst (locate_with_msg (pr_reference f_R_mut++str ": Not an inductive type!") @@ -352,7 +372,7 @@ let generate_principle (evd:Evd.evar_map ref) pconstants on_error f_R_mut) in let fname_kn (((fname,_),_,_,_,_),_) = - let f_ref = Ident fname in + let f_ref = CAst.map (fun n -> Ident n) fname in locate_with_msg (pr_reference f_ref++str ": Not an inductive type!") locate_constant @@ -367,7 +387,8 @@ let generate_principle (evd:Evd.evar_map ref) pconstants on_error let evd = ref (Evd.from_env env) in let evd',uprinc = Evd.fresh_global env !evd princ in let _ = evd := evd' in - let princ_type = Typing.e_type_of ~refresh:true env evd uprinc in + let princ_type = Typing.e_type_of ~refresh:true env evd (EConstr.of_constr uprinc) in + let princ_type = EConstr.Unsafe.to_constr princ_type in Functional_principles_types.generate_functional_principle evd interactive_proof @@ -390,33 +411,40 @@ let generate_principle (evd:Evd.evar_map ref) pconstants on_error let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) = match fixpoint_exprl with - | [(((_,fname),pl),_,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 + | [(({CAst.v=fname},pl),_,bl,ret_type,body),_] when not is_rec -> + let body = match body with | Some body -> body | None -> user_err ~hdr:"Function" (str "Body of Function must be given") in + ComDefinition.do_definition + ~program_mode:false fname (Decl_kinds.Global,(Flags.is_universe_polymorphism ()),Decl_kinds.Definition) pl bl None body (Some ret_type) (Lemmas.mk_hook (fun _ _ -> ())); let evd,rev_pconstants = List.fold_left - (fun (evd,l) ((((_,fname),_),_,_,_,_),_) -> + (fun (evd,l) ((({CAst.v=fname},_),_,_,_,_),_) -> let evd,c = Evd.fresh_global (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident fname)) in - evd,((destConst c)::l) + let c = EConstr.of_constr c in + let (cst, u) = destConst evd c in + let u = EInstance.kind evd u in + evd,((cst, u) :: l) ) (Evd.from_env (Global.env ()),[]) fixpoint_exprl in evd,List.rev rev_pconstants | _ -> - Command.do_fixpoint Global (Flags.is_universe_polymorphism ()) fixpoint_exprl; + ComFixpoint.do_fixpoint Global (Flags.is_universe_polymorphism ()) fixpoint_exprl; let evd,rev_pconstants = List.fold_left - (fun (evd,l) ((((_,fname),_),_,_,_,_),_) -> + (fun (evd,l) ((({CAst.v=fname},_),_,_,_,_),_) -> let evd,c = Evd.fresh_global (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident fname)) in - evd,((destConst c)::l) + let c = EConstr.of_constr c in + let (cst, u) = destConst evd c in + let u = EInstance.kind evd u in + evd,((cst, u) :: l) ) (Evd.from_env (Global.env ()),[]) fixpoint_exprl @@ -426,7 +454,7 @@ let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexp 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 - (_: int) (_:Names.constant array) (_:Term.constr array) (_:int) : Tacmach.tactic = + (_: int) (_:Names.Constant.t array) (_:EConstr.constr array) (_:int) : Tacmach.tactic = Functional_principles_proofs.prove_principle_for_gen (f_ref,functional_ref,eq_ref) tcc_lemma_ref is_mes rec_arg_num rec_arg_type relation @@ -435,11 +463,11 @@ let generate_correction_proof_wf f_ref tcc_lemma_ref let register_wf ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas args ret_type body pre_hook = - let type_of_f = Constrexpr_ops.prod_constr_expr ret_type args in + let type_of_f = Constrexpr_ops.mkCProdN args ret_type in let rec_arg_num = let names = List.map - snd + CAst.(with_val (fun x -> x)) (Constrexpr_ops.names_of_local_assums args) in match wf_arg with @@ -451,22 +479,21 @@ let register_wf ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas in let unbounded_eq = let f_app_args = - Constrexpr.CAppExpl - (Loc.ghost, - (None,(Ident (Loc.ghost,fname)),None) , + CAst.make @@ Constrexpr.CAppExpl( + (None,CAst.make @@ Ident fname,None) , (List.map (function - | _,Anonymous -> assert false - | _,Name e -> (Constrexpr_ops.mkIdentC e) + | {CAst.v=Anonymous} -> assert false + | {CAst.v=Name e} -> (Constrexpr_ops.mkIdentC e) ) (Constrexpr_ops.names_of_local_assums args) ) ) in - Constrexpr.CApp (Loc.ghost,(None,Constrexpr_ops.mkRefC (Qualid (Loc.ghost,(qualid_of_string "Logic.eq")))), + CAst.make @@ Constrexpr.CApp ((None,Constrexpr_ops.mkRefC (CAst.make @@ Qualid (qualid_of_string "Logic.eq"))), [(f_app_args,None);(body,None)]) in - let eq = Constrexpr_ops.prod_constr_expr unbounded_eq args in + let eq = Constrexpr_ops.mkCProdN args unbounded_eq in let hook ((f_ref,_) as fconst) tcc_lemma_ref (functional_ref,_) (eq_ref,_) rec_arg_num rec_arg_type nb_args relation = try @@ -495,7 +522,7 @@ let register_mes fname rec_impls wf_mes_expr wf_rel_expr_opt wf_arg using_lemmas | None -> begin match args with - | [Constrexpr.LocalRawAssum ([(_,Name x)],k,t)] -> t,x + | [Constrexpr.CLocalAssum ([{CAst.v=Name x}],k,t)] -> t,x | _ -> error "Recursive argument must be specified" end | Some wf_args -> @@ -503,15 +530,15 @@ let register_mes fname rec_impls wf_mes_expr wf_rel_expr_opt wf_arg using_lemmas match List.find (function - | Constrexpr.LocalRawAssum(l,k,t) -> + | Constrexpr.CLocalAssum(l,k,t) -> List.exists - (function (_,Name id) -> Id.equal id wf_args | _ -> false) + (function {CAst.v=Name id} -> Id.equal id wf_args | _ -> false) l | _ -> false ) args with - | Constrexpr.LocalRawAssum(_,k,t) -> t,wf_args + | Constrexpr.CLocalAssum(_,k,t) -> t,wf_args | _ -> assert false with Not_found -> assert false in @@ -520,13 +547,13 @@ let register_mes fname rec_impls wf_mes_expr wf_rel_expr_opt wf_arg using_lemmas | None -> let ltof = let make_dir l = DirPath.make (List.rev_map Id.of_string l) in - Libnames.Qualid (Loc.ghost,Libnames.qualid_of_path + CAst.make @@ Libnames.Qualid (Libnames.qualid_of_path (Libnames.make_path (make_dir ["Arith";"Wf_nat"]) (Id.of_string "ltof"))) in let fun_from_mes = let applied_mes = Constrexpr_ops.mkAppC(wf_mes_expr,[Constrexpr_ops.mkIdentC wf_arg]) in - Constrexpr_ops.mkLambdaC ([(Loc.ghost,Name wf_arg)],Constrexpr_ops.default_binder_kind,wf_arg_type,applied_mes) + Constrexpr_ops.mkLambdaC ([CAst.make @@ Name wf_arg],Constrexpr_ops.default_binder_kind,wf_arg_type,applied_mes) in let wf_rel_from_mes = Constrexpr_ops.mkAppC(Constrexpr_ops.mkRefC ltof,[wf_arg_type;fun_from_mes]) @@ -537,7 +564,7 @@ let register_mes fname rec_impls wf_mes_expr wf_rel_expr_opt wf_arg using_lemmas let a = Names.Id.of_string "___a" in let b = Names.Id.of_string "___b" in Constrexpr_ops.mkLambdaC( - [Loc.ghost,Name a;Loc.ghost,Name b], + [CAst.make @@ Name a; CAst.make @@ Name b], Constrexpr.Default Explicit, wf_arg_type, Constrexpr_ops.mkAppC(wf_rel_expr, @@ -557,60 +584,54 @@ let map_option f = function | Some v -> Some (f v) open Constrexpr -open Topconstr -let make_assoc assoc l1 l2 = - let fold assoc a b = match a, b with - | (_, Name na), (_, Name id) -> Id.Map.add na id assoc - | _, _ -> assoc - in - List.fold_left2 fold assoc l1 l2 - -let rec rebuild_bl (aux,assoc) bl typ = - match bl,typ with - | [], _ -> (List.rev aux,replace_vars_constr_expr assoc typ,assoc) - | (Constrexpr.LocalRawAssum(nal,bk,_))::bl',typ -> - rebuild_nal (aux,assoc) bk bl' nal (List.length nal) typ - | (Constrexpr.LocalRawDef(na,_))::bl',Constrexpr.CLetIn(_,_,nat,typ') -> - rebuild_bl ((Constrexpr.LocalRawDef(na,replace_vars_constr_expr assoc nat)::aux),assoc) +let rec rebuild_bl aux bl typ = + match bl,typ with + | [], _ -> List.rev aux,typ + | (CLocalAssum(nal,bk,_))::bl',typ -> + rebuild_nal aux bk bl' nal typ + | (CLocalDef(na,_,_))::bl',{ CAst.v = CLetIn(_,nat,ty,typ') } -> + rebuild_bl (Constrexpr.CLocalDef(na,nat,ty)::aux) bl' typ' | _ -> assert false - and rebuild_nal (aux,assoc) bk bl' nal lnal typ = +and rebuild_nal aux bk bl' nal typ = match nal,typ with - | [], _ -> rebuild_bl (aux,assoc) bl' typ - | _,CProdN(_,[],typ) -> rebuild_nal (aux,assoc) bk bl' nal lnal typ - | _,CProdN(_,(nal',bk',nal't)::rest,typ') -> - let lnal' = List.length nal' in - if lnal' >= lnal - then - let old_nal',new_nal' = List.chop lnal nal' in - let nassoc = make_assoc assoc old_nal' nal in - let assum = LocalRawAssum(nal,bk,replace_vars_constr_expr assoc nal't) in - rebuild_bl ((assum :: aux), nassoc) bl' - (if List.is_empty new_nal' && List.is_empty rest - then typ' - else if List.is_empty new_nal' - then CProdN(Loc.ghost,rest,typ') - else CProdN(Loc.ghost,((new_nal',bk',nal't)::rest),typ')) - else - let captured_nal,non_captured_nal = List.chop lnal' nal in - let nassoc = make_assoc assoc nal' captured_nal in - let assum = LocalRawAssum(captured_nal,bk,replace_vars_constr_expr assoc nal't) in - rebuild_nal ((assum :: aux), nassoc) - bk bl' non_captured_nal (lnal - lnal') (CProdN(Loc.ghost,rest,typ')) - | _ -> assert false - -let rebuild_bl (aux,assoc) bl typ = rebuild_bl (aux,assoc) bl typ + | _,{ CAst.v = CProdN([],typ) } -> rebuild_nal aux bk bl' nal typ + | [], _ -> rebuild_bl aux bl' typ + | na::nal,{ CAst.v = CProdN(CLocalAssum(na'::nal',bk',nal't)::rest,typ') } -> + if Name.equal (na.CAst.v) (na'.CAst.v) || Name.is_anonymous (na'.CAst.v) + then + let assum = CLocalAssum([na],bk,nal't) in + let new_rest = if nal' = [] then rest else (CLocalAssum(nal',bk',nal't)::rest) in + rebuild_nal + (assum::aux) + bk + bl' + nal + (CAst.make @@ CProdN(new_rest,typ')) + else + let assum = CLocalAssum([na'],bk,nal't) in + let new_rest = if nal' = [] then rest else (CLocalAssum(nal',bk',nal't)::rest) in + rebuild_nal + (assum::aux) + bk + bl' + (na::nal) + (CAst.make @@ CProdN(new_rest,typ')) + | _ -> + assert false + +let rebuild_bl aux bl typ = rebuild_bl aux 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),_,ctx,_) = Command.interp_fixpoint fixl ntns in + let fixl,ntns = ComFixpoint.extract_fixpoint_components false fixpoint_exprl in + let ((_,_,typel),_,ctx,_) = ComFixpoint.interp_fixpoint ~cofix:false fixl ntns in let constr_expr_typel = - with_full_print (List.map (Constrextern.extern_constr false (Global.env ()) (Evd.from_ctx ctx))) typel in + with_full_print (List.map (fun c -> Constrextern.extern_constr false (Global.env ()) (Evd.from_ctx ctx) (EConstr.of_constr c))) typel in let fixpoint_exprl_with_new_bl = List.map2 (fun ((lna,(rec_arg_opt,rec_order),bl,ret_typ,opt_body),notation_list) fix_typ -> - let new_bl',new_ret_type,_ = rebuild_bl ([],Id.Map.empty) bl fix_typ in + let new_bl',new_ret_type = rebuild_bl [] bl fix_typ in (((lna,(rec_arg_opt,rec_order),new_bl',new_ret_type,opt_body),notation_list):(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list)) ) fixpoint_exprl constr_expr_typel @@ -624,13 +645,13 @@ let do_generate_principle pconstants on_error register_built interactive_proof let _is_struct = match fixpoint_exprl with | [((_,(wf_x,Constrexpr.CWfRec wf_rel),_,_,_),_) as fixpoint_expr] -> - let (((((_,name),pl),_,args,types,body)),_) as fixpoint_expr = + let (((({CAst.v=name},pl),_,args,types,body)),_) as fixpoint_expr = match recompute_binder_list [fixpoint_expr] with | [e] -> e | _ -> assert false in let fixpoint_exprl = [fixpoint_expr] in - let body = match body with | Some body -> body | None -> user_err_loc (Loc.ghost,"Function",str "Body of Function must be given") in + let body = match body with | Some body -> body | None -> user_err ~hdr:"Function" (str "Body of Function must be given") in let recdefs,rec_impls = build_newrecursive fixpoint_exprl in let using_lemmas = [] in let pre_hook pconstants = @@ -645,10 +666,10 @@ let do_generate_principle pconstants on_error register_built interactive_proof true in if register_built - then register_wf name rec_impls wf_rel (map_option snd wf_x) using_lemmas args types body pre_hook; + then register_wf name rec_impls wf_rel (map_option (fun x -> x.CAst.v) wf_x) using_lemmas args types body pre_hook; false |[((_,(wf_x,Constrexpr.CMeasureRec(wf_mes,wf_rel_opt)),_,_,_),_) as fixpoint_expr] -> - let (((((_,name),_),_,args,types,body)),_) as fixpoint_expr = + let (((({CAst.v=name},_),_,args,types,body)),_) as fixpoint_expr = match recompute_binder_list [fixpoint_expr] with | [e] -> e | _ -> assert false @@ -656,7 +677,7 @@ let do_generate_principle pconstants on_error register_built interactive_proof let fixpoint_exprl = [fixpoint_expr] in let recdefs,rec_impls = build_newrecursive fixpoint_exprl in let using_lemmas = [] in - let body = match body with | Some body -> body | None -> user_err_loc (Loc.ghost,"Function",str "Body of Function must be given") in + let body = match body with | Some body -> body | None -> user_err ~hdr:"Function" (str "Body of Function must be given") in let pre_hook pconstants = generate_principle (ref (Evd.from_env (Global.env ()))) @@ -669,7 +690,7 @@ let do_generate_principle pconstants on_error register_built interactive_proof true in if register_built - then register_mes name rec_impls wf_mes wf_rel_opt (map_option snd wf_x) using_lemmas args types body pre_hook; + then register_mes name rec_impls wf_mes wf_rel_opt (map_option (fun x -> x.CAst.v) wf_x) using_lemmas args types body pre_hook; true | _ -> List.iter (function ((_na,(_,ord),_args,_body,_type),_not) -> @@ -682,7 +703,7 @@ let do_generate_principle pconstants on_error register_built interactive_proof fixpoint_exprl; let fixpoint_exprl = recompute_binder_list fixpoint_exprl in let fix_names = - List.map (function ((((_,name),_),_,_,_,_),_) -> name) fixpoint_exprl + List.map (function ((({CAst.v=name},_),_,_,_,_),_) -> name) fixpoint_exprl in (* ok all the expressions are structural *) let recdefs,rec_impls = build_newrecursive fixpoint_exprl in @@ -708,67 +729,69 @@ let do_generate_principle pconstants on_error register_built interactive_proof in () -let rec add_args id new_args b = - match b with - | CRef (r,_) -> - begin match r with - | Libnames.Ident(loc,fname) when Id.equal fname id -> - CAppExpl(Loc.ghost,(None,r,None),new_args) +let rec add_args id new_args = CAst.map (function + | CRef (r,_) as b -> + begin match r with + | {CAst.v=Libnames.Ident fname} when Id.equal fname id -> + CAppExpl((None,r,None),new_args) | _ -> b end - | CFix _ | CCoFix _ -> anomaly ~label:"add_args " (Pp.str "todo") - | CProdN(loc,nal,b1) -> - CProdN(loc, - List.map (fun (nal,k,b2) -> (nal,k,add_args id new_args b2)) nal, + | CFix _ | CCoFix _ -> anomaly ~label:"add_args " (Pp.str "todo.") + | CProdN(nal,b1) -> + CProdN(List.map (function CLocalAssum (nal,k,b2) -> CLocalAssum (nal,k,add_args id new_args b2) + | CLocalDef (na,b1,t) -> CLocalDef (na,add_args id new_args b1,Option.map (add_args id new_args) t) + | CLocalPattern _ -> user_err (Pp.str "pattern with quote not allowed here.")) nal, add_args id new_args b1) - | CLambdaN(loc,nal,b1) -> - CLambdaN(loc, - List.map (fun (nal,k,b2) -> (nal,k,add_args id new_args b2)) nal, + | CLambdaN(nal,b1) -> + CLambdaN(List.map (function CLocalAssum (nal,k,b2) -> CLocalAssum (nal,k,add_args id new_args b2) + | CLocalDef (na,b1,t) -> CLocalDef (na,add_args id new_args b1,Option.map (add_args id new_args) t) + | CLocalPattern _ -> user_err (Pp.str "pattern with quote not allowed here.")) nal, 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,us),exprl) -> + | CLetIn(na,b1,t,b2) -> + CLetIn(na,add_args id new_args b1,Option.map (add_args id new_args) t,add_args id new_args b2) + | CAppExpl((pf,r,us),exprl) -> begin match r with - | Libnames.Ident(loc,fname) when Id.equal fname id -> - 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) + | {CAst.v=Libnames.Ident fname} when Id.equal fname id -> + CAppExpl((pf,r,us),new_args@(List.map (add_args id new_args) exprl)) + | _ -> CAppExpl((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), + | CApp((pf,b),bl) -> + CApp((pf,add_args id new_args b), List.map (fun (e,o) -> add_args id new_args e,o) bl) - | CCases(loc,sty,b_option,cel,cal) -> - CCases(loc,sty,Option.map (add_args id new_args) b_option, + | CCases(sty,b_option,cel,cal) -> + CCases(sty,Option.map (add_args id new_args) b_option, List.map (fun (b,na,b_option) -> add_args id new_args b, na, b_option) cel, - List.map (fun (loc,cpl,e) -> (loc,cpl,add_args id new_args e)) cal + List.map CAst.(map (fun (cpl,e) -> (cpl,add_args id new_args e))) cal ) - | CLetTuple(loc,nal,(na,b_option),b1,b2) -> - CLetTuple(loc,nal,(na,Option.map (add_args id new_args) b_option), + | CLetTuple(nal,(na,b_option),b1,b2) -> + CLetTuple(nal,(na,Option.map (add_args id new_args) b_option), add_args id new_args b1, add_args id new_args b2 ) - | CIf(loc,b1,(na,b_option),b2,b3) -> - CIf(loc,add_args id new_args b1, + | CIf(b1,(na,b_option),b2,b3) -> + CIf(add_args id new_args b1, (na,Option.map (add_args id new_args) b_option), add_args id new_args b2, add_args id new_args b3 ) - | CHole _ -> b - | CPatVar _ -> b - | CEvar _ -> b - | CSort _ -> b - | CCast(loc,b1,b2) -> - CCast(loc,add_args id new_args b1, + | CHole _ + | CPatVar _ + | CEvar _ + | CPrim _ + | CSort _ as b -> b + | CCast(b1,b2) -> + CCast(add_args id new_args b1, Miscops.map_cast_type (add_args id new_args) b2) - | CRecord (loc, pars) -> - CRecord (loc, List.map (fun (e,o) -> e, add_args id new_args o) pars) - | CNotation _ -> anomaly ~label:"add_args " (Pp.str "CNotation") - | CGeneralization _ -> anomaly ~label:"add_args " (Pp.str "CGeneralization") - | CPrim _ -> b - | CDelimiters _ -> anomaly ~label:"add_args " (Pp.str "CDelimiters") + | CRecord pars -> + CRecord (List.map (fun (e,o) -> e, add_args id new_args o) pars) + | CNotation _ -> anomaly ~label:"add_args " (Pp.str "CNotation.") + | CGeneralization _ -> anomaly ~label:"add_args " (Pp.str "CGeneralization.") + | CDelimiters _ -> anomaly ~label:"add_args " (Pp.str "CDelimiters.") + ) exception Stop of Constrexpr.constr_expr @@ -779,8 +802,8 @@ let rec chop_n_arrow n t = if n <= 0 then t (* If we have already removed all the arrows then return the type *) else (* If not we check the form of [t] *) - match t with - | Constrexpr.CProdN(_,nal_ta',t') -> (* If we have a forall, to result are possible : + match t.CAst.v with + | Constrexpr.CProdN(nal_ta',t') -> (* If we have a forall, two results are possible : either we need to discard more than the number of arrows contained in this product declaration then we just recall [chop_n_arrow] on the remaining number of arrow to chop and [t'] we discard it and @@ -792,104 +815,103 @@ let rec chop_n_arrow n t = let new_n = let rec aux (n:int) = function [] -> n - | (nal,k,t'')::nal_ta' -> + | CLocalAssum(nal,k,t'')::nal_ta' -> let nal_l = List.length nal in if n >= nal_l then aux (n - nal_l) nal_ta' else - let new_t' = - Constrexpr.CProdN(Loc.ghost, - ((snd (List.chop n nal)),k,t'')::nal_ta',t') + let new_t' = CAst.make @@ + Constrexpr.CProdN( + CLocalAssum((snd (List.chop n nal)),k,t'')::nal_ta',t') in raise (Stop new_t') + | _ -> anomaly (Pp.str "Not enough products.") in aux n nal_ta' in chop_n_arrow new_n t' with Stop t -> t end - | _ -> anomaly (Pp.str "Not enough products") + | _ -> anomaly (Pp.str "Not enough products.") -let rec get_args b t : Constrexpr.local_binder list * +let rec get_args b t : Constrexpr.local_binder_expr list * Constrexpr.constr_expr * Constrexpr.constr_expr = - match b with - | Constrexpr.CLambdaN (loc, (nal_ta), b') -> + match b.CAst.v with + | Constrexpr.CLambdaN (CLocalAssum(nal,k,ta) as d::rest, b') -> begin - let n = - (List.fold_left (fun n (nal,_,_) -> - n+List.length nal) 0 nal_ta ) - in - let nal_tas,b'',t'' = get_args b' (chop_n_arrow n t) in - (List.map (fun (nal,k,ta) -> - (Constrexpr.LocalRawAssum (nal,k,ta))) nal_ta)@nal_tas, b'',t'' + let n = List.length nal in + let nal_tas,b'',t'' = get_args (CAst.make ?loc:b.CAst.loc @@ Constrexpr.CLambdaN (rest,b')) (chop_n_arrow n t) in + d :: nal_tas, b'',t'' end + | Constrexpr.CLambdaN ([], b) -> [],b,t | _ -> [],b,t let make_graph (f_ref:global_reference) = let c,c_body = match f_ref with - | ConstRef c -> - begin try c,Global.lookup_constant c - with Not_found -> - raise (UserError ("",str "Cannot find " ++ Printer.pr_lconstr (mkConst c)) ) - end - | _ -> raise (UserError ("", str "Not a function reference") ) + | ConstRef c -> + begin try c,Global.lookup_constant c + with Not_found -> + let sigma, env = Pfedit.get_current_context () in + raise (UserError (None,str "Cannot find " ++ Printer.pr_leconstr_env env sigma (mkConst c)) ) + end + | _ -> raise (UserError (None, str "Not a function reference") ) in (match Global.body_of_constant_body c_body with - | None -> error "Cannot build a graph over an axiom !" - | Some body -> + | None -> error "Cannot build a graph over an axiom!" + | Some (body, _) -> let env = Global.env () in let sigma = Evd.from_env env in let extern_body,extern_type = with_full_print (fun () -> - (Constrextern.extern_constr false env sigma body, + (Constrextern.extern_constr false env sigma (EConstr.of_constr body), Constrextern.extern_type false env sigma - ((*FIXME*) Typeops.type_of_constant_type env c_body.const_type) + (EConstr.of_constr (*FIXME*) c_body.const_type) ) ) () in let (nal_tas,b,t) = get_args extern_body extern_type in let expr_list = - match b with - | Constrexpr.CFix(loc,l_id,fixexprl) -> + match b.CAst.v with + | Constrexpr.CFix(l_id,fixexprl) -> let l = List.map (fun (id,(n,recexp),bl,t,b) -> - let loc, rec_id = Option.get n in + let { CAst.loc; v=rec_id } = Option.get n in let new_args = List.flatten (List.map (function - | Constrexpr.LocalRawDef (na,_)-> [] - | Constrexpr.LocalRawAssum (nal,_,_) -> + | Constrexpr.CLocalDef (na,_,_)-> [] + | Constrexpr.CLocalAssum (nal,_,_) -> List.map - (fun (loc,n) -> - CRef(Libnames.Ident(loc, Nameops.out_name n),None)) + (fun {CAst.loc;v=n} -> CAst.make ?loc @@ + CRef(CAst.make ?loc @@ Libnames.Ident(Nameops.Name.get_id n),None)) nal - | Constrexpr.LocalPattern _ -> assert false + | Constrexpr.CLocalPattern _ -> assert false ) nal_tas ) in - let b' = add_args (snd id) new_args b in - ((((id,None), ( Some (Loc.ghost,rec_id),CStructRec),nal_tas@bl,t,Some b'),[]):(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list)) + let b' = add_args id.CAst.v new_args b in + ((((id,None), ( Some CAst.(make rec_id),CStructRec),nal_tas@bl,t,Some b'),[]):(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list)) ) fixexprl in l | _ -> - let id = Label.to_id (con_label c) in - [(((Loc.ghost,id),None),(None,Constrexpr.CStructRec),nal_tas,t,Some b),[]] + let id = Label.to_id (Constant.label c) in + [((CAst.make id,None),(None,Constrexpr.CStructRec),nal_tas,t,Some b),[]] in - let mp,dp,_ = repr_con c in + let mp,dp,_ = Constant.repr3 c in do_generate_principle [c,Univ.Instance.empty] error_error false false expr_list; (* We register the infos *) List.iter - (fun ((((_,id),_),_,_,_,_),_) -> add_Function false (make_con mp dp (Label.of_id id))) + (fun ((({CAst.v=id},_),_,_,_,_),_) -> add_Function false (Constant.make3 mp dp (Label.of_id id))) expr_list) let do_generate_principle = do_generate_principle [] warning_error true diff --git a/plugins/funind/indfun.mli b/plugins/funind/indfun.mli index 1c27bdfa..dcc1c2ea 100644 --- a/plugins/funind/indfun.mli +++ b/plugins/funind/indfun.mli @@ -1,8 +1,8 @@ open Misctypes -val warn_cannot_define_graph : ?loc:Loc.t -> Pp.std_ppcmds * Pp.std_ppcmds -> unit +val warn_cannot_define_graph : ?loc:Loc.t -> Pp.t * Pp.t -> unit -val warn_cannot_define_principle : ?loc:Loc.t -> Pp.std_ppcmds * Pp.std_ppcmds -> unit +val warn_cannot_define_principle : ?loc:Loc.t -> Pp.t * Pp.t -> unit val do_generate_principle : bool -> @@ -12,10 +12,10 @@ val do_generate_principle : val functional_induction : bool -> - Term.constr -> - (Term.constr * Term.constr bindings) option -> - Tacexpr.or_and_intro_pattern option -> - Proof_type.goal Tacmach.sigma -> Proof_type.goal list Evd.sigma + EConstr.constr -> + (EConstr.constr * EConstr.constr bindings) option -> + Ltac_plugin.Tacexpr.or_and_intro_pattern option -> + Goal.goal Evd.sigma -> Goal.goal list Evd.sigma val make_graph : Globnames.global_reference -> unit diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index f56e9241..a0b9217c 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -1,8 +1,10 @@ open Names open Pp +open Constr open Libnames open Globnames open Refiner + let mk_prefix pre id = Id.of_string (pre^(Id.to_string id)) let mk_rel_id = mk_prefix "R_" let mk_correct_id id = Nameops.add_suffix (mk_rel_id id) "_correct" @@ -12,7 +14,7 @@ let mk_equation_id id = Nameops.add_suffix id "_equation" let msgnl m = () -let fresh_id avoid s = Namegen.next_ident_away_in_goal (Id.of_string s) avoid +let fresh_id avoid s = Namegen.next_ident_away_in_goal (Id.of_string s) (Id.Set.of_list avoid) let fresh_name avoid s = Name (fresh_id avoid s) @@ -21,19 +23,16 @@ let get_name avoid ?(default="H") = function | Name n -> Name n let array_get_start a = - try - Array.init - (Array.length a - 1) - (fun i -> a.(i)) - with Invalid_argument "index out of bounds" -> - invalid_arg "array_get_start" + Array.init + (Array.length a - 1) + (fun i -> a.(i)) let id_of_name = function Name id -> id | _ -> raise Not_found let locate ref = - let (loc,qid) = qualid_of_reference ref in + let {CAst.v=qid} = qualid_of_reference ref in Nametab.locate qid let locate_ind ref = @@ -49,7 +48,7 @@ let locate_constant ref = let locate_with_msg msg f x = try f x - with Not_found -> raise (CErrors.UserError("", msg)) + with Not_found -> raise (CErrors.UserError(None, msg)) let filter_map filter f = @@ -69,11 +68,11 @@ let chop_rlambda_n = if n == 0 then List.rev acc,rt else - match rt with - | Glob_term.GLambda(_,name,k,t,b) -> chop_lambda_n ((name,t,false)::acc) (n-1) b - | Glob_term.GLetIn(_,name,v,b) -> chop_lambda_n ((name,v,true)::acc) (n-1) b + match DAst.get rt with + | Glob_term.GLambda(name,k,t,b) -> chop_lambda_n ((name,t,None)::acc) (n-1) b + | Glob_term.GLetIn(name,v,t,b) -> chop_lambda_n ((name,v,t)::acc) (n-1) b | _ -> - raise (CErrors.UserError("chop_rlambda_n", + raise (CErrors.UserError(Some "chop_rlambda_n", str "chop_rlambda_n: Not enough Lambdas")) in chop_lambda_n [] @@ -83,9 +82,9 @@ let chop_rprod_n = if n == 0 then List.rev acc,rt else - match rt with - | Glob_term.GProd(_,name,k,t,b) -> chop_prod_n ((name,t)::acc) (n-1) b - | _ -> raise (CErrors.UserError("chop_rprod_n",str "chop_rprod_n: Not enough products")) + match DAst.get rt with + | Glob_term.GProd(name,k,t,b) -> chop_prod_n ((name,t)::acc) (n-1) b + | _ -> raise (CErrors.UserError(Some "chop_rprod_n",str "chop_rprod_n: Not enough products")) in chop_prod_n [] @@ -101,20 +100,15 @@ let list_union_eq eq_fun l1 l2 = let list_add_set_eq eq_fun x l = if List.exists (eq_fun x) l then l else x::l - - - let const_of_id id = - let _,princ_ref = - qualid_of_reference (Libnames.Ident (Loc.ghost,id)) - in + let princ_ref = qualid_of_ident id in try Constrintern.locate_reference princ_ref with Not_found -> - CErrors.errorlabstrm "IndFun.const_of_id" - (str "cannot find " ++ Nameops.pr_id id) + CErrors.user_err ~hdr:"IndFun.const_of_id" + (str "cannot find " ++ Id.print id) let def_of_const t = - match (Term.kind_of_term t) with + match Constr.kind t with Term.Const sp -> (try (match Environ.constant_opt_value_in (Global.env()) sp with | Some c -> c @@ -123,15 +117,16 @@ let def_of_const t = |_ -> assert false let coq_constant s = - Coqlib.gen_constant_in_modules "RecursiveDefinition" + Universes.constr_of_global @@ + Coqlib.gen_reference_in_modules "RecursiveDefinition" Coqlib.init_modules s;; let find_reference sl s = let dp = Names.DirPath.make (List.rev_map Id.of_string sl) in Nametab.locate (make_qualid dp (Id.of_string s)) -let eq = lazy(coq_constant "eq") -let refl_equal = lazy(coq_constant "eq_refl") +let eq = lazy(EConstr.of_constr (coq_constant "eq")) +let refl_equal = lazy(EConstr.of_constr (coq_constant "eq_refl")) (*****************************************************************) (* Copy of the standart save mechanism but without the much too *) @@ -162,7 +157,7 @@ let save with_clean id const (locality,_,kind) hook = let kn = declare_constant id ~local (DefinitionEntry const, k) in (locality, ConstRef kn) in - if with_clean then Pfedit.delete_current_proof (); + if with_clean then Proof_global.discard_current (); CEphemeron.iter_opt hook (fun f -> Lemmas.call_hook fix_exn f l r); definition_message id @@ -174,7 +169,7 @@ let cook_proof _ = let get_proof_clean do_reduce = let result = cook_proof do_reduce in - Pfedit.delete_current_proof (); + Proof_global.discard_current (); result let with_full_print f a = @@ -183,12 +178,13 @@ let with_full_print f a = and old_contextual_implicit_args = Impargs.is_contextual_implicit_args () in let old_rawprint = !Flags.raw_print in let old_printuniverses = !Constrextern.print_universes in + let old_printallowmatchdefaultclause = !Detyping.print_allow_match_default_clause in Constrextern.print_universes := true; + Detyping.print_allow_match_default_clause := false; Flags.raw_print := true; Impargs.make_implicit_args false; Impargs.make_strict_implicit_args false; Impargs.make_contextual_implicit_args false; - Impargs.make_contextual_implicit_args false; Dumpglob.pause (); try let res = f a in @@ -197,6 +193,7 @@ let with_full_print f a = Impargs.make_contextual_implicit_args old_contextual_implicit_args; Flags.raw_print := old_rawprint; Constrextern.print_universes := old_printuniverses; + Detyping.print_allow_match_default_clause := old_printallowmatchdefaultclause; Dumpglob.continue (); res with @@ -206,6 +203,7 @@ let with_full_print f a = Impargs.make_contextual_implicit_args old_contextual_implicit_args; Flags.raw_print := old_rawprint; Constrextern.print_universes := old_printuniverses; + Detyping.print_allow_match_default_clause := old_printallowmatchdefaultclause; Dumpglob.continue (); raise reraise @@ -218,14 +216,14 @@ let with_full_print f a = type function_info = { - function_constant : constant; + function_constant : Constant.t; graph_ind : inductive; - equation_lemma : constant option; - correctness_lemma : constant option; - completeness_lemma : constant option; - rect_lemma : constant option; - rec_lemma : constant option; - prop_lemma : constant option; + equation_lemma : Constant.t option; + correctness_lemma : Constant.t option; + completeness_lemma : Constant.t option; + rect_lemma : Constant.t option; + rec_lemma : Constant.t option; + prop_lemma : Constant.t option; is_general : bool; (* Has this function been defined using general recursive definition *) } @@ -332,18 +330,18 @@ let discharge_Function (_,finfos) = is_general = finfos.is_general } -open Term - let pr_ocst c = - Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) c (mt ()) + let sigma, env = Pfedit.get_current_context () in + Option.fold_right (fun v acc -> Printer.pr_lconstr_env env sigma (mkConst v)) c (mt ()) let pr_info f_info = + let sigma, env = Pfedit.get_current_context () in str "function_constant := " ++ - Printer.pr_lconstr (mkConst f_info.function_constant)++ fnl () ++ + Printer.pr_lconstr_env env sigma (mkConst f_info.function_constant)++ fnl () ++ str "function_constant_type := " ++ (try - Printer.pr_lconstr - (Global.type_of_global_unsafe (ConstRef f_info.function_constant)) + Printer.pr_lconstr_env env sigma + (fst (Global.type_of_global_in_context env (ConstRef f_info.function_constant))) with e when CErrors.noncritical e -> mt ()) ++ fnl () ++ str "equation_lemma := " ++ pr_ocst f_info.equation_lemma ++ fnl () ++ str "completeness_lemma :=" ++ pr_ocst f_info.completeness_lemma ++ fnl () ++ @@ -351,7 +349,7 @@ let pr_info f_info = str "rect_lemma := " ++ pr_ocst f_info.rect_lemma ++ fnl () ++ str "rec_lemma := " ++ pr_ocst f_info.rec_lemma ++ fnl () ++ str "prop_lemma := " ++ pr_ocst f_info.prop_lemma ++ fnl () ++ - str "graph_ind := " ++ Printer.pr_lconstr (mkInd f_info.graph_ind) ++ fnl () + str "graph_ind := " ++ Printer.pr_lconstr_env env sigma (mkInd f_info.graph_ind) ++ fnl () let pr_table tb = let l = Cmap_env.fold (fun k v acc -> v::acc) tb [] in @@ -371,7 +369,7 @@ let in_Function : function_info -> Libobject.obj = let find_or_none id = try Some - (match Nametab.locate (qualid_of_ident id) with ConstRef c -> c | _ -> CErrors.anomaly (Pp.str "Not a constant") + (match Nametab.locate (qualid_of_ident id) with ConstRef c -> c | _ -> CErrors.anomaly (Pp.str "Not a constant.") ) with Not_found -> None @@ -390,7 +388,7 @@ let update_Function finfo = let add_Function is_general f = - let f_id = Label.to_id (con_label f) in + let f_id = Label.to_id (Constant.label f) in let equation_lemma = find_or_none (mk_equation_id f_id) and correctness_lemma = find_or_none (mk_correct_id f_id) and completeness_lemma = find_or_none (mk_complete_id f_id) @@ -399,7 +397,7 @@ let add_Function is_general f = and prop_lemma = find_or_none (Nameops.add_suffix f_id "_ind") and graph_ind = match Nametab.locate (qualid_of_ident (mk_rel_id f_id)) - with | IndRef ind -> ind | _ -> CErrors.anomaly (Pp.str "Not an inductive") + with | IndRef ind -> ind | _ -> CErrors.anomaly (Pp.str "Not an inductive.") in let finfos = { function_constant = f; @@ -425,7 +423,6 @@ open Goptions let functional_induction_rewrite_dependent_proofs_sig = { - optsync = false; optdepr = false; optname = "Functional Induction Rewrite Dependent"; optkey = ["Functional";"Induction";"Rewrite";"Dependent"]; @@ -438,7 +435,6 @@ let do_rewrite_dependent () = !functional_induction_rewrite_dependent_proofs = t let function_debug_sig = { - optsync = false; optdepr = false; optname = "Function debug"; optkey = ["Function_debug"]; @@ -457,7 +453,6 @@ let strict_tcc = ref false let is_strict_tcc () = !strict_tcc let strict_tcc_sig = { - optsync = false; optdepr = false; optname = "Raw Function Tcc"; optkey = ["Function_raw_tcc"]; @@ -475,13 +470,17 @@ exception ToShow of exn let jmeq () = try Coqlib.check_required_library Coqlib.jmeq_module_name; - Coqlib.gen_constant "Function" ["Logic";"JMeq"] "JMeq" + EConstr.of_constr @@ + Universes.constr_of_global @@ + Coqlib.coq_reference "Function" ["Logic";"JMeq"] "JMeq" with e when CErrors.noncritical e -> raise (ToShow e) let jmeq_refl () = try Coqlib.check_required_library Coqlib.jmeq_module_name; - Coqlib.gen_constant "Function" ["Logic";"JMeq"] "JMeq_refl" + EConstr.of_constr @@ + Universes.constr_of_global @@ + Coqlib.coq_reference "Function" ["Logic";"JMeq"] "JMeq_refl" with e when CErrors.noncritical e -> raise (ToShow e) let h_intros l = @@ -489,10 +488,13 @@ let h_intros l = let h_id = Id.of_string "h" let hrec_id = Id.of_string "hrec" -let well_founded = function () -> (coq_constant "well_founded") -let acc_rel = function () -> (coq_constant "Acc") -let acc_inv_id = function () -> (coq_constant "Acc_inv") -let well_founded_ltof = function () -> (Coqlib.coq_constant "" ["Arith";"Wf_nat"] "well_founded_ltof") +let well_founded = function () -> EConstr.of_constr (coq_constant "well_founded") +let acc_rel = function () -> EConstr.of_constr (coq_constant "Acc") +let acc_inv_id = function () -> EConstr.of_constr (coq_constant "Acc_inv") + +let well_founded_ltof () = EConstr.of_constr @@ Universes.constr_of_global @@ + Coqlib.coq_reference "" ["Arith";"Wf_nat"] "well_founded_ltof" + let ltof_ref = function () -> (find_reference ["Coq";"Arith";"Wf_nat"] "ltof") let evaluable_of_global_reference r = (* Tacred.evaluable_of_global_reference (Global.env ()) *) @@ -501,8 +503,58 @@ let evaluable_of_global_reference r = (* Tacred.evaluable_of_global_reference (G | VarRef id -> EvalVarRef id | _ -> assert false;; -let list_rewrite (rev:bool) (eqs: (constr*bool) list) = +let list_rewrite (rev:bool) (eqs: (EConstr.constr*bool) list) = tclREPEAT (List.fold_right (fun (eq,b) i -> tclORELSE (Proofview.V82.of_tactic ((if b then Equality.rewriteLR else Equality.rewriteRL) eq)) i) (if rev then (List.rev eqs) else eqs) (tclFAIL 0 (mt())));; + +let decompose_lam_n sigma n = + if n < 0 then CErrors.user_err Pp.(str "decompose_lam_n: integer parameter must be positive"); + let rec lamdec_rec l n c = + if Int.equal n 0 then l,c + else match EConstr.kind sigma c with + | Lambda (x,t,c) -> lamdec_rec ((x,t)::l) (n-1) c + | Cast (c,_,_) -> lamdec_rec l n c + | _ -> CErrors.user_err Pp.(str "decompose_lam_n: not enough abstractions") + in + lamdec_rec [] n + +let lamn n env b = + let open EConstr in + let rec lamrec = function + | (0, env, b) -> b + | (n, ((v,t)::l), b) -> lamrec (n-1, l, mkLambda (v,t,b)) + | _ -> assert false + in + lamrec (n,env,b) + +(* compose_lam [xn:Tn;..;x1:T1] b = [x1:T1]..[xn:Tn]b *) +let compose_lam l b = lamn (List.length l) l b + +(* prodn n [xn:Tn;..;x1:T1;Gamma] b = (x1:T1)..(xn:Tn)b *) +let prodn n env b = + let open EConstr in + let rec prodrec = function + | (0, env, b) -> b + | (n, ((v,t)::l), b) -> prodrec (n-1, l, mkProd (v,t,b)) + | _ -> assert false + in + prodrec (n,env,b) + +(* compose_prod [xn:Tn;..;x1:T1] b = (x1:T1)..(xn:Tn)b *) +let compose_prod l b = prodn (List.length l) l b + +type tcc_lemma_value = + | Undefined + | Value of constr + | Not_needed + +(* We only "purify" on exceptions. XXX: What is this doing here? *) +let funind_purify f x = + let st = Vernacstate.freeze_interp_state `No in + try f x + with e -> + let e = CErrors.push e in + Vernacstate.unfreeze_interp_state st; + Exninfo.iraise e diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli index e5c756f5..5cc7163a 100644 --- a/plugins/funind/indfun_common.mli +++ b/plugins/funind/indfun_common.mli @@ -1,5 +1,4 @@ open Names -open Pp (* The mk_?_id function build different name w.r.t. a function @@ -11,7 +10,7 @@ val mk_complete_id : Id.t -> Id.t val mk_equation_id : Id.t -> Id.t -val msgnl : std_ppcmds -> unit +val msgnl : Pp.t -> unit val fresh_id : Id.t list -> string -> Id.t val fresh_name : Id.t list -> string -> Name.t @@ -22,9 +21,9 @@ val array_get_start : 'a array -> 'a array val id_of_name : Name.t -> Id.t val locate_ind : Libnames.reference -> inductive -val locate_constant : Libnames.reference -> constant +val locate_constant : Libnames.reference -> Constant.t val locate_with_msg : - Pp.std_ppcmds -> (Libnames.reference -> 'a) -> + Pp.t -> (Libnames.reference -> 'a) -> Libnames.reference -> 'a val filter_map : ('a -> bool) -> ('a -> 'b) -> 'a list -> 'b list @@ -34,17 +33,17 @@ val list_add_set_eq : ('a -> 'a -> bool) -> 'a -> 'a list -> 'a list val chop_rlambda_n : int -> Glob_term.glob_constr -> - (Name.t*Glob_term.glob_constr*bool) list * Glob_term.glob_constr + (Name.t*Glob_term.glob_constr*Glob_term.glob_constr option) list * Glob_term.glob_constr val chop_rprod_n : int -> Glob_term.glob_constr -> (Name.t*Glob_term.glob_constr) list * Glob_term.glob_constr -val def_of_const : Term.constr -> Term.constr -val eq : Term.constr Lazy.t -val refl_equal : Term.constr Lazy.t +val def_of_const : Constr.t -> Constr.t +val eq : EConstr.constr Lazy.t +val refl_equal : EConstr.constr Lazy.t val const_of_id: Id.t -> Globnames.global_reference(* constantyes *) -val jmeq : unit -> Term.constr -val jmeq_refl : unit -> Term.constr +val jmeq : unit -> EConstr.constr +val jmeq_refl : unit -> EConstr.constr val save : bool -> Id.t -> Safe_typing.private_constants Entries.definition_entry -> Decl_kinds.goal_kind -> unit Lemmas.declaration_hook CEphemeron.key -> unit @@ -69,28 +68,28 @@ val with_full_print : ('a -> 'b) -> 'a -> 'b type function_info = { - function_constant : constant; + function_constant : Constant.t; graph_ind : inductive; - equation_lemma : constant option; - correctness_lemma : constant option; - completeness_lemma : constant option; - rect_lemma : constant option; - rec_lemma : constant option; - prop_lemma : constant option; + equation_lemma : Constant.t option; + correctness_lemma : Constant.t option; + completeness_lemma : Constant.t option; + rect_lemma : Constant.t option; + rec_lemma : Constant.t option; + prop_lemma : Constant.t option; is_general : bool; } -val find_Function_infos : constant -> function_info +val find_Function_infos : Constant.t -> function_info val find_Function_of_graph : inductive -> function_info (* WARNING: To be used just after the graph definition !!! *) -val add_Function : bool -> constant -> unit +val add_Function : bool -> Constant.t -> unit val update_Function : function_info -> unit (** debugging *) -val pr_info : function_info -> Pp.std_ppcmds -val pr_table : unit -> Pp.std_ppcmds +val pr_info : function_info -> Pp.t +val pr_table : unit -> Pp.t (* val function_debug : bool ref *) @@ -104,13 +103,25 @@ exception ToShow of exn val is_strict_tcc : unit -> bool -val h_intros: Names.Id.t list -> Proof_type.tactic +val h_intros: Names.Id.t list -> Tacmach.tactic val h_id : Names.Id.t val hrec_id : Names.Id.t -val acc_inv_id : Term.constr Util.delayed +val acc_inv_id : EConstr.constr Util.delayed val ltof_ref : Globnames.global_reference Util.delayed -val well_founded_ltof : Term.constr Util.delayed -val acc_rel : Term.constr Util.delayed -val well_founded : Term.constr Util.delayed +val well_founded_ltof : EConstr.constr Util.delayed +val acc_rel : EConstr.constr Util.delayed +val well_founded : EConstr.constr Util.delayed val evaluable_of_global_reference : Globnames.global_reference -> Names.evaluable_global_reference -val list_rewrite : bool -> (Term.constr*bool) list -> Proof_type.tactic +val list_rewrite : bool -> (EConstr.constr*bool) list -> Tacmach.tactic + +val decompose_lam_n : Evd.evar_map -> int -> EConstr.t -> + (Names.Name.t * EConstr.t) list * EConstr.t +val compose_lam : (Names.Name.t * EConstr.t) list -> EConstr.t -> EConstr.t +val compose_prod : (Names.Name.t * EConstr.t) list -> EConstr.t -> EConstr.t + +type tcc_lemma_value = + | Undefined + | Value of Constr.t + | Not_needed + +val funind_purify : ('a -> 'b) -> ('a -> 'b) diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index 26fc88a6..bed95740 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -1,17 +1,21 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Tacexpr +open Ltac_plugin open Declarations open CErrors open Util open Names open Term +open Constr +open EConstr open Vars open Pp open Globnames @@ -23,30 +27,7 @@ open Misctypes open Termops open Context.Rel.Declaration -(* Some pretty printing function for debugging purpose *) - -let pr_binding prc = - function - | loc, NamedHyp id, c -> hov 1 (Ppconstr.pr_id id ++ str " := " ++ Pp.cut () ++ prc c) - | loc, AnonHyp n, c -> hov 1 (int n ++ str " := " ++ Pp.cut () ++ prc c) - -let pr_bindings prc prlc = function - | ImplicitBindings l -> - brk (1,1) ++ str "with" ++ brk (1,1) ++ - pr_sequence prc l - | ExplicitBindings l -> - brk (1,1) ++ str "with" ++ brk (1,1) ++ - pr_sequence (fun b -> str"(" ++ pr_binding prlc b ++ str")") l - | NoBindings -> mt () - - -let pr_with_bindings prc prlc (c,bl) = - prc c ++ hv 0 (pr_bindings prc prlc bl) - - - -let pr_constr_with_binding prc (c,bl) : Pp.std_ppcmds = - pr_with_bindings prc prc (c,bl) +module RelDecl = Context.Rel.Declaration (* The local debugging mechanism *) (* let msgnl = Pp.msgnl *) @@ -77,12 +58,6 @@ let do_observe_tac s tac g = CErrors.iprint e ++ str " on goal" ++ fnl() ++ goal )); iraise reraise;; - -let observe_tac_strm s tac g = - if do_observe () - then do_observe_tac s tac g - else tac g - let observe_tac s tac g = if do_observe () then do_observe_tac (str s) tac g @@ -106,12 +81,8 @@ let thin ids gl = Proofview.V82.of_tactic (Tactics.clear ids) gl let make_eq () = try - Universes.constr_of_global (Coqlib.build_coq_eq ()) + EConstr.of_constr (Universes.constr_of_global (Coqlib.build_coq_eq ())) with _ -> assert false -let make_eq_refl () = - try - Universes.constr_of_global (Coqlib.build_coq_eq_refl ()) - with _ -> assert false (* [generate_type g_to_f f graph i] build the completeness (resp. correctness) lemma type if [g_to_f = true] @@ -129,15 +100,16 @@ let make_eq_refl () = let generate_type evd 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 evd',graph = - Evd.fresh_global (Global.env ()) !evd (Globnames.IndRef (fst (destInd graph))) + Evd.fresh_global (Global.env ()) !evd (Globnames.IndRef (fst (destInd !evd graph))) in + let graph = EConstr.of_constr graph in evd:=evd'; let graph_arity = Typing.e_type_of (Global.env ()) evd graph in - let ctxt,_ = decompose_prod_assum graph_arity in + let ctxt,_ = decompose_prod_assum !evd graph_arity in let fun_ctxt,res_type = match ctxt with - | [] | [_] -> anomaly (Pp.str "Not a valid context") - | decl :: fun_ctxt -> fun_ctxt, get_type decl + | [] | [_] -> anomaly (Pp.str "Not a valid context.") + | decl :: fun_ctxt -> fun_ctxt, RelDecl.get_type decl in let rec args_from_decl i accu = function | [] -> accu @@ -148,13 +120,13 @@ let generate_type evd g_to_f f graph i = args_from_decl (succ i) (t :: accu) l in (*i We need to name the vars [res] and [fv] i*) - let filter = fun decl -> match get_name decl with + let filter = fun decl -> match RelDecl.get_name decl with | Name id -> Some id | Anonymous -> None in - let named_ctxt = List.map_filter filter fun_ctxt in + let named_ctxt = Id.Set.of_list (List.map_filter filter fun_ctxt) in let res_id = Namegen.next_ident_away_in_goal (Id.of_string "_res") named_ctxt in - let fv_id = Namegen.next_ident_away_in_goal (Id.of_string "fv") (res_id :: named_ctxt) in + let fv_id = Namegen.next_ident_away_in_goal (Id.of_string "fv") (Id.Set.add res_id named_ctxt) in (*i we can then type the argument to be applied to the function [f] i*) let args_as_rels = Array.of_list (args_from_decl 1 [] fun_ctxt) in (*i @@ -191,15 +163,16 @@ let generate_type evd g_to_f f graph i = WARNING: while convertible, [type_of body] and [type] can be non equal *) let find_induction_principle evd f = - let f_as_constant,u = match kind_of_term f with + let f_as_constant,u = match EConstr.kind !evd f with | Const c' -> c' - | _ -> error "Must be used with a function" + | _ -> user_err Pp.(str "Must be used with a function") in let infos = find_Function_infos f_as_constant in match infos.rect_lemma with | None -> raise Not_found | Some rect_lemma -> let evd',rect_lemma = Evd.fresh_global (Global.env ()) !evd (Globnames.ConstRef rect_lemma) in + let rect_lemma = EConstr.of_constr rect_lemma in let evd',typ = Typing.type_of ~refresh:true (Global.env ()) evd' rect_lemma in evd:=evd'; rect_lemma,typ @@ -209,14 +182,13 @@ let rec generate_fresh_id x avoid i = if i == 0 then [] else - let id = Namegen.next_ident_away_in_goal x avoid in + let id = Namegen.next_ident_away_in_goal x (Id.Set.of_list avoid) in id::(generate_fresh_id x (id::avoid) (pred i)) -(* [prove_fun_correct functional_induction funs_constr graphs_constr schemes lemmas_types_infos i ] +(* [prove_fun_correct funs_constr graphs_constr schemes lemmas_types_infos i ] is the tactic used to prove correctness lemma. - [functional_induction] is the tactic defined in [indfun] (dependency problem) [funs_constr], [graphs_constr] [schemes] [lemmas_types_infos] are the mutually recursive functions (resp. graphs of the functions and principles and correctness lemma types) to prove correct. @@ -237,29 +209,29 @@ let rec generate_fresh_id x avoid i = \end{enumerate} *) -let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes lemmas_types_infos i : tactic = +let prove_fun_correct evd funs_constr graphs_constr schemes lemmas_types_infos i : Tacmach.tactic = fun g -> (* first of all we recreate the lemmas types to be used as predicates of the induction principle that is~: \[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,u = destInd graphs_constr.(i) in + let graph_ind,u = destInd evd 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 *) let f_principle,princ_type = schemes.(i) in let princ_type = nf_zeta princ_type in - let princ_infos = Tactics.compute_elim_sig princ_type in + let princ_infos = Tactics.compute_elim_sig evd princ_type in (* The number of args of the function is then easily computable *) - let nb_fun_args = nb_prod (pf_concl g) - 2 in + let nb_fun_args = nb_prod (project g) (pf_concl g) - 2 in let args_names = generate_fresh_id (Id.of_string "x") [] nb_fun_args in let ids = args_names@(pf_ids_of_hyps g) in (* Since we cannot ensure that the functional principle is defined in the environment and due to the bug #1174, we will need to pose the principle using a name *) - let principle_id = Namegen.next_ident_away_in_goal (Id.of_string "princ") ids in + let principle_id = Namegen.next_ident_away_in_goal (Id.of_string "princ") (Id.Set.of_list ids) in let ids = principle_id :: ids in (* We get the branches of the principle *) let branches = List.rev princ_infos.branches in @@ -268,14 +240,14 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes List.map (fun decl -> List.map - (fun id -> Loc.ghost, IntroNaming (IntroIdentifier id)) - (generate_fresh_id (Id.of_string "y") ids (List.length (fst (decompose_prod_assum (get_type decl))))) + (fun id -> CAst.make @@ IntroNaming (IntroIdentifier id)) + (generate_fresh_id (Id.of_string "y") ids (List.length (fst (decompose_prod_assum evd (RelDecl.get_type decl))))) ) branches in (* before building the full intro pattern for the principle *) let eq_ind = make_eq () in - let eq_construct = mkConstructUi (destInd eq_ind, 1) in + let eq_construct = mkConstructUi (destInd evd 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 @@ -284,10 +256,10 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes (* We get the identifiers of this branch *) let pre_args = List.fold_right - (fun (_,pat) acc -> + (fun {CAst.v=pat} acc -> match pat with | IntroNaming (IntroIdentifier id) -> id::acc - | _ -> anomaly (Pp.str "Not an identifier") + | _ -> anomaly (Pp.str "Not an identifier.") ) (List.nth intro_pats (pred i)) [] @@ -304,17 +276,18 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes List.fold_right (fun hid acc -> let type_of_hid = pf_unsafe_type_of g (mkVar hid) in - match kind_of_term type_of_hid with + let sigma = project g in + match EConstr.kind sigma type_of_hid with | Prod(_,_,t') -> begin - match kind_of_term t' with + match EConstr.kind sigma t' with | Prod(_,t'',t''') -> begin - match kind_of_term t'',kind_of_term t''' with + match EConstr.kind sigma t'',EConstr.kind sigma t''' with | App(eq,args), App(graph',_) when - (eq_constr eq eq_ind) && - Array.exists (Constr.eq_constr_nounivs graph') graphs_constr -> + (EConstr.eq_constr sigma eq eq_ind) && + Array.exists (EConstr.eq_constr_nounivs sigma graph') graphs_constr -> (args.(2)::(mkApp(mkVar hid,[|args.(2);(mkApp(eq_construct,[|args.(0);args.(2)|]))|])) ::acc) | _ -> mkVar hid :: acc @@ -360,7 +333,7 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes in (* observe (str "constructor := " ++ Printer.pr_lconstr_env (pf_env g) app_constructor); *) ( - tclTHENSEQ + tclTHENLIST [ observe_tac("h_intro_patterns ") (let l = (List.nth intro_pats (pred i)) in match l with @@ -379,7 +352,7 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes Locusops.onConcl); observe_tac ("toto ") tclIDTAC; - (* introducing the the result of the graph and the equality hypothesis *) + (* introducing the result of the graph and the equality hypothesis *) observe_tac "introducing" (tclMAP (fun x -> Proofview.V82.of_tactic (Simple.intro x)) [res;hres]); (* replacing [res] with its value *) observe_tac "rewriting res value" (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar hres))); @@ -395,11 +368,11 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes Array.map (fun ((_,(ctxt,concl))) -> match ctxt with - | [] | [_] | [_;_] -> anomaly (Pp.str "bad context") + | [] | [_] | [_;_] -> anomaly (Pp.str "bad context.") | hres::res::decl::ctxt -> - let res = Termops.it_mkLambda_or_LetIn - (Termops.it_mkProd_or_LetIn concl [hres;res]) - (LocalAssum (get_name decl, get_type decl) :: ctxt) + let res = EConstr.it_mkLambda_or_LetIn + (EConstr.it_mkProd_or_LetIn concl [hres;res]) + (LocalAssum (RelDecl.get_name decl, RelDecl.get_type decl) :: ctxt) in res ) @@ -415,7 +388,7 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes let params_bindings,avoid = List.fold_left2 (fun (bindings,avoid) decl p -> - let id = Namegen.next_ident_away (Nameops.out_name (get_name decl)) avoid in + let id = Namegen.next_ident_away (Nameops.Name.get_id (RelDecl.get_name decl)) (Id.Set.of_list avoid) in p::bindings,id::avoid ) ([],pf_ids_of_hyps g) @@ -425,7 +398,7 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes let lemmas_bindings = List.rev (fst (List.fold_left2 (fun (bindings,avoid) decl p -> - let id = Namegen.next_ident_away (Nameops.out_name (get_name decl)) avoid in + let id = Namegen.next_ident_away (Nameops.Name.get_id (RelDecl.get_name decl)) (Id.Set.of_list avoid) in (nf_zeta p)::bindings,id::avoid) ([],avoid) princ_infos.predicates @@ -433,7 +406,7 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes in (params_bindings@lemmas_bindings) in - tclTHENSEQ + tclTHENLIST [ observe_tac "principle" (Proofview.V82.of_tactic (assert_by (Name principle_id) @@ -465,7 +438,7 @@ let generalize_dependent_of x hyp g = tclMAP (function | LocalAssum (id,t) when not (Id.equal id hyp) && - (Termops.occur_var (pf_env g) x t) -> tclTHEN (Proofview.V82.of_tactic (Tactics.generalize [mkVar id])) (thin [id]) + (Termops.occur_var (pf_env g) (project g) x t) -> tclTHEN (Proofview.V82.of_tactic (Tactics.generalize [mkVar id])) (thin [id]) | _ -> tclIDTAC ) (pf_hyps g) @@ -486,46 +459,47 @@ let tauto = let rec intros_with_rewrite g = observe_tac "intros_with_rewrite" intros_with_rewrite_aux g -and intros_with_rewrite_aux : tactic = +and intros_with_rewrite_aux : Tacmach.tactic = fun g -> let eq_ind = make_eq () in - match kind_of_term (pf_concl g) with + let sigma = project g in + match EConstr.kind sigma (pf_concl g) with | Prod(_,t,t') -> begin - match kind_of_term t with - | App(eq,args) when (eq_constr eq eq_ind) -> + match EConstr.kind sigma t with + | App(eq,args) when (EConstr.eq_constr sigma eq eq_ind) -> if Reductionops.is_conv (pf_env g) (project g) args.(1) args.(2) then let id = pf_get_new_id (Id.of_string "y") g in - tclTHENSEQ [ Proofview.V82.of_tactic (Simple.intro id); thin [id]; intros_with_rewrite ] g - else if isVar args.(1) && (Environ.evaluable_named (destVar args.(1)) (pf_env g)) - then tclTHENSEQ[ - Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(1)))]); - tclMAP (fun id -> tclTRY(Proofview.V82.of_tactic (unfold_in_hyp [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(1)))] ((destVar args.(1)),Locus.InHyp) ))) + tclTHENLIST [ Proofview.V82.of_tactic (Simple.intro id); thin [id]; intros_with_rewrite ] g + else if isVar sigma args.(1) && (Environ.evaluable_named (destVar sigma args.(1)) (pf_env g)) + then tclTHENLIST[ + Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalVarRef (destVar sigma args.(1)))]); + tclMAP (fun id -> tclTRY(Proofview.V82.of_tactic (unfold_in_hyp [(Locus.AllOccurrences, Names.EvalVarRef (destVar sigma args.(1)))] ((destVar sigma args.(1)),Locus.InHyp) ))) (pf_ids_of_hyps g); intros_with_rewrite ] g - else if isVar args.(2) && (Environ.evaluable_named (destVar args.(2)) (pf_env g)) - then tclTHENSEQ[ - Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(2)))]); - tclMAP (fun id -> tclTRY(Proofview.V82.of_tactic (unfold_in_hyp [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(2)))] ((destVar args.(2)),Locus.InHyp) ))) + else if isVar sigma args.(2) && (Environ.evaluable_named (destVar sigma args.(2)) (pf_env g)) + then tclTHENLIST[ + Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalVarRef (destVar sigma args.(2)))]); + tclMAP (fun id -> tclTRY(Proofview.V82.of_tactic (unfold_in_hyp [(Locus.AllOccurrences, Names.EvalVarRef (destVar sigma args.(2)))] ((destVar sigma args.(2)),Locus.InHyp) ))) (pf_ids_of_hyps g); intros_with_rewrite ] g - else if isVar args.(1) + else if isVar sigma args.(1) then let id = pf_get_new_id (Id.of_string "y") g in - tclTHENSEQ [ Proofview.V82.of_tactic (Simple.intro id); - generalize_dependent_of (destVar args.(1)) id; + tclTHENLIST [ Proofview.V82.of_tactic (Simple.intro id); + generalize_dependent_of (destVar sigma args.(1)) id; tclTRY (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar id))); intros_with_rewrite ] g - else if isVar args.(2) + else if isVar sigma args.(2) then let id = pf_get_new_id (Id.of_string "y") g in - tclTHENSEQ [ Proofview.V82.of_tactic (Simple.intro id); - generalize_dependent_of (destVar args.(2)) id; + tclTHENLIST [ Proofview.V82.of_tactic (Simple.intro id); + generalize_dependent_of (destVar sigma args.(2)) id; tclTRY (Proofview.V82.of_tactic (Equality.rewriteRL (mkVar id))); intros_with_rewrite ] @@ -533,21 +507,21 @@ and intros_with_rewrite_aux : tactic = else begin let id = pf_get_new_id (Id.of_string "y") g in - tclTHENSEQ[ + tclTHENLIST[ Proofview.V82.of_tactic (Simple.intro id); tclTRY (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar id))); intros_with_rewrite ] g end - | Ind _ when eq_constr t (Coqlib.build_coq_False ()) -> + | Ind _ when EConstr.eq_constr sigma t (EConstr.of_constr (Universes.constr_of_global @@ Coqlib.build_coq_False ())) -> Proofview.V82.of_tactic tauto g | Case(_,_,v,_) -> - tclTHENSEQ[ + tclTHENLIST[ Proofview.V82.of_tactic (simplest_case v); intros_with_rewrite ] g | LetIn _ -> - tclTHENSEQ[ + tclTHENLIST[ Proofview.V82.of_tactic (reduce (Genredexpr.Cbv {Redops.all_flags @@ -559,10 +533,10 @@ and intros_with_rewrite_aux : tactic = ] g | _ -> let id = pf_get_new_id (Id.of_string "y") g in - tclTHENSEQ [ Proofview.V82.of_tactic (Simple.intro id);intros_with_rewrite] g + tclTHENLIST [ Proofview.V82.of_tactic (Simple.intro id);intros_with_rewrite] g end | LetIn _ -> - tclTHENSEQ[ + tclTHENLIST[ Proofview.V82.of_tactic (reduce (Genredexpr.Cbv {Redops.all_flags @@ -577,9 +551,9 @@ and intros_with_rewrite_aux : tactic = let rec reflexivity_with_destruct_cases g = let destruct_case () = try - match kind_of_term (snd (destApp (pf_concl g))).(2) with + match EConstr.kind (project g) (snd (destApp (project g) (pf_concl g))).(2) with | Case(_,_,v,_) -> - tclTHENSEQ[ + tclTHENLIST[ Proofview.V82.of_tactic (simplest_case v); Proofview.V82.of_tactic intros; observe_tac "reflexivity_with_destruct_cases" reflexivity_with_destruct_cases @@ -588,18 +562,23 @@ let rec reflexivity_with_destruct_cases g = with e when CErrors.noncritical e -> Proofview.V82.of_tactic reflexivity in let eq_ind = make_eq () in + let my_inj_flags = Some { + Equality.keep_proof_equalities = false; + injection_in_context = false; (* for compatibility, necessary *) + injection_pattern_l2r_order = false; (* probably does not matter; except maybe with dependent hyps *) + } in let discr_inject = Tacticals.onAllHypsAndConcl ( fun sc g -> match sc with None -> tclIDTAC g | Some id -> - match kind_of_term (pf_unsafe_type_of g (mkVar id)) with - | App(eq,[|_;t1;t2|]) when eq_constr eq eq_ind -> + match EConstr.kind (project g) (pf_unsafe_type_of g (mkVar id)) with + | App(eq,[|_;t1;t2|]) when EConstr.eq_constr (project g) eq eq_ind -> if Equality.discriminable (pf_env g) (project g) t1 t2 then Proofview.V82.of_tactic (Equality.discrHyp id) g - else if Equality.injectable (pf_env g) (project g) t1 t2 - then tclTHENSEQ [Proofview.V82.of_tactic (Equality.injHyp None id);thin [id];intros_with_rewrite] g + else if Equality.injectable (pf_env g) (project g) ~keep_proofs:None t1 t2 + then tclTHENLIST [Proofview.V82.of_tactic (Equality.injHyp my_inj_flags None id);thin [id];intros_with_rewrite] g else tclIDTAC g | _ -> tclIDTAC g ) @@ -646,25 +625,25 @@ let rec reflexivity_with_destruct_cases g = *) -let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = +let prove_fun_complete funcs graphs schemes lemmas_types_infos i : Tacmach.tactic = fun g -> (* We compute the types of the different mutually recursive lemmas in $\zeta$ normal form *) let lemmas = Array.map - (fun (_,(ctxt,concl)) -> nf_zeta (Termops.it_mkLambda_or_LetIn concl ctxt)) + (fun (_,(ctxt,concl)) -> nf_zeta (EConstr.it_mkLambda_or_LetIn concl ctxt)) lemmas_types_infos in (* We get the constant and the principle corresponding to this lemma *) let f = funcs.(i) in - let graph_principle = nf_zeta schemes.(i) in + let graph_principle = nf_zeta (EConstr.of_constr schemes.(i)) in let princ_type = pf_unsafe_type_of g graph_principle in - let princ_infos = Tactics.compute_elim_sig princ_type in + let princ_infos = Tactics.compute_elim_sig (project g) princ_type in (* Then we get the number of argument of the function and compute a fresh name for each of them *) - let nb_fun_args = nb_prod (pf_concl g) - 2 in + let nb_fun_args = nb_prod (project g) (pf_concl g) - 2 in let args_names = generate_fresh_id (Id.of_string "x") [] nb_fun_args in let ids = args_names@(pf_ids_of_hyps g) in (* and fresh names for res H and the principle (cf bug bug #1174) *) @@ -682,7 +661,7 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = (fun decl -> List.map (fun id -> id) - (generate_fresh_id (Id.of_string "y") ids (nb_prod (get_type decl))) + (generate_fresh_id (Id.of_string "y") ids (nb_prod (project g) (RelDecl.get_type decl))) ) branches in @@ -690,20 +669,20 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = using [f_equation] if it is recursive (that is the graph is infinite or unfold if the graph is finite *) - let rewrite_tac j ids : tactic = + let rewrite_tac j ids : Tacmach.tactic = let graph_def = graphs.(j) in let infos = - try find_Function_infos (fst (destConst funcs.(j))) - with Not_found -> error "No graph found" + try find_Function_infos (fst (destConst (project g) funcs.(j))) + with Not_found -> user_err Pp.(str "No graph found") in if infos.is_general || Rtree.is_infinite Declareops.eq_recarg graph_def.mind_recargs then let eq_lemma = try Option.get (infos).equation_lemma - with Option.IsNone -> anomaly (Pp.str "Cannot find equation lemma") + with Option.IsNone -> anomaly (Pp.str "Cannot find equation lemma.") in - tclTHENSEQ[ + tclTHENLIST[ tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) ids; Proofview.V82.of_tactic (Equality.rewriteLR (mkConst eq_lemma)); (* Don't forget to $\zeta$ normlize the term since the principles @@ -719,7 +698,7 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = thin ids ] else - Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalConstRef (fst (destConst f)))]) + Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalConstRef (fst (destConst (project g) f)))]) in (* The proof of each branche itself *) let ind_number = ref 0 in @@ -739,7 +718,7 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = end in let this_branche_ids = List.nth intro_pats (pred i) in - tclTHENSEQ[ + tclTHENLIST[ (* we expand the definition of the function *) observe_tac "rewrite_tac" (rewrite_tac this_ind_number this_branche_ids); (* introduce hypothesis with some rewrite *) @@ -750,8 +729,9 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = g in let params_names = fst (List.chop princ_infos.nparams args_names) in + let open EConstr in let params = List.map mkVar params_names in - tclTHENSEQ + tclTHENLIST [ tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) (args_names@[res;hres]); observe_tac "h_generalize" (Proofview.V82.of_tactic (generalize [mkApp(applist(graph_principle,params),Array.map (fun c -> applist(c,params)) lemmas)])); @@ -763,19 +743,20 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = g -(* [derive_correctness make_scheme functional_induction funs graphs] create correctness and completeness +(* [derive_correctness make_scheme funs graphs] create correctness and completeness lemmas for each function in [funs] w.r.t. [graphs] [make_scheme] is Functional_principle_types.make_scheme (dependency pb) and - [functional_induction] is Indfun.functional_induction (same pb) *) -let derive_correctness make_scheme functional_induction (funs: pconstant list) (graphs:inductive list) = +let derive_correctness make_scheme (funs: pconstant list) (graphs:inductive list) = assert (funs <> []); assert (graphs <> []); let funs = Array.of_list funs and graphs = Array.of_list graphs in - let funs_constr = Array.map mkConstU funs in - States.with_state_protection_on_exception + let map (c, u) = mkConstU (c, EInstance.make u) in + let funs_constr = Array.map map funs in + (* XXX STATE Why do we need this... why is the toplevel protection not enought *) + funind_purify (fun () -> let env = Global.env () in let evd = ref (Evd.from_env env) in @@ -789,10 +770,10 @@ let derive_correctness make_scheme functional_induction (funs: pconstant list) ( in let type_info = (type_of_lemma_ctxt,type_of_lemma_concl) in graphs_constr.(i) <- graph; - let type_of_lemma = Termops.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt in + let type_of_lemma = EConstr.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt in let _ = Typing.e_type_of (Global.env ()) evd type_of_lemma in let type_of_lemma = nf_zeta type_of_lemma in - observe (str "type_of_lemma := " ++ Printer.pr_lconstr_env (Global.env ()) !evd type_of_lemma); + observe (str "type_of_lemma := " ++ Printer.pr_leconstr_env (Global.env ()) !evd type_of_lemma); type_of_lemma,type_info ) funs_constr @@ -811,18 +792,18 @@ let derive_correctness make_scheme functional_induction (funs: pconstant list) ( Array.of_list (List.map (fun entry -> - (fst (fst(Future.force entry.Entries.const_entry_body)), Option.get entry.Entries.const_entry_type ) + (EConstr.of_constr (fst (fst(Future.force entry.Entries.const_entry_body))), EConstr.of_constr (Option.get entry.Entries.const_entry_type )) ) - (make_scheme evd (Array.map_to_list (fun const -> const,GType []) funs)) + (make_scheme evd (Array.map_to_list (fun const -> const,Sorts.InType) funs)) ) ) in let proving_tac = - prove_fun_correct !evd functional_induction funs_constr graphs_constr schemes lemmas_types_infos + prove_fun_correct !evd funs_constr graphs_constr schemes lemmas_types_infos in Array.iteri (fun i f_as_constant -> - let f_id = Label.to_id (con_label (fst f_as_constant)) in + let f_id = Label.to_id (Constant.label (fst f_as_constant)) in (*i The next call to mk_correct_id is valid since we are constructing the lemma Ensures by: obvious i*) @@ -842,7 +823,8 @@ let derive_correctness make_scheme functional_induction (funs: pconstant list) ( (* let lem_cst = fst (destConst (Constrintern.global_reference lem_id)) in *) let _,lem_cst_constr = Evd.fresh_global (Global.env ()) !evd (Constrintern.locate_reference (Libnames.qualid_of_ident lem_id)) in - let (lem_cst,_) = destConst lem_cst_constr in + let lem_cst_constr = EConstr.of_constr lem_cst_constr in + let (lem_cst,_) = destConst !evd lem_cst_constr in update_Function {finfo with correctness_lemma = Some lem_cst}; ) @@ -856,23 +838,23 @@ let derive_correctness make_scheme functional_induction (funs: pconstant list) ( let type_info = (type_of_lemma_ctxt,type_of_lemma_concl) in graphs_constr.(i) <- graph; let type_of_lemma = - Termops.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt + EConstr.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt in let type_of_lemma = nf_zeta type_of_lemma in - observe (str "type_of_lemma := " ++ Printer.pr_lconstr type_of_lemma); + observe (str "type_of_lemma := " ++ Printer.pr_leconstr_env env !evd type_of_lemma); type_of_lemma,type_info ) funs_constr graphs_constr in - let (kn,_) as graph_ind,u = (destInd graphs_constr.(0)) in + let (kn,_) as graph_ind,u = (destInd !evd graphs_constr.(0)) in let mib,mip = Global.lookup_inductive graph_ind in let sigma, scheme = (Indrec.build_mutual_induction_scheme (Global.env ()) !evd (Array.to_list (Array.mapi - (fun i _ -> ((kn,i),u(* Univ.Instance.empty *)),true,InType) + (fun i _ -> ((kn,i), EInstance.kind !evd u),true,InType) mib.Declarations.mind_packets ) ) @@ -886,7 +868,7 @@ let derive_correctness make_scheme functional_induction (funs: pconstant list) ( in Array.iteri (fun i f_as_constant -> - let f_id = Label.to_id (con_label (fst f_as_constant)) in + let f_id = Label.to_id (Constant.label (fst f_as_constant)) in (*i The next call to mk_complete_id is valid since we are constructing the lemma Ensures by: obvious i*) @@ -902,7 +884,8 @@ let derive_correctness make_scheme functional_induction (funs: pconstant list) ( let finfo = find_Function_infos (fst f_as_constant) in let _,lem_cst_constr = Evd.fresh_global (Global.env ()) !evd (Constrintern.locate_reference (Libnames.qualid_of_ident lem_id)) in - let (lem_cst,_) = destConst lem_cst_constr in + let lem_cst_constr = EConstr.of_constr lem_cst_constr in + let (lem_cst,_) = destConst !evd lem_cst_constr in update_Function {finfo with completeness_lemma = Some lem_cst} ) funs) @@ -917,16 +900,17 @@ let derive_correctness make_scheme functional_induction (funs: pconstant list) ( if the type of hypothesis has not this form or if we cannot find the completeness lemma then we do nothing *) let revert_graph kn post_tac hid g = + let sigma = project g in let typ = pf_unsafe_type_of g (mkVar hid) in - match kind_of_term typ with - | App(i,args) when isInd i -> - let ((kn',num) as ind'),u = destInd i in + match EConstr.kind sigma typ with + | App(i,args) when isInd sigma i -> + let ((kn',num) as ind'),u = destInd sigma 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 = try find_Function_of_graph ind' with Not_found -> (* The graphs are mutually recursive but we cannot find one of them !*) - anomaly (Pp.str "Cannot retrieve infos about a mutual block") + anomaly (Pp.str "Cannot retrieve infos about a mutual block.") in (* if we can find a completeness lemma for this function then we can come back to the functional form. If not, we do nothing @@ -935,7 +919,7 @@ let revert_graph kn post_tac hid g = | None -> tclIDTAC g | Some f_complete -> let f_args,res = Array.chop (Array.length args - 1) args in - tclTHENSEQ + tclTHENLIST [ Proofview.V82.of_tactic (generalize [applist(mkConst f_complete,(Array.to_list f_args)@[res.(0);mkVar hid])]); thin [hid]; @@ -965,21 +949,22 @@ let revert_graph kn post_tac hid g = \end{enumerate} *) -let functional_inversion kn hid fconst f_correct : tactic = +let functional_inversion kn hid fconst f_correct : Tacmach.tactic = fun g -> let old_ids = List.fold_right Id.Set.add (pf_ids_of_hyps g) Id.Set.empty in + let sigma = project g in let type_of_h = pf_unsafe_type_of g (mkVar hid) in - match kind_of_term type_of_h with - | App(eq,args) when eq_constr eq (make_eq ()) -> + match EConstr.kind sigma type_of_h with + | App(eq,args) when EConstr.eq_constr sigma 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 -> + match EConstr.kind sigma args.(1),EConstr.kind sigma args.(2) with + | App(f,f_args),_ when EConstr.eq_constr sigma f fconst -> ((fun hid -> Proofview.V82.of_tactic (intros_symmetry (Locusops.onHyp hid))),f_args,args.(2)) - |_,App(f,f_args) when eq_constr f fconst -> + |_,App(f,f_args) when EConstr.eq_constr sigma f fconst -> ((fun hid -> tclIDTAC),f_args,args.(1)) | _ -> (fun hid -> tclFAIL 1 (mt ())),[||],args.(2) in - tclTHENSEQ[ + tclTHENLIST [ pre_tac hid; Proofview.V82.of_tactic (generalize [applist(f_correct,(Array.to_list f_args)@[res;mkVar hid])]); thin [hid]; @@ -993,12 +978,13 @@ let functional_inversion kn hid fconst f_correct : tactic = | _ -> tclFAIL 1 (mt ()) g +let error msg = user_err Pp.(str msg) let invfun qhyp f = let f = match f with | ConstRef f -> f - | _ -> raise (CErrors.UserError("",str "Not a function")) + | _ -> raise (CErrors.UserError(None,str "Not a function")) in try let finfos = find_Function_infos f in @@ -1012,7 +998,7 @@ let invfun qhyp f = | Not_found -> error "No graph found" | Option.IsNone -> error "Cannot use equivalence with graph!" - +exception NoFunction let invfun qhyp f g = match f with | Some f -> invfun qhyp f g @@ -1020,42 +1006,43 @@ let invfun qhyp f g = Proofview.V82.of_tactic begin Tactics.try_intros_until (fun hid -> Proofview.V82.tactic begin fun g -> + let sigma = project g in let hyp_typ = pf_unsafe_type_of g (mkVar hid) in - match kind_of_term hyp_typ with - | App(eq,args) when eq_constr eq (make_eq ()) -> + match EConstr.kind sigma hyp_typ with + | App(eq,args) when EConstr.eq_constr sigma eq (make_eq ()) -> begin - let f1,_ = decompose_app args.(1) in + let f1,_ = decompose_app sigma args.(1) in try - if not (isConst f1) then failwith ""; - let finfos = find_Function_infos (fst (destConst f1)) in + if not (isConst sigma f1) then raise NoFunction; + let finfos = find_Function_infos (fst (destConst sigma f1)) in let f_correct = mkConst(Option.get finfos.correctness_lemma) and kn = fst finfos.graph_ind in functional_inversion kn hid f1 f_correct g - with | Failure "" | Option.IsNone | Not_found -> + with | NoFunction | Option.IsNone | Not_found -> try - let f2,_ = decompose_app args.(2) in - if not (isConst f2) then failwith ""; - let finfos = find_Function_infos (fst (destConst f2)) in + let f2,_ = decompose_app sigma args.(2) in + if not (isConst sigma f2) then raise NoFunction; + let finfos = find_Function_infos (fst (destConst sigma f2)) in let f_correct = mkConst(Option.get finfos.correctness_lemma) and kn = fst finfos.graph_ind in functional_inversion kn hid f2 f_correct g with - | Failure "" -> - errorlabstrm "" (str "Hypothesis " ++ Ppconstr.pr_id hid ++ str " must contain at least one Function") + | NoFunction -> + user_err (str "Hypothesis " ++ Ppconstr.pr_id hid ++ str " must contain at least one Function") | Option.IsNone -> if do_observe () then error "Cannot use equivalence with graph for any side of the equality" - else errorlabstrm "" (str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid) + else user_err (str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid) | Not_found -> if do_observe () then error "No graph found for any side of equality" - else errorlabstrm "" (str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid) + else user_err (str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid) end - | _ -> errorlabstrm "" (Ppconstr.pr_id hid ++ str " must be an equality ") + | _ -> user_err (Ppconstr.pr_id hid ++ str " must be an equality ") end) qhyp end diff --git a/plugins/funind/invfun.mli b/plugins/funind/invfun.mli new file mode 100644 index 00000000..ad306ab2 --- /dev/null +++ b/plugins/funind/invfun.mli @@ -0,0 +1,19 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +val invfun : + Misctypes.quantified_hypothesis -> + Globnames.global_reference option -> + Evar.t Evd.sigma -> Evar.t list Evd.sigma +val derive_correctness : + (Evd.evar_map ref -> + (Constr.pconstant * Sorts.family) list -> + 'a Entries.definition_entry list) -> + Constr.pconstant list -> Names.inductive list -> unit diff --git a/plugins/funind/merge.ml b/plugins/funind/merge.ml deleted file mode 100644 index de4210af..00000000 --- a/plugins/funind/merge.ml +++ /dev/null @@ -1,1009 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* Merging of induction principles. *) - -open Globnames -open Tactics -open Indfun_common -open CErrors -open Util -open Constrexpr -open Vernacexpr -open Pp -open Names -open Term -open Vars -open Termops -open Declarations -open Glob_term -open Glob_termops -open Decl_kinds -open Context.Rel.Declaration - -(** {1 Utilities} *) - -(** {2 Useful operations on constr and glob_constr} *) - -let rec popn i c = if i<=0 then c else pop (popn (i-1) c) - -(** Substitutions in constr *) -let compare_constr_nosub t1 t2 = - if compare_constr (fun _ _ -> false) t1 t2 - then true - else false - -let rec compare_constr' t1 t2 = - if compare_constr_nosub t1 t2 - then true - else (compare_constr (compare_constr') t1 t2) - -let rec substitterm prof t by_t in_u = - if (compare_constr' (lift prof t) in_u) - then (lift prof by_t) - else map_constr_with_binders succ - (fun i -> substitterm i t by_t) prof in_u - -let lift_ldecl n ldecl = List.map (fun (x,y) -> x,lift n y) ldecl - -let understand = Pretyping.understand (Global.env()) Evd.empty - -(** Operations on names and identifiers *) -let id_of_name = function - Anonymous -> Id.of_string "H" - | Name id -> id;; -let name_of_string str = Name (Id.of_string str) -let string_of_name nme = Id.to_string (id_of_name nme) - -(** [isVarf f x] returns [true] if term [x] is of the form [(Var f)]. *) -let isVarf f x = - match x with - | GVar (_,x) -> Id.equal x f - | _ -> false - -(** [ident_global_exist id] returns true if identifier [id] is linked - in global environment. *) -let ident_global_exist id = - try - let ans = CRef (Libnames.Ident (Loc.ghost,id), None) in - let _ = ignore (Constrintern.intern_constr (Global.env()) ans) in - true - with e when CErrors.noncritical e -> false - -(** [next_ident_fresh id] returns a fresh identifier (ie not linked in - global env) with base [id]. *) -let next_ident_fresh (id:Id.t) = - let res = ref id in - while ident_global_exist !res do res := Nameops.lift_subscript !res done; - !res - - -(** {2 Debugging} *) -(* comment this line to see debug msgs *) -let msg x = () ;; let pr_lconstr c = str "" -(* uncomment this to see debugging *) -let prconstr c = msg (str" " ++ Printer.pr_lconstr c) -let prconstrnl c = msg (str" " ++ Printer.pr_lconstr c ++ str"\n") -let prlistconstr lc = List.iter prconstr lc -let prstr s = msg(str s) -let prNamedConstr s c = - begin - msg(str ""); - msg(str(s^" {§ ") ++ Printer.pr_lconstr c ++ str " §} "); - msg(str ""); - end -let prNamedRConstr s c = - begin - msg(str ""); - msg(str(s^" {§ ") ++ Printer.pr_glob_constr c ++ str " §} "); - msg(str ""); - end -let prNamedLConstr_aux lc = List.iter (prNamedConstr "\n") lc -let prNamedLConstr s lc = - begin - prstr "[§§§ "; - prstr s; - prNamedLConstr_aux lc; - prstr " §§§]\n"; - end -let prNamedLDecl s lc = - begin - prstr s; prstr "\n"; - List.iter (fun (nm,_,tp) -> prNamedConstr (string_of_name nm) tp) lc; - prstr "\n"; - end -let prNamedRLDecl s lc = - begin - prstr s; prstr "\n"; prstr "{§§ "; - List.iter - (fun x -> - match x with - | (nm,None,Some tp) -> prNamedRConstr (string_of_name nm) tp - | (nm,Some bdy,None) -> prNamedRConstr ("(letin) "^string_of_name nm) bdy - | _ -> assert false - ) lc; - prstr " §§}\n"; - prstr "\n"; - end - -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()) (fst ind1) in - List.iter (fun decl -> - print_string (string_of_name (Context.Rel.Declaration.get_name decl) ^ ":"); - prconstr (get_type decl); print_string "\n") - ib1.mind_arity_ctxt; - Printf.printf "arity :"; prconstr (Inductiveops.type_of_inductive (Global.env ()) ind1); - Array.iteri - (fun i x -> Printf.printf"type constr %d :" i ; prconstr x) - ib1.mind_user_lc - -(** {2 Misc} *) - -exception Found of int - -(* Array scanning *) - -let array_prfx (arr: 'a array) (pred: int -> 'a -> bool): int = -match Array.findi pred arr with -| None -> Array.length arr (* all elt are positive *) -| Some i -> i - -(* Like List.chop but except that [i] is the size of the suffix of [l]. *) -let list_chop_end i l = - let size_prefix = List.length l -i in - if size_prefix < 0 then failwith "list_chop_end" - else List.chop size_prefix l - -let list_fold_lefti (f: int -> 'a -> 'b -> 'a) (acc:'a) (arr:'b list): 'a = - let i = ref 0 in - List.fold_left - (fun acc x -> - let res = f !i acc x in i := !i + 1; res) - acc arr - -let list_filteri (f: int -> 'a -> bool) (l:'a list):'a list = - let i = ref 0 in - List.filter (fun x -> let res = f !i x in i := !i + 1; res) l - - -(** Iteration module *) -module For = -struct - let rec map i j (f: int -> 'a) = if i>j then [] else f i :: (map (i+1) j f) - let rec foldup i j (f: 'a -> int -> 'a) acc = - if i>j then acc else let newacc = f acc i in foldup (i+1) j f newacc - let rec folddown i j (f: 'a -> int -> 'a) acc = - if i>j then acc else let newacc = f acc j in folddown i (j-1) f newacc - let fold i j = if i<j then foldup i j else folddown i j -end - - -(** {1 Parameters shifting and linking information} *) - -(** This type is used to deal with debruijn linked indices. When a - variable is linked to a previous one, we will ignore it and refer - to previous one. *) -type linked_var = - | Linked of int - | Unlinked - | Funres - -(** When merging two graphs, parameters may become regular arguments, - and thus be shifted. This type describes the result of computing - the changes. *) -type 'a shifted_params = - { - nprm1:'a; - nprm2:'a; - prm2_unlinked:'a list; (* ranks of unlinked params in nprms2 *) - nuprm1:'a; - nuprm2:'a; - nargs1:'a; - nargs2:'a; - } - - -let prlinked x = - match x with - | Linked i -> Printf.sprintf "Linked %d" i - | Unlinked -> Printf.sprintf "Unlinked" - | Funres -> Printf.sprintf "Funres" - -let linkmonad f lnkvar = - match lnkvar with - | Linked i -> Linked (f i) - | Unlinked -> Unlinked - | Funres -> Funres - -let linklift lnkvar i = linkmonad (fun x -> x+i) lnkvar - -(* This map is used to deal with debruijn linked indices. *) -module Link = Map.Make (Int) - -let pr_links l = - Printf.printf "links:\n"; - Link.iter (fun k e -> Printf.printf "%d : %s\n" k (prlinked e)) l; - Printf.printf "_____________\n" - -type 'a merged_arg = - | Prm_stable of 'a - | Prm_linked of 'a - | Prm_arg of 'a - | Arg_stable of 'a - | Arg_linked of 'a - | Arg_funres - -(** Information about graph merging of two inductives. - All rel_decl list are IN REVERSE ORDER (ie well suited for compose) *) - -type merge_infos = - { - ident:Id.t; (** new inductive name *) - mib1: mutual_inductive_body; - oib1: one_inductive_body; - mib2: mutual_inductive_body; - oib2: one_inductive_body; - - (** Array of links of the first inductive (should be all stable) *) - lnk1: int merged_arg array; - - (** Array of links of the second inductive (point to the first ind param/args) *) - lnk2: int merged_arg array; - - (** rec params which remain rec param (ie not linked) *) - recprms1: Context.Rel.Declaration.t list; - recprms2: Context.Rel.Declaration.t list; - nrecprms1: int; - nrecprms2: int; - - (** rec parms which became non parm (either linked to something - or because after a rec parm that became non parm) *) - otherprms1: Context.Rel.Declaration.t list; - otherprms2: Context.Rel.Declaration.t list; - notherprms1:int; - notherprms2:int; - - (** args which remain args in merge *) - args1:Context.Rel.Declaration.t list; - args2:Context.Rel.Declaration.t list; - nargs1:int; - nargs2:int; - - (** functional result args *) - funresprms1: Context.Rel.Declaration.t list; - funresprms2: Context.Rel.Declaration.t list; - nfunresprms1:int; - nfunresprms2:int; - } - - -let pr_merginfo x = - let i,s= - match x with - | Prm_linked i -> Some i,"Prm_linked" - | Arg_linked i -> Some i,"Arg_linked" - | Prm_stable i -> Some i,"Prm_stable" - | Prm_arg i -> Some i,"Prm_arg" - | Arg_stable i -> Some i,"Arg_stable" - | Arg_funres -> None , "Arg_funres" in - match i with - | Some i -> Printf.sprintf "%s(%d)" s i - | None -> Printf.sprintf "%s" s - -let isPrm_stable x = match x with Prm_stable _ -> true | _ -> false - -(* ?? prm_linked?? *) -let isArg_stable x = match x with Arg_stable _ | Prm_arg _ -> true | _ -> false - -let is_stable x = - match x with Arg_stable _ | Prm_stable _ | Prm_arg _ -> true | _ -> false - -let isArg_funres x = match x with Arg_funres -> true | _ -> false - -let filter_shift_stable (lnk:int merged_arg array) (l:'a list): 'a list = - let prms = list_filteri (fun i _ -> isPrm_stable lnk.(i)) l in - let args = list_filteri (fun i _ -> isArg_stable lnk.(i)) l in - let fres = list_filteri (fun i _ -> isArg_funres lnk.(i)) l in - prms@args@fres - -(** Reverse the link map, keeping only linked vars, elements are list - of int as several vars may be linked to the same var. *) -let revlinked lnk = - For.fold 0 (Array.length lnk - 1) - (fun acc k -> - match lnk.(k) with - | Unlinked | Funres -> acc - | Linked i -> - let old = try Link.find i acc with Not_found -> [] in - Link.add i (k::old) acc) - Link.empty - -let array_switch arr i j = - let aux = arr.(j) in arr.(j) <- arr.(i); arr.(i) <- aux - -let filter_shift_stable_right (lnk:int merged_arg array) (l:'a list): 'a list = - let larr = Array.of_list l in - let _ = - Array.iteri - (fun j x -> - match x with - | Prm_linked i -> array_switch larr i j - | Arg_linked i -> array_switch larr i j - | Prm_stable i -> () - | Prm_arg i -> () - | Arg_stable i -> () - | Arg_funres -> () - ) lnk in - filter_shift_stable lnk (Array.to_list larr) - - - - -(** {1 Utilities for merging} *) - -let ind1name = Id.of_string "__ind1" -let ind2name = Id.of_string "__ind2" - -(** Performs verifications on two graphs before merging: they must not - be co-inductive, and for the moment they must not be mutual - either. *) -let verify_inds mib1 mib2 = - if mib1.mind_finite == Decl_kinds.CoFinite then error "First argument is coinductive"; - if mib2.mind_finite == Decl_kinds.CoFinite then error "Second argument is coinductive"; - if not (Int.equal mib1.mind_ntypes 1) then error "First argument is mutual"; - if not (Int.equal mib2.mind_ntypes 1) then error "Second argument is mutual"; - () - -(* -(** [build_raw_params prms_decl avoid] returns a list of variables - attributed to the list of decl [prms_decl], avoiding names in - [avoid]. *) -let build_raw_params prms_decl avoid = - let dummy_constr = compose_prod (List.map (fun (x,_,z) -> x,z) prms_decl) (mkRel 1) in - let _ = prNamedConstr "DUMMY" dummy_constr in - let dummy_glob_constr = Detyping.detype false avoid [] dummy_constr in - let _ = prNamedRConstr "RAWDUMMY" dummy_glob_constr in - let res,_ = glob_decompose_prod dummy_glob_constr in - let comblist = List.combine prms_decl res in - comblist, res , (avoid @ (Id.Set.elements (ids_of_glob_constr dummy_glob_constr))) -*) - -let ids_of_rawlist avoid rawl = - List.fold_left Id.Set.union avoid (List.map ids_of_glob_constr rawl) - - - -(** {1 Merging function graphs} *) - -(** [shift_linked_params mib1 mib2 lnk] Computes which parameters (rec - uniform and ordinary ones) of mutual inductives [mib1] and [mib2] - remain uniform when linked by [lnk]. All parameters are - considered, ie we take parameters of the first inductive body of - [mib1] and [mib2]. - - Explanation: The two inductives have parameters, some of the first - are recursively uniform, some of the last are functional result of - the functional graph. - - (I x1 x2 ... xk ... xk' ... xn) - (J y1 y2 ... xl ... yl' ... ym) - - Problem is, if some rec unif params are linked to non rec unif - ones, they become non rec (and the following too). And functinal - argument have to be shifted at the end *) -let shift_linked_params mib1 mib2 (lnk1:linked_var array) (lnk2:linked_var array) id = - let _ = prstr "\nYOUHOU shift\n" in - let linked_targets = revlinked lnk2 in - let is_param_of_mib1 x = x < mib1.mind_nparams_rec in - let is_param_of_mib2 x = x < mib2.mind_nparams_rec in - let is_targetted_by_non_recparam_lnk1 i = - try - let targets = Link.find i linked_targets in - List.exists (fun x -> not (is_param_of_mib2 x)) targets - with Not_found -> false in - let mlnk1 = - Array.mapi - (fun i lkv -> - let isprm = is_param_of_mib1 i in - let prmlost = is_targetted_by_non_recparam_lnk1 i in - match isprm , prmlost, lnk1.(i) with - | true , true , _ -> Prm_arg i (* recparam becoming ordinary *) - | true , false , _-> Prm_stable i (* recparam remains recparam*) - | false , false , Funres -> Arg_funres - | _ , _ , Funres -> assert false (* fun res cannot be a rec param or lost *) - | false , _ , _ -> Arg_stable i) (* Args of lnk1 are not linked *) - lnk1 in - let mlnk2 = - Array.mapi - (fun i lkv -> - (* Is this correct if some param of ind2 is lost? *) - let isprm = is_param_of_mib2 i in - match isprm , lnk2.(i) with - | true , Linked j when not (is_param_of_mib1 j) -> - Prm_arg j (* recparam becoming ordinary *) - | true , Linked j -> Prm_linked j (*recparam linked to recparam*) - | true , Unlinked -> Prm_stable i (* recparam remains recparam*) - | false , Linked j -> Arg_linked j (* Args of lnk2 lost *) - | false , Unlinked -> Arg_stable i (* Args of lnk2 remains *) - | false , Funres -> Arg_funres - | true , Funres -> assert false (* fun res cannot be a rec param *) - ) - lnk2 in - let oib1 = mib1.mind_packets.(0) in - let oib2 = mib2.mind_packets.(0) in - (* count params remaining params *) - let n_params1 = array_prfx mlnk1 (fun i x -> not (isPrm_stable x)) in - let n_params2 = array_prfx mlnk2 (fun i x -> not (isPrm_stable x)) in - let bldprms arity_ctxt mlnk = - list_fold_lefti - (fun i (acc1,acc2,acc3,acc4) x -> - prstr (pr_merginfo mlnk.(i));prstr "\n"; - match mlnk.(i) with - | Prm_stable _ -> x::acc1 , acc2 , acc3, acc4 - | Prm_arg _ -> acc1 , x::acc2 , acc3, acc4 - | Arg_stable _ -> acc1 , acc2 , x::acc3, acc4 - | Arg_funres -> acc1 , acc2 , acc3, x::acc4 - | _ -> acc1 , acc2 , acc3, acc4) - ([],[],[],[]) arity_ctxt in -(* let arity_ctxt2 = - build_raw_params oib2.mind_arity_ctxt - (Id.Set.elements (ids_of_glob_constr oib1.mind_arity_ctxt)) in*) - let recprms1,otherprms1,args1,funresprms1 = bldprms (List.rev oib1.mind_arity_ctxt) mlnk1 in - let _ = prstr "\n\n\n" in - let recprms2,otherprms2,args2,funresprms2 = bldprms (List.rev oib2.mind_arity_ctxt) mlnk2 in - let _ = prstr "\notherprms1:\n" in - let _ = - List.iter (fun decl -> prstr (string_of_name (get_name decl) ^ " : "); - prconstr (get_type decl); prstr "\n") - otherprms1 in - let _ = prstr "\notherprms2:\n" in - let _ = - List.iter (fun decl -> prstr (string_of_name (get_name decl) ^ " : "); prconstr (get_type decl); prstr "\n") - otherprms2 in - { - ident=id; - mib1=mib1; - oib1 = oib1; - mib2=mib2; - oib2 = oib2; - lnk1 = mlnk1; - lnk2 = mlnk2; - nrecprms1 = n_params1; - recprms1 = recprms1; - otherprms1 = otherprms1; - args1 = args1; - funresprms1 = funresprms1; - notherprms1 = Array.length mlnk1 - n_params1; - nfunresprms1 = List.length funresprms1; - nargs1 = List.length args1; - nrecprms2 = n_params2; - recprms2 = recprms2; - otherprms2 = otherprms2; - args2 = args2; - funresprms2 = funresprms2; - notherprms2 = Array.length mlnk2 - n_params2; - nargs2 = List.length args2; - nfunresprms2 = List.length funresprms2; - } - - - - -(** {1 Merging functions} *) - -exception NoMerge - -let rec merge_app c1 c2 id1 id2 shift filter_shift_stable = - let lnk = Array.append shift.lnk1 shift.lnk2 in - match c1 , c2 with - | GApp(_,f1, arr1), GApp(_,f2,arr2) when isVarf id1 f1 && isVarf id2 f2 -> - let _ = prstr "\nICI1!\n" in - let args = filter_shift_stable lnk (arr1 @ arr2) in - GApp (Loc.ghost,GVar (Loc.ghost,shift.ident) , args) - | GApp(_,f1, arr1), GApp(_,f2,arr2) -> raise NoMerge - | GLetIn(_,nme,bdy,trm) , _ -> - let _ = prstr "\nICI2!\n" in - let newtrm = merge_app trm c2 id1 id2 shift filter_shift_stable in - GLetIn(Loc.ghost,nme,bdy,newtrm) - | _, GLetIn(_,nme,bdy,trm) -> - let _ = prstr "\nICI3!\n" in - let newtrm = merge_app c1 trm id1 id2 shift filter_shift_stable in - GLetIn(Loc.ghost,nme,bdy,newtrm) - | _ -> let _ = prstr "\nICI4!\n" in - raise NoMerge - -let rec merge_app_unsafe c1 c2 shift filter_shift_stable = - let lnk = Array.append shift.lnk1 shift.lnk2 in - match c1 , c2 with - | GApp(_,f1, arr1), GApp(_,f2,arr2) -> - let args = filter_shift_stable lnk (arr1 @ arr2) in - GApp (Loc.ghost,GVar(Loc.ghost,shift.ident) , args) - (* FIXME: what if the function appears in the body of the let? *) - | GLetIn(_,nme,bdy,trm) , _ -> - let _ = prstr "\nICI2 '!\n" in - let newtrm = merge_app_unsafe trm c2 shift filter_shift_stable in - GLetIn(Loc.ghost,nme,bdy,newtrm) - | _, GLetIn(_,nme,bdy,trm) -> - let _ = prstr "\nICI3 '!\n" in - let newtrm = merge_app_unsafe c1 trm shift filter_shift_stable in - GLetIn(Loc.ghost,nme,bdy,newtrm) - | _ -> let _ = prstr "\nICI4 '!\n" in raise NoMerge - - - -(* Heuristic when merging two lists of hypothesis: merge every rec - calls of branch 1 with all rec calls of branch 2. *) -(* TODO: reecrire cette heuristique (jusqu'a merge_types) *) -let rec merge_rec_hyps shift accrec - (ltyp:(Name.t * glob_constr option * glob_constr option) list) - filter_shift_stable : (Name.t * glob_constr option * glob_constr option) list = - let mergeonehyp t reldecl = - match reldecl with - | (nme,x,Some (GApp(_,i,args) as ind)) - -> nme,x, Some (merge_app_unsafe ind t shift filter_shift_stable) - | (nme,Some _,None) -> error "letins with recursive calls not treated yet" - | (nme,None,Some _) -> assert false - | (nme,None,None) | (nme,Some _,Some _) -> assert false in - match ltyp with - | [] -> [] - | (nme,None,Some (GApp(_,f, largs) as t)) :: lt when isVarf ind2name f -> - let rechyps = List.map (mergeonehyp t) accrec in - rechyps @ merge_rec_hyps shift accrec lt filter_shift_stable - | e::lt -> e :: merge_rec_hyps shift accrec lt filter_shift_stable - - -let build_suppl_reccall (accrec:(Name.t * glob_constr) list) concl2 shift = - List.map (fun (nm,tp) -> (nm,merge_app_unsafe tp concl2 shift)) accrec - - -let find_app (nme:Id.t) ltyp = - try - ignore - (List.map - (fun x -> - match x with - | _,None,Some (GApp(_,f,_)) when isVarf nme f -> raise (Found 0) - | _ -> ()) - ltyp); - false - with Found _ -> true - -let prnt_prod_or_letin nm letbdy typ = - match letbdy , typ with - | Some lbdy , None -> prNamedRConstr ("(letin) " ^ string_of_name nm) lbdy - | None , Some tp -> prNamedRConstr (string_of_name nm) tp - | _ , _ -> assert false - - -let rec merge_types shift accrec1 - (ltyp1:(Name.t * glob_constr option * glob_constr option) list) - (concl1:glob_constr) (ltyp2:(Name.t * glob_constr option * glob_constr option) list) concl2 - : (Name.t * glob_constr option * glob_constr option) list * glob_constr = - let _ = prstr "MERGE_TYPES\n" in - let _ = prstr "ltyp 1 : " in - let _ = List.iter (fun (nm,lbdy,tp) -> prnt_prod_or_letin nm lbdy tp) ltyp1 in - let _ = prstr "\nltyp 2 : " in - let _ = List.iter (fun (nm,lbdy,tp) -> prnt_prod_or_letin nm lbdy tp) ltyp2 in - let _ = prstr "\n" in - let res = - match ltyp1 with - | [] -> - let isrec1 = not (List.is_empty accrec1) in - let isrec2 = find_app ind2name ltyp2 in - let rechyps = - if isrec1 && isrec2 - then (* merge_rec_hyps shift accrec1 ltyp2 filter_shift_stable *) - merge_rec_hyps shift [name_of_string "concl1",None,Some concl1] ltyp2 - filter_shift_stable_right - @ merge_rec_hyps shift accrec1 [name_of_string "concl2",None, Some concl2] - filter_shift_stable - else if isrec1 - (* if rec calls in accrec1 and not in ltyp2, add one to ltyp2 *) - then - merge_rec_hyps shift accrec1 - (ltyp2@[name_of_string "concl2",None,Some concl2]) filter_shift_stable - else if isrec2 - then merge_rec_hyps shift [name_of_string "concl1",None,Some concl1] ltyp2 - filter_shift_stable_right - else ltyp2 in - let _ = prstr"\nrechyps : " in - let _ = List.iter(fun (nm,lbdy,tp)-> prnt_prod_or_letin nm lbdy tp) rechyps in - let _ = prstr "MERGE CONCL : " in - let _ = prNamedRConstr "concl1" concl1 in - let _ = prstr " with " in - let _ = prNamedRConstr "concl2" concl2 in - let _ = prstr "\n" in - let concl = - merge_app concl1 concl2 ind1name ind2name shift filter_shift_stable in - let _ = prstr "FIN " in - let _ = prNamedRConstr "concl" concl in - let _ = prstr "\n" in - - rechyps , concl - | (nme,None, Some t1)as e ::lt1 -> - (match t1 with - | GApp(_,f,carr) when isVarf ind1name f -> - merge_types shift (e::accrec1) lt1 concl1 ltyp2 concl2 - | _ -> - let recres, recconcl2 = - merge_types shift accrec1 lt1 concl1 ltyp2 concl2 in - ((nme,None,Some t1) :: recres) , recconcl2) - | (nme,Some bd, None) ::lt1 -> - (* FIXME: what if ind1name appears in bd? *) - let recres, recconcl2 = - merge_types shift accrec1 lt1 concl1 ltyp2 concl2 in - ((nme,Some bd,None) :: recres) , recconcl2 - | (_,None,None)::_ | (_,Some _,Some _)::_ -> assert false - in - res - - -(** [build_link_map_aux allargs1 allargs2 shift] returns the mapping of - linked args [allargs2] to target args of [allargs1] as specified - in [shift]. [allargs1] and [allargs2] are in reverse order. Also - returns the list of unlinked vars of [allargs2]. *) -let build_link_map_aux (allargs1:Id.t array) (allargs2:Id.t array) - (lnk:int merged_arg array) = - Array.fold_left_i - (fun i acc e -> - if Int.equal i (Array.length lnk - 1) then acc (* functional arg, not in allargs *) - else - match e with - | Prm_linked j | Arg_linked j -> Id.Map.add allargs2.(i) allargs1.(j) acc - | _ -> acc) - Id.Map.empty lnk - -let build_link_map allargs1 allargs2 lnk = - let allargs1 = - Array.of_list (List.rev_map (fun (x,_,_) -> id_of_name x) allargs1) in - let allargs2 = - Array.of_list (List.rev_map (fun (x,_,_) -> id_of_name x) allargs2) in - build_link_map_aux allargs1 allargs2 lnk - - -(** [merge_one_constructor lnk shift typcstr1 typcstr2] merges the two - constructor rawtypes [typcstr1] and [typcstr2]. [typcstr1] and - [typcstr2] contain all parameters (including rec. unif. ones) of - their inductive. - - if [typcstr1] and [typcstr2] are of the form: - - forall recparams1, forall ordparams1, H1a -> H2a... (I1 x1 y1 ... z1) - forall recparams2, forall ordparams2, H2b -> H2b... (I2 x2 y2 ... z2) - - we build: - - forall recparams1 (recparams2 without linked params), - forall ordparams1 (ordparams2 without linked params), - H1a' -> H2a' -> ... -> H2a' -> H2b'(shifted) -> ... - -> (newI x1 ... z1 x2 y2 ...z2 without linked params) - - where Hix' have been adapted, ie: - - linked vars have been changed, - - rec calls to I1 and I2 have been replaced by rec calls to - newI. More precisely calls to I1 and I2 have been merge by an - experimental heuristic (in particular if n o rec calls for I1 - or I2 is found, we use the conclusion as a rec call). See - [merge_types] above. - - Precond: vars sets of [typcstr1] and [typcstr2] must be disjoint. - - TODO: return nothing if equalities (after linking) are contradictory. *) -let merge_one_constructor (shift:merge_infos) (typcstr1:glob_constr) - (typcstr2:glob_constr) : glob_constr = - (* FIXME: les noms des parametres corerspondent en principe au - parametres du niveau mib, mais il faudrait s'en assurer *) - (* shift.nfunresprmsx last args are functional result *) - let nargs1 = - shift.mib1.mind_nparams + shift.oib1.mind_nrealargs - shift.nfunresprms1 in - let nargs2 = - shift.mib2.mind_nparams + shift.oib2.mind_nrealargs - shift.nfunresprms2 in - let allargs1,rest1 = glob_decompose_prod_or_letin_n nargs1 typcstr1 in - let allargs2,rest2 = glob_decompose_prod_or_letin_n nargs2 typcstr2 in - (* Build map of linked args of [typcstr2], and apply it to [typcstr2]. *) - let linked_map = build_link_map allargs1 allargs2 shift.lnk2 in - let rest2 = change_vars linked_map rest2 in - let hyps1,concl1 = glob_decompose_prod_or_letin rest1 in - let hyps2,concl2' = glob_decompose_prod_or_letin rest2 in - let ltyp,concl2 = - merge_types shift [] (List.rev hyps1) concl1 (List.rev hyps2) concl2' in - let _ = prNamedRLDecl "ltyp result:" ltyp in - let typ = glob_compose_prod_or_letin concl2 (List.rev ltyp) in - let revargs1 = - list_filteri (fun i _ -> isArg_stable shift.lnk1.(i)) (List.rev allargs1) in - let _ = prNamedRLDecl "ltyp allargs1" allargs1 in - let _ = prNamedRLDecl "ltyp revargs1" revargs1 in - let revargs2 = - list_filteri (fun i _ -> isArg_stable shift.lnk2.(i)) (List.rev allargs2) in - let _ = prNamedRLDecl "ltyp allargs2" allargs2 in - let _ = prNamedRLDecl "ltyp revargs2" revargs2 in - let typwithprms = - glob_compose_prod_or_letin typ (List.rev revargs2 @ List.rev revargs1) in - typwithprms - - -(** constructor numbering *) -let fresh_cstror_suffix , cstror_suffix_init = - let cstror_num = ref 0 in - (fun () -> - let res = string_of_int !cstror_num in - cstror_num := !cstror_num + 1; - res) , - (fun () -> cstror_num := 0) - -(** [merge_constructor_id id1 id2 shift] returns the identifier of the - new constructor from the id of the two merged constructor and - the merging info. *) -let merge_constructor_id id1 id2 shift:Id.t = - let id = Id.to_string shift.ident ^ "_" ^ fresh_cstror_suffix () in - next_ident_fresh (Id.of_string id) - - - -(** [merge_constructors lnk shift avoid] merges the two list of - constructor [(name*type)]. These are translated to glob_constr - first, each of them having distinct var names. *) -let merge_constructors (shift:merge_infos) (avoid:Id.Set.t) - (typcstr1:(Id.t * glob_constr) list) - (typcstr2:(Id.t * glob_constr) list) : (Id.t * glob_constr) list = - List.flatten - (List.map - (fun (id1,rawtyp1) -> - List.map - (fun (id2,rawtyp2) -> - let typ = merge_one_constructor shift rawtyp1 rawtyp2 in - let newcstror_id = merge_constructor_id id1 id2 shift in - let _ = prstr "\n**************\n" in - newcstror_id , typ) - typcstr2) - typcstr1) - -(** [merge_inductive_body lnk shift avoid oib1 oib2] merges two - inductive bodies [oib1] and [oib2], linking with [lnk], params - info in [shift], avoiding identifiers in [avoid]. *) -let merge_inductive_body (shift:merge_infos) avoid (oib1:one_inductive_body) - (oib2:one_inductive_body) = - (* building glob_constr type of constructors *) - let mkrawcor nme avoid typ = - (* first replace rel 1 by a varname *) - let substindtyp = substitterm 0 (mkRel 1) (mkVar nme) typ in - Detyping.detype false (Id.Set.elements avoid) (Global.env()) Evd.empty substindtyp in - let lcstr1: glob_constr list = - Array.to_list (Array.map (mkrawcor ind1name avoid) oib1.mind_user_lc) in - (* add to avoid all indentifiers of lcstr1 *) - let avoid2 = Id.Set.union avoid (ids_of_rawlist avoid lcstr1) in - let lcstr2 = - Array.to_list (Array.map (mkrawcor ind2name avoid2) oib2.mind_user_lc) in - let avoid3 = Id.Set.union avoid (ids_of_rawlist avoid lcstr2) in - - let params1 = - try fst (glob_decompose_prod_n shift.nrecprms1 (List.hd lcstr1)) - with e when CErrors.noncritical e -> [] in - let params2 = - try fst (glob_decompose_prod_n shift.nrecprms2 (List.hd lcstr2)) - with e when CErrors.noncritical e -> [] in - - let lcstr1 = List.combine (Array.to_list oib1.mind_consnames) lcstr1 in - let lcstr2 = List.combine (Array.to_list oib2.mind_consnames) lcstr2 in - - cstror_suffix_init(); - params1,params2,merge_constructors shift avoid3 lcstr1 lcstr2 - - -(** [merge_mutual_inductive_body lnk mib1 mib2 shift] merge mutual - inductive bodies [mib1] and [mib2] linking vars with - [lnk]. [shift] information on parameters of the new inductive. - For the moment, inductives are supposed to be non mutual. -*) -let merge_mutual_inductive_body - (mib1:mutual_inductive_body) (mib2:mutual_inductive_body) (shift:merge_infos) = - (* Mutual not treated, we take first ind body of each. *) - merge_inductive_body shift Id.Set.empty mib1.mind_packets.(0) mib2.mind_packets.(0) - - -let glob_constr_to_constr_expr x = (* build a constr_expr from a glob_constr *) - Flags.with_option Flags.raw_print (Constrextern.extern_glob_type Id.Set.empty) x - -let merge_rec_params_and_arity prms1 prms2 shift (concl:constr) = - let params = prms2 @ prms1 in - let resparams = - List.fold_left - (fun acc (nme,tp) -> - let _ = prstr "param :" in - let _ = prNamedRConstr (string_of_name nme) tp in - let _ = prstr " ; " in - let typ = glob_constr_to_constr_expr tp in - LocalRawAssum ([(Loc.ghost,nme)], Constrexpr_ops.default_binder_kind, typ) :: acc) - [] params in - let concl = Constrextern.extern_constr false (Global.env()) Evd.empty concl in - let arity,_ = - List.fold_left - (fun (acc,env) decl -> - let nm = Context.Rel.Declaration.get_name decl in - let c = get_type decl in - let typ = Constrextern.extern_constr false env Evd.empty c in - let newenv = Environ.push_rel (LocalAssum (nm,c)) env in - CProdN (Loc.ghost, [[(Loc.ghost,nm)],Constrexpr_ops.default_binder_kind,typ] , acc) , newenv) - (concl,Global.env()) - (shift.funresprms2 @ shift.funresprms1 - @ shift.args2 @ shift.args1 @ shift.otherprms2 @ shift.otherprms1) in - resparams,arity - - - -(** [glob_constr_list_to_inductive_expr ident rawlist] returns the - induct_expr corresponding to the the list of constructor types - [rawlist], named ident. - FIXME: params et cstr_expr (arity) *) -let glob_constr_list_to_inductive_expr prms1 prms2 mib1 mib2 shift - (rawlist:(Id.t * glob_constr) list) = - let lident = (Loc.ghost, shift.ident), None in - let bindlist , cstr_expr = (* params , arities *) - merge_rec_params_and_arity prms1 prms2 shift mkSet in - let lcstor_expr : (bool * (lident * constr_expr)) list = - List.map (* zeta_normalize t ? *) - (fun (id,t) -> false, ((Loc.ghost,id),glob_constr_to_constr_expr t)) - rawlist in - lident , bindlist , Some cstr_expr , lcstor_expr - - -let mkProd_reldecl (rdecl:Context.Rel.Declaration.t) (t2:glob_constr) = - match rdecl with - | LocalAssum (nme,t) -> - let traw = Detyping.detype false [] (Global.env()) Evd.empty t in - GProd (Loc.ghost,nme,Explicit,traw,t2) - | LocalDef _ -> assert false - - -(** [merge_inductive ind1 ind2 lnk] merges two graphs, linking - variables specified in [lnk]. Graphs are not supposed to be mutual - inductives for the moment. *) -let merge_inductive (ind1: inductive) (ind2: inductive) - (lnk1: linked_var array) (lnk2: linked_var array) id = - let env = Global.env() in - let mib1,_ = Inductive.lookup_mind_specif env ind1 in - let mib2,_ = Inductive.lookup_mind_specif env ind2 in - let _ = verify_inds mib1 mib2 in (* raises an exception if something wrong *) - (* compute params that become ordinary args (because linked to ord. args) *) - let shift_prm = shift_linked_params mib1 mib2 lnk1 lnk2 id in - let prms1,prms2, rawlist = merge_mutual_inductive_body mib1 mib2 shift_prm in - let _ = prstr "\nrawlist : " in - let _ = - List.iter (fun (nm,tp) -> prNamedRConstr (Id.to_string nm) tp;prstr "\n") rawlist in - let _ = prstr "\nend rawlist\n" in -(* FIX: retransformer en constr ici - let shift_prm = - { shift_prm with - recprms1=prms1; - recprms1=prms1; - } in *) - 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,pl,impls = Command.interp_mutual_inductive indl [] - false (*FIXMEnon-poly *) false (* means not private *) Decl_kinds.Finite (* means: not coinductive *) in - (* Declare the mutual inductive block with its associated schemes *) - ignore (Command.declare_mutual_inductive_with_eliminations mie pl impls) - - -(* Find infos on identifier id. *) -let find_Function_infos_safe (id:Id.t): Indfun_common.function_info = - let kn_of_id x = - let f_ref = Libnames.Ident (Loc.ghost,x) in - locate_with_msg (str "Don't know what to do with " ++ Libnames.pr_reference f_ref) - locate_constant f_ref in - try find_Function_infos (kn_of_id id) - with Not_found -> - errorlabstrm "indfun" (Nameops.pr_id id ++ str " has no functional scheme") - -(** [merge id1 id2 args1 args2 id] builds and declares a new inductive - type called [id], representing the merged graphs of both graphs - [ind1] and [ind2]. identifiers occurring in both arrays [args1] and - [args2] are considered linked (i.e. are the same variable) in the - new graph. - - Warning: For the moment, repetitions of an id in [args1] or - [args2] are not supported. *) -let merge (id1:Id.t) (id2:Id.t) (args1:Id.t array) - (args2:Id.t array) id : unit = - let finfo1 = find_Function_infos_safe id1 in - let finfo2 = find_Function_infos_safe id2 in - (* FIXME? args1 are supposed unlinked. mergescheme (G x x) ?? *) - (* We add one arg (functional arg of the graph) *) - let lnk1 = Array.make (Array.length args1 + 1) Unlinked in - let lnk2' = (* args2 may be linked to args1 members. FIXME: same - as above: vars may be linked inside args2?? *) - Array.mapi - (fun i c -> - match Array.findi (fun i x -> Id.equal x c) args1 with - | Some j -> Linked j - | None -> Unlinked) - args2 in - (* We add one arg (functional arg of the graph) *) - let lnk2 = Array.append lnk2' (Array.make 1 Unlinked) in - (* setting functional results *) - let _ = lnk1.(Array.length lnk1 - 1) <- Funres in - let _ = lnk2.(Array.length lnk2 - 1) <- Funres in - merge_inductive finfo1.graph_ind finfo2.graph_ind lnk1 lnk2 id - - -let remove_last_arg c = - let (x,y) = decompose_prod c in - let xnolast = List.rev (List.tl (List.rev x)) in - compose_prod xnolast y - -let rec remove_n_fst_list n l = if Int.equal n 0 then l else remove_n_fst_list (n-1) (List.tl l) -let remove_n_last_list n l = List.rev (remove_n_fst_list n (List.rev l)) - -let remove_last_n_arg n c = - let (x,y) = decompose_prod c in - let xnolast = remove_n_last_list n x in - compose_prod xnolast y - -(* [funify_branches relinfo nfuns branch] returns the branch [branch] - of the relinfo [relinfo] modified to fit in a functional principle. - Things to do: - - remove indargs from rel applications - - replace *variables only* corresponding to function (recursive) - results by the actual function application. *) -let funify_branches relinfo nfuns branch = - let mut_induct, induct = - match relinfo.indref with - | None -> assert false - | Some (IndRef ((mutual_ind,i) as ind)) -> mutual_ind,ind - | _ -> assert false in - let is_dom c = - match kind_of_term c with - | Ind(((u,_),_)) | Construct(((u,_),_),_) -> MutInd.equal u mut_induct - | _ -> false in - let _dom_i c = - assert (is_dom c); - match kind_of_term c with - | Ind((u,i)) | Construct((u,_),i) -> i - | _ -> assert false in - let _is_pred c shift = - match kind_of_term c with - | Rel i -> let reali = i-shift in (reali>=0 && reali<relinfo.nbranches) - | _ -> false in - (* FIXME: *) - LocalDef (Anonymous,mkProp,mkProp) - - -let relprinctype_to_funprinctype relprinctype nfuns = - let relinfo = compute_elim_sig relprinctype in - assert (not relinfo.farg_in_concl); - assert (relinfo.indarg_in_concl); - (* first remove indarg and indarg_in_concl *) - let relinfo_noindarg = { relinfo with - indarg_in_concl = false; indarg = None; - concl = remove_last_arg (pop relinfo.concl); } in - (* the nfuns last induction arguments are functional ones: remove them *) - let relinfo_argsok = { relinfo_noindarg with - nargs = relinfo_noindarg.nargs - nfuns; - (* args is in reverse order, so remove fst *) - args = remove_n_fst_list nfuns relinfo_noindarg.args; - concl = popn nfuns relinfo_noindarg.concl - } in - let new_branches = - List.map (funify_branches relinfo_argsok nfuns) relinfo_argsok.branches in - let relinfo_branches = { relinfo_argsok with branches = new_branches } in - relinfo_branches - -(* @article{ bundy93rippling, - author = "Alan Bundy and Andrew Stevens and Frank van Harmelen and Andrew Ireland and Alan Smaill", - title = "Rippling: A Heuristic for Guiding Inductive Proofs", - journal = "Artificial Intelligence", - volume = "62", - number = "2", - pages = "185-253", - year = "1993", - url = "citeseer.ist.psu.edu/bundy93rippling.html" } - - *) diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index fa84e4dd..fb9ae64b 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -1,12 +1,18 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Term + +module CVars = Vars + +open Constr +open EConstr open Vars open Namegen open Environ @@ -25,7 +31,7 @@ open Nametab open Declare open Decl_kinds open Tacred -open Proof_type +open Goal open Pfedit open Glob_term open Pretyping @@ -39,56 +45,63 @@ open Auto open Eauto open Indfun_common -open Sigma.Notations open Context.Rel.Declaration - (* Ugly things which should not be here *) -let coq_constant m s = - Coqlib.coq_constant "RecursiveDefinition" m s +let coq_constant m s = EConstr.of_constr @@ Universes.constr_of_global @@ + Coqlib.coq_reference "RecursiveDefinition" m s let arith_Nat = ["Arith";"PeanoNat";"Nat"] let arith_Lt = ["Arith";"Lt"] +let pr_leconstr_rd = + let sigma, env = Pfedit.get_current_context () in + Printer.pr_leconstr_env env sigma + let coq_init_constant s = - Coqlib.gen_constant_in_modules "RecursiveDefinition" Coqlib.init_modules s + EConstr.of_constr ( + Universes.constr_of_global @@ + Coqlib.gen_reference_in_modules "RecursiveDefinition" Coqlib.init_modules s) 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 f_id kind ?(ctx=Univ.UContext.empty) value = - let ce = definition_entry ~univs:ctx value (*FIXME *) in +let declare_fun f_id kind ?univs value = + let ce = definition_entry ?univs value (*FIXME *) in ConstRef(declare_constant f_id (DefinitionEntry ce, kind));; let defined () = Lemmas.save_proof (Vernacexpr.(Proved (Transparent,None))) let def_of_const t = - match (kind_of_term t) with + match (Constr.kind t) with Const sp -> (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 (fst sp))))) + (Id.print (Label.to_id (Constant.label (fst sp)))) ++ str ".") ) |_ -> assert false -let type_of_const t = - match (kind_of_term t) with - Const sp -> Typeops.type_of_constant (Global.env()) sp +let type_of_const sigma t = + match (EConstr.kind sigma t) with + | Const (sp, u) -> + let u = EInstance.kind sigma u in + (* FIXME discarding universe constraints *) + Typeops.type_of_constant_in (Global.env()) (sp, u) |_ -> assert false let constr_of_global x = - fst (Universes.unsafe_constr_of_global x) + fst (Global.constr_of_global_in_context (Global.env ()) x) let constant sl s = constr_of_global (find_reference sl s) let const_of_ref = function ConstRef kn -> kn - | _ -> anomaly (Pp.str "ConstRef expected") + | _ -> anomaly (Pp.str "ConstRef expected.") let nf_zeta env = @@ -98,9 +111,7 @@ let nf_zeta env = let nf_betaiotazeta = (* Reductionops.local_strong Reductionops.whd_betaiotazeta *) - let clos_norm_flags flgs env sigma t = - CClosure.norm_val (CClosure.create_clos_infos flgs env) (CClosure.inject (Reductionops.nf_evar sigma t)) in - clos_norm_flags CClosure.betaiotazeta Environ.empty_env Evd.empty + Reductionops.clos_norm_flags CClosure.betaiotazeta Environ.empty_env Evd.empty @@ -110,13 +121,17 @@ let nf_betaiotazeta = (* Reductionops.local_strong Reductionops.whd_betaiotazeta (* Generic values *) let pf_get_new_ids idl g = let ids = pf_ids_of_hyps g in + let ids = Id.Set.of_list ids in List.fold_right - (fun id acc -> next_global_ident_away id (acc@ids)::acc) + (fun id acc -> next_global_ident_away id (Id.Set.union (Id.Set.of_list acc) ids)::acc) idl [] +let next_ident_away_in_goal ids avoid = + next_ident_away_in_goal ids (Id.Set.of_list avoid) + let compute_renamed_type gls c = - rename_bound_vars_as_displayed (*no avoid*) [] (*no rels*) [] + rename_bound_vars_as_displayed (project gls) (*no avoid*) Id.Set.empty (*no rels*) [] (pf_unsafe_type_of gls c) let h'_id = Id.of_string "h'" let teq_id = Id.of_string "teq" @@ -128,13 +143,13 @@ let def_id = Id.of_string "def" let p_id = Id.of_string "p" let rec_res_id = Id.of_string "rec_res";; let lt = function () -> (coq_init_constant "lt") -let le = function () -> (coq_init_constant "le") +let le = function () -> (Coqlib.gen_reference_in_modules "RecursiveDefinition" Coqlib.init_modules "le") let ex = function () -> (coq_init_constant "ex") let nat = function () -> (coq_init_constant "nat") let iter_ref () = try find_reference ["Recdef"] "iter" - with Not_found -> error "module Recdef not loaded" -let iter = function () -> (constr_of_global (delayed_force iter_ref)) + with Not_found -> user_err Pp.(str "module Recdef not loaded") +let iter_rd = function () -> (constr_of_global (delayed_force iter_ref)) let eq = function () -> (coq_init_constant "eq") let le_lt_SS = function () -> (constant ["Recdef"] "le_lt_SS") let le_lt_n_Sm = function () -> (coq_constant arith_Lt "le_lt_n_Sm") @@ -147,7 +162,7 @@ let coq_O = function () -> (coq_init_constant "O") let coq_S = function () -> (coq_init_constant "S") let lt_n_O = function () -> (coq_constant arith_Nat "nlt_0_r") let max_ref = function () -> (find_reference ["Recdef"] "max") -let max_constr = function () -> (constr_of_global (delayed_force max_ref)) +let max_constr = function () -> EConstr.of_constr (constr_of_global (delayed_force max_ref)) let coq_conj = function () -> find_reference Coqlib.logic_module_name "conj" let f_S t = mkApp(delayed_force coq_S, [|t|]);; @@ -166,9 +181,10 @@ let simpl_iter clause = clause (* Others ugly things ... *) -let (value_f:constr list -> global_reference -> constr) = +let (value_f: Constr.t list -> global_reference -> Constr.t) = + let open Term in + let open Constr in fun al fterm -> - let d0 = Loc.ghost in let rev_x_id_l = ( List.fold_left @@ -185,21 +201,21 @@ let (value_f:constr list -> global_reference -> constr) = in let env = Environ.push_rel_context context (Global.env ()) in let glob_body = - GCases - (d0,RegularStyle,None, - [GApp(d0, GRef(d0,fterm,None), List.rev_map (fun x_id -> GVar(d0, x_id)) rev_x_id_l), + DAst.make @@ + GCases + (RegularStyle,None, + [DAst.make @@ GApp(DAst.make @@ GRef(fterm,None), List.rev_map (fun x_id -> DAst.make @@ GVar x_id) rev_x_id_l), (Anonymous,None)], - [d0, [v_id], [PatCstr(d0,(destIndRef - (delayed_force coq_sig_ref),1), - [PatVar(d0, Name v_id); - PatVar(d0, Anonymous)], - Anonymous)], - GVar(d0,v_id)]) + [CAst.make ([v_id], [DAst.make @@ PatCstr ((destIndRef (delayed_force coq_sig_ref),1), + [DAst.make @@ PatVar(Name v_id); DAst.make @@ PatVar Anonymous], + Anonymous)], + DAst.make @@ GVar v_id)]) in let body = fst (understand env (Evd.from_env env) glob_body)(*FIXME*) in + let body = EConstr.Unsafe.to_constr body in it_mkLambda_or_LetIn body context -let (declare_f : Id.t -> logical_kind -> constr list -> global_reference -> global_reference) = +let (declare_f : Id.t -> logical_kind -> Constr.t list -> global_reference -> global_reference) = fun f_id kind input_type fterm_ref -> declare_fun f_id kind (value_f input_type fterm_ref);; @@ -301,14 +317,14 @@ let tclUSER_if_not_mes concl_tac is_mes names_to_suppress = (* [check_not_nested forbidden e] checks that [e] does not contains any variable of [forbidden] *) -let check_not_nested forbidden e = +let check_not_nested sigma forbidden e = let rec check_not_nested e = - match kind_of_term e with + match EConstr.kind sigma e with | Rel _ -> () | Var x -> if Id.List.mem x forbidden - then errorlabstrm "Recdef.check_not_nested" - (str "check_not_nested: failure " ++ pr_id x) + then user_err ~hdr:"Recdef.check_not_nested" + (str "check_not_nested: failure " ++ Id.print x) | Meta _ | Evar _ | Sort _ -> () | Cast(e,_,t) -> check_not_nested e;check_not_nested t | Prod(_,t,b) -> check_not_nested t;check_not_nested b @@ -321,13 +337,14 @@ let check_not_nested forbidden e = | Construct _ -> () | Case(_,t,e,a) -> check_not_nested t;check_not_nested e;Array.iter check_not_nested a - | Fix _ -> error "check_not_nested : Fix" - | CoFix _ -> error "check_not_nested : Fix" + | Fix _ -> user_err Pp.(str "check_not_nested : Fix") + | CoFix _ -> user_err Pp.(str "check_not_nested : Fix") in try check_not_nested e with UserError(_,p) -> - errorlabstrm "_" (str "on expr : " ++ Printer.pr_lconstr e ++ str " " ++ p) + let _, env = Pfedit.get_current_context () in + user_err ~hdr:"_" (str "on expr : " ++ Printer.pr_leconstr_env env sigma e ++ str " " ++ p) (* ['a info] contains the local information for traveling *) type 'a infos = @@ -374,15 +391,17 @@ type journey_info = -let rec add_vars forbidden e = - match kind_of_term e with +let add_vars sigma forbidden e = + let rec aux forbidden e = + match EConstr.kind sigma e with | Var x -> x::forbidden - | _ -> fold_constr add_vars forbidden e - + | _ -> EConstr.fold sigma aux forbidden e + in + aux forbidden e let treat_case forbid_new_ids to_intros finalize_tac nb_lam e infos : tactic = fun g -> - let rev_context,b = decompose_lam_n nb_lam e in + let rev_context,b = decompose_lam_n (project g) nb_lam e in let ids = List.fold_left (fun acc (na,_) -> let pre_id = match na with @@ -404,17 +423,17 @@ let treat_case forbid_new_ids to_intros finalize_tac nb_lam e infos : tactic = (fun g' -> let ty_teq = pf_unsafe_type_of g' (mkVar heq) in let teq_lhs,teq_rhs = - let _,args = try destApp ty_teq with DestKO -> assert false in + let _,args = try destApp (project g') ty_teq with DestKO -> assert false in args.(1),args.(2) in - let new_b' = Termops.replace_term teq_lhs teq_rhs new_b in + let new_b' = Termops.replace_term (project g') teq_lhs teq_rhs new_b in let new_infos = { infos with info = new_b'; eqs = heq::infos.eqs; forbidden_ids = if forbid_new_ids - then add_vars infos.forbidden_ids new_b' + then add_vars (project g') infos.forbidden_ids new_b' else infos.forbidden_ids } in finalize_tac new_infos g' @@ -423,34 +442,35 @@ let treat_case forbid_new_ids to_intros finalize_tac nb_lam e infos : tactic = ) ] g -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" +let rec travel_aux jinfo continuation_tac (expr_info:constr infos) g = + let sigma = project g in + match EConstr.kind sigma expr_info.info with + | CoFix _ | Fix _ -> user_err Pp.(str "Function cannot treat local fixpoint or cofixpoint") + | Proj _ -> user_err Pp.(str "Function cannot treat projections") | LetIn(na,b,t,e) -> begin let new_continuation_tac = jinfo.letiN (na,b,t,e) expr_info continuation_tac in travel jinfo new_continuation_tac - {expr_info with info = b; is_final=false} + {expr_info with info = b; is_final=false} g end - | Rel _ -> anomaly (Pp.str "Free var in goal conclusion !") + | Rel _ -> anomaly (Pp.str "Free var in goal conclusion!") | Prod _ -> begin try - check_not_nested (expr_info.f_id::expr_info.forbidden_ids) expr_info.info; - jinfo.otherS () expr_info continuation_tac expr_info + check_not_nested sigma (expr_info.f_id::expr_info.forbidden_ids) expr_info.info; + jinfo.otherS () expr_info continuation_tac expr_info g with e when CErrors.noncritical e -> - errorlabstrm "Recdef.travel" (str "the term " ++ Printer.pr_lconstr expr_info.info ++ str " can not contain a recursive call to " ++ pr_id expr_info.f_id) + user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_leconstr_env (pf_env g) sigma expr_info.info ++ str " can not contain a recursive call to " ++ Id.print expr_info.f_id) end | Lambda(n,t,b) -> begin try - check_not_nested (expr_info.f_id::expr_info.forbidden_ids) expr_info.info; - jinfo.otherS () expr_info continuation_tac expr_info + check_not_nested sigma (expr_info.f_id::expr_info.forbidden_ids) expr_info.info; + jinfo.otherS () expr_info continuation_tac expr_info g with e when CErrors.noncritical e -> - errorlabstrm "Recdef.travel" (str "the term " ++ Printer.pr_lconstr expr_info.info ++ str " can not contain a recursive call to " ++ pr_id expr_info.f_id) + user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_leconstr_env (pf_env g) sigma expr_info.info ++ str " can not contain a recursive call to " ++ Id.print expr_info.f_id) end | Case(ci,t,a,l) -> begin @@ -461,15 +481,15 @@ let rec travel_aux jinfo continuation_tac (expr_info:constr infos) = travel jinfo continuation_tac_a {expr_info with info = a; is_main_branch = false; - is_final = false} + is_final = false} g end | App _ -> - let f,args = decompose_app expr_info.info in - if eq_constr f (expr_info.f_constr) - then jinfo.app_reC (f,args) expr_info continuation_tac expr_info + let f,args = decompose_app sigma expr_info.info in + if EConstr.eq_constr sigma f (expr_info.f_constr) + then jinfo.app_reC (f,args) expr_info continuation_tac expr_info g else begin - match kind_of_term f with + match EConstr.kind sigma f with | App _ -> assert false (* f is coming from a decompose_app *) | Const _ | Construct _ | Rel _ | Evar _ | Meta _ | Ind _ | Sort _ | Prod _ | Var _ -> @@ -477,15 +497,15 @@ let rec travel_aux jinfo continuation_tac (expr_info:constr infos) = let new_continuation_tac = jinfo.apP (f,args) expr_info continuation_tac in travel_args jinfo - expr_info.is_main_branch new_continuation_tac new_infos - | Case _ -> errorlabstrm "Recdef.travel" (str "the term " ++ Printer.pr_lconstr expr_info.info ++ str " can not contain an applied match (See Limitation in Section 2.3 of refman)") - | _ -> anomaly (Pp.str "travel_aux : unexpected "++ Printer.pr_lconstr expr_info.info) + expr_info.is_main_branch new_continuation_tac new_infos g + | Case _ -> user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_leconstr_env (pf_env g) sigma expr_info.info ++ str " can not contain an applied match (See Limitation in Section 2.3 of refman)") + | _ -> anomaly (Pp.str "travel_aux : unexpected "++ Printer.pr_leconstr_env (pf_env g) sigma expr_info.info ++ Pp.str ".") end - | Cast(t,_,_) -> travel jinfo continuation_tac {expr_info with info=t} + | Cast(t,_,_) -> travel jinfo continuation_tac {expr_info with info=t} g | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ -> let new_continuation_tac = jinfo.otherS () expr_info continuation_tac in - new_continuation_tac expr_info + new_continuation_tac expr_info g and travel_args jinfo is_final continuation_tac infos = let (f_args',args) = infos.info in match args with @@ -502,27 +522,28 @@ and travel_args jinfo is_final continuation_tac infos = {infos with info=arg;is_final=false} and travel jinfo continuation_tac expr_info = observe_tac - (str jinfo.message ++ Printer.pr_lconstr expr_info.info) + (str jinfo.message ++ pr_leconstr_rd expr_info.info) (travel_aux jinfo continuation_tac expr_info) (* Termination proof *) let rec prove_lt hyple g = + let sigma = project g in begin try - let (varx,varz) = match decompose_app (pf_concl g) with - | _, x::z::_ when isVar x && isVar z -> x, z + let (varx,varz) = match decompose_app sigma (pf_concl g) with + | _, x::z::_ when isVar sigma x && isVar sigma z -> x, z | _ -> assert false in let h = List.find (fun id -> - match decompose_app (pf_unsafe_type_of g (mkVar id)) with - | _, t::_ -> eq_constr t varx + match decompose_app sigma (pf_unsafe_type_of g (mkVar id)) with + | _, t::_ -> EConstr.eq_constr sigma t varx | _ -> false ) hyple in let y = - List.hd (List.tl (snd (decompose_app (pf_unsafe_type_of g (mkVar h))))) in + List.hd (List.tl (snd (decompose_app sigma (pf_unsafe_type_of g (mkVar h))))) in observe_tclTHENLIST (str "prove_lt1")[ Proofview.V82.of_tactic (apply (mkApp(le_lt_trans (),[|varx;y;varz;mkVar h|]))); observe_tac (str "prove_lt") (prove_lt hyple) @@ -638,12 +659,13 @@ let terminate_others _ expr_info continuation_tac infos = ] else continuation_tac infos -let terminate_letin (na,b,t,e) expr_info continuation_tac info = +let terminate_letin (na,b,t,e) expr_info continuation_tac info g = + let sigma = project g in let new_e = subst1 info.info e in let new_forbidden = let forbid = try - check_not_nested (expr_info.f_id::expr_info.forbidden_ids) b; + check_not_nested sigma (expr_info.f_id::expr_info.forbidden_ids) b; true with e when CErrors.noncritical e -> false in @@ -654,7 +676,7 @@ let terminate_letin (na,b,t,e) expr_info continuation_tac info = | Name id -> id::info.forbidden_ids else info.forbidden_ids in - continuation_tac {info with info = new_e; forbidden_ids = new_forbidden} + continuation_tac {info with info = new_e; forbidden_ids = new_forbidden} g let pf_type c tac gl = let evars, ty = Typing.type_of (pf_env gl) (project gl) c in @@ -673,7 +695,7 @@ let pf_typel l tac = introduced back later; the result is the pair of the tactic and the list of hypotheses that have been generalized and cleared. *) let mkDestructEq : - Id.t list -> constr -> goal sigma -> tactic * Id.t list = + Id.t list -> constr -> goal Evd.sigma -> tactic * Id.t list = fun not_on_hyp expr g -> let hyps = pf_hyps g in let to_revert = @@ -681,7 +703,7 @@ let mkDestructEq : (fun decl -> let open Context.Named.Declaration in let id = get_id decl in - if Id.List.mem id not_on_hyp || not (Termops.occur_term expr (get_type decl)) + if Id.List.mem id not_on_hyp || not (Termops.dependent (project g) expr (get_type decl)) then None else Some id) hyps in let to_revert_constr = List.rev_map mkVar to_revert in let type_of_expr = pf_unsafe_type_of g expr in @@ -691,18 +713,18 @@ let mkDestructEq : observe_tclTHENLIST (str "mkDestructEq") [Proofview.V82.of_tactic (generalize new_hyps); (fun g2 -> - let changefun patvars = { run = fun sigma -> - let redfun = pattern_occs [Locus.AllOccurrencesBut [1], expr] in - redfun.Reductionops.e_redfun (pf_env g2) sigma (pf_concl g2) - } in + let changefun patvars sigma = + pattern_occs [Locus.AllOccurrencesBut [1], expr] (pf_env g2) sigma (pf_concl g2) + in Proofview.V82.of_tactic (change_in_concl None changefun) g2); Proofview.V82.of_tactic (simplest_case expr)]), to_revert let terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos g = + let sigma = project g in let f_is_present = try - check_not_nested (expr_info.f_id::expr_info.forbidden_ids) a; + check_not_nested sigma (expr_info.f_id::expr_info.forbidden_ids) a; false with e when CErrors.noncritical e -> true @@ -716,25 +738,26 @@ let terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos g = let destruct_tac,rev_to_thin_intro = mkDestructEq [expr_info.rec_arg_id] a' g in let to_thin_intro = List.rev rev_to_thin_intro in - observe_tac (str "treating cases (" ++ int (Array.length l) ++ str")" ++ spc () ++ Printer.pr_lconstr a') + observe_tac (str "treating cases (" ++ int (Array.length l) ++ str")" ++ spc () ++ Printer.pr_leconstr_env (pf_env g) sigma a') (try (tclTHENS destruct_tac (List.map_i (fun i e -> observe_tac (str "do treat case") (treat_case f_is_present to_thin_intro (next_step continuation_tac) ci.ci_cstr_ndecls.(i) e new_info)) 0 (Array.to_list l) )) with - | UserError("Refiner.thensn_tac3",_) - | UserError("Refiner.tclFAIL_s",_) -> - (observe_tac (str "is computable " ++ Printer.pr_lconstr new_info.info) (next_step continuation_tac {new_info with info = nf_betaiotazeta new_info.info} ) + | UserError(Some "Refiner.thensn_tac3",_) + | UserError(Some "Refiner.tclFAIL_s",_) -> + (observe_tac (str "is computable " ++ Printer.pr_leconstr_env (pf_env g) sigma new_info.info) (next_step continuation_tac {new_info with info = nf_betaiotazeta new_info.info} ) )) g -let terminate_app_rec (f,args) expr_info continuation_tac _ = - List.iter (check_not_nested (expr_info.f_id::expr_info.forbidden_ids)) +let terminate_app_rec (f,args) expr_info continuation_tac _ g = + let sigma = project g in + List.iter (check_not_nested sigma (expr_info.f_id::expr_info.forbidden_ids)) args; begin try - let v = List.assoc_f (List.equal Constr.equal) args expr_info.args_assoc in + let v = List.assoc_f (List.equal (EConstr.eq_constr sigma)) args expr_info.args_assoc in let new_infos = {expr_info with info = v} in observe_tclTHENLIST (str "terminate_app_rec")[ continuation_tac new_infos; @@ -748,7 +771,7 @@ let terminate_app_rec (f,args) expr_info continuation_tac _ = ] else tclIDTAC - ] + ] g with Not_found -> observe_tac (str "terminate_app_rec not found") (tclTHENS (Proofview.V82.of_tactic (simplest_elim (mkApp(mkVar expr_info.ih,Array.of_list args)))) @@ -805,7 +828,7 @@ let terminate_app_rec (f,args) expr_info continuation_tac _ = ); ] ]) - ]) + ]) g end let terminate_info = @@ -827,8 +850,9 @@ let equation_case next_step (ci,a,t,l) expr_info continuation_tac infos = observe_tac (str "equation case") (terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos) let rec prove_le g = + let sigma = project g in let x,z = - let _,args = decompose_app (pf_concl g) in + let _,args = decompose_app sigma (pf_concl g) in (List.hd args,List.hd (List.tl args)) in tclFIRST[ @@ -836,13 +860,17 @@ let rec prove_le g = Proofview.V82.of_tactic (apply (delayed_force le_n)); begin try - let matching_fun = - pf_is_matching g - (Pattern.PApp(Pattern.PRef (reference_of_constr (le ())),[|Pattern.PVar (destVar x);Pattern.PMeta None|])) in + let matching_fun c = match EConstr.kind sigma c with + | App (c, [| x0 ; _ |]) -> + EConstr.isVar sigma x0 && + Id.equal (destVar sigma x0) (destVar sigma x) && + EConstr.is_global sigma (le ()) c + | _ -> false + in let (h,t) = List.find (fun (_,t) -> matching_fun t) (pf_hyps_types g) in let y = - let _,args = decompose_app t in + let _,args = decompose_app sigma t in List.hd (List.tl args) in observe_tclTHENLIST (str "prove_le")[ @@ -858,21 +886,21 @@ let rec make_rewrite_list expr_info max = function | [] -> tclIDTAC | (_,p,hp)::l -> observe_tac (str "make_rewrite_list") (tclTHENS - (observe_tac (str "rewrite heq on " ++ pr_id p ) ( + (observe_tac (str "rewrite heq on " ++ Id.print p ) ( (fun g -> + let sigma = project g in let t_eq = compute_renamed_type g (mkVar hp) in let k,def = - let k_na,_,t = destProd t_eq in - let _,_,t = destProd t in - let def_na,_,_ = destProd t in - Nameops.out_name k_na,Nameops.out_name def_na + let k_na,_,t = destProd sigma t_eq in + let _,_,t = destProd sigma t in + let def_na,_,_ = destProd sigma t in + Nameops.Name.get_id k_na,Nameops.Name.get_id def_na in Proofview.V82.of_tactic (general_rewrite_bindings false Locus.AllOccurrences true (* dep proofs also: *) true (mkVar hp, - ExplicitBindings[Loc.ghost,NamedHyp def, - expr_info.f_constr;Loc.ghost,NamedHyp k, - (f_S max)]) false) g) ) + ExplicitBindings[CAst.make @@ (NamedHyp def, expr_info.f_constr); + CAst.make @@ (NamedHyp k, f_S max)]) false) g) ) ) [make_rewrite_list expr_info max l; observe_tclTHENLIST (str "make_rewrite_list")[ (* x < S max proof *) @@ -886,20 +914,20 @@ let make_rewrite expr_info l hp max = (observe_tac (str "make_rewrite") (make_rewrite_list expr_info max l)) (observe_tac (str "make_rewrite") (tclTHENS (fun g -> + let sigma = project g in let t_eq = compute_renamed_type g (mkVar hp) in let k,def = - let k_na,_,t = destProd t_eq in - let _,_,t = destProd t in - let def_na,_,_ = destProd t in - Nameops.out_name k_na,Nameops.out_name def_na + let k_na,_,t = destProd sigma t_eq in + let _,_,t = destProd sigma t in + let def_na,_,_ = destProd sigma t in + Nameops.Name.get_id k_na,Nameops.Name.get_id def_na in observe_tac (str "general_rewrite_bindings") (Proofview.V82.of_tactic (general_rewrite_bindings false Locus.AllOccurrences true (* dep proofs also: *) true (mkVar hp, - ExplicitBindings[Loc.ghost,NamedHyp def, - expr_info.f_constr;Loc.ghost,NamedHyp k, - (f_S (f_S max))]) false)) g) + ExplicitBindings[CAst.make @@ (NamedHyp def, expr_info.f_constr); + CAst.make @@ (NamedHyp k, f_S (f_S max))]) false)) g) [observe_tac(str "make_rewrite finalize") ( (* tclORELSE( h_reflexivity) *) (observe_tclTHENLIST (str "make_rewrite")[ @@ -916,7 +944,7 @@ let make_rewrite expr_info l hp max = ])) ; observe_tclTHENLIST (str "make_rewrite1")[ (* x < S (S max) proof *) - Proofview.V82.of_tactic (apply (delayed_force le_lt_SS)); + Proofview.V82.of_tactic (apply (EConstr.of_constr (delayed_force le_lt_SS))); observe_tac (str "prove_le (3)") prove_le ] ]) @@ -953,7 +981,7 @@ let rec destruct_hex expr_info acc l = onNthHypId 1 (fun hp -> onNthHypId 2 (fun p -> observe_tac - (str "destruct_hex after " ++ pr_id hp ++ spc () ++ pr_id p) + (str "destruct_hex after " ++ Id.print hp ++ spc () ++ Id.print p) (destruct_hex expr_info ((v,p,hp)::acc) l) ) ) @@ -974,23 +1002,24 @@ let rec intros_values_eq expr_info acc = let equation_others _ expr_info continuation_tac infos = if expr_info.is_final && expr_info.is_main_branch then - observe_tac (str "equation_others (cont_tac +intros) " ++ Printer.pr_lconstr expr_info.info) + observe_tac (str "equation_others (cont_tac +intros) " ++ pr_leconstr_rd expr_info.info) (tclTHEN (continuation_tac infos) - (observe_tac (str "intros_values_eq equation_others " ++ Printer.pr_lconstr expr_info.info) (intros_values_eq expr_info []))) - else observe_tac (str "equation_others (cont_tac) " ++ Printer.pr_lconstr expr_info.info) (continuation_tac infos) + (observe_tac (str "intros_values_eq equation_others " ++ pr_leconstr_rd expr_info.info) (intros_values_eq expr_info []))) + else observe_tac (str "equation_others (cont_tac) " ++ pr_leconstr_rd expr_info.info) (continuation_tac infos) let equation_app f_and_args expr_info continuation_tac infos = if expr_info.is_final && expr_info.is_main_branch then ((observe_tac (str "intros_values_eq equation_app") (intros_values_eq expr_info []))) else continuation_tac infos -let equation_app_rec (f,args) expr_info continuation_tac info = +let equation_app_rec (f,args) expr_info continuation_tac info g = + let sigma = project g in begin try - let v = List.assoc_f (List.equal Constr.equal) args expr_info.args_assoc in + let v = List.assoc_f (List.equal (EConstr.eq_constr sigma)) args expr_info.args_assoc in let new_infos = {expr_info with info = v} in - observe_tac (str "app_rec found") (continuation_tac new_infos) + observe_tac (str "app_rec found") (continuation_tac new_infos) g with Not_found -> if expr_info.is_final && expr_info.is_main_branch then @@ -998,12 +1027,12 @@ let equation_app_rec (f,args) expr_info continuation_tac info = [ Proofview.V82.of_tactic (simplest_case (mkApp (expr_info.f_terminate,Array.of_list args))); continuation_tac {expr_info with args_assoc = (args,delayed_force coq_O)::expr_info.args_assoc}; observe_tac (str "app_rec intros_values_eq") (intros_values_eq expr_info []) - ] + ] g else observe_tclTHENLIST (str "equation_app_rec1")[ Proofview.V82.of_tactic (simplest_case (mkApp (expr_info.f_terminate,Array.of_list args))); observe_tac (str "app_rec not_found") (continuation_tac {expr_info with args_assoc = (args,delayed_force coq_O)::expr_info.args_assoc}) - ] + ] g end let equation_info = @@ -1022,10 +1051,13 @@ let prove_eq = travel equation_info (* [compute_terminate_type] computes the type of the Definition f_terminate from the type of f_F *) let compute_terminate_type nb_args func = + let open Term in + let open Constr in + let open CVars in let _,a_arrow_b,_ = destLambda(def_of_const (constr_of_global func)) in let rev_args,b = decompose_prod_n nb_args a_arrow_b in let left = - mkApp(delayed_force iter, + mkApp(delayed_force iter_rd, Array.of_list (lift 5 a_arrow_b:: mkRel 3:: constr_of_global func::mkRel 1:: @@ -1034,6 +1066,7 @@ let compute_terminate_type nb_args func = ) in let right = mkRel 5 in + let delayed_force c = EConstr.Unsafe.to_constr (delayed_force c) in let equality = mkApp(delayed_force eq, [|lift 5 b; left; right|]) in let result = (mkProd ((Name def_id) , lift 4 a_arrow_b, equality)) in let cond = mkApp(delayed_force lt, [|(mkRel 2); (mkRel 1)|]) in @@ -1046,7 +1079,7 @@ let compute_terminate_type nb_args func = delayed_force nat, (mkProd (Name k_id, delayed_force nat, mkArrow cond result))))|])in - let value = mkApp(constr_of_global (delayed_force coq_sig_ref), + let value = mkApp(constr_of_global (Util.delayed_force coq_sig_ref), [|b; (mkLambda (Name v_id, b, nb_iter))|]) in compose_prod rev_args value @@ -1130,25 +1163,27 @@ let termination_proof_header is_mes input_type ids args_id relation -let rec instantiate_lambda t l = +let rec instantiate_lambda sigma t l = match l with | [] -> t | a::l -> - let (_, _, body) = destLambda t in - instantiate_lambda (subst1 a body) l + let (_, _, body) = destLambda sigma t in + instantiate_lambda sigma (subst1 a body) l let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_arg_num : tactic = begin fun g -> + let sigma = project g in let ids = Termops.ids_of_named_context (pf_hyps g) in let func_body = (def_of_const (constr_of_global func)) in - let (f_name, _, body1) = destLambda func_body in + let func_body = EConstr.of_constr func_body in + let (f_name, _, body1) = destLambda sigma func_body in let f_id = match f_name with | Name f_id -> next_ident_away_in_goal f_id ids - | Anonymous -> anomaly (Pp.str "Anonymous function") + | Anonymous -> anomaly (Pp.str "Anonymous function.") in - let n_names_types,_ = decompose_lam_n nb_args body1 in + let n_names_types,_ = decompose_lam_n sigma nb_args body1 in let n_ids,ids = List.fold_left (fun (n_ids,ids) (n_name,_) -> @@ -1156,13 +1191,13 @@ let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_a | Name id -> let n_id = next_ident_away_in_goal id ids in n_id::n_ids,n_id::ids - | _ -> anomaly (Pp.str "anonymous argument") + | _ -> anomaly (Pp.str "anonymous argument.") ) ([],(f_id::ids)) n_names_types in let rec_arg_id = List.nth n_ids (rec_arg_num - 1) in - let expr = instantiate_lambda func_body (mkVar f_id::(List.map mkVar n_ids)) in + let expr = instantiate_lambda sigma func_body (mkVar f_id::(List.map mkVar n_ids)) in termination_proof_header is_mes input_type @@ -1201,20 +1236,21 @@ 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 - sigma, List.map (Goal.V82.abstract_type sigma) sgs + let sgs,_,_,_,sigma = Proof.proof p in + sigma, List.map (Goal.V82.abstract_type sigma) sgs -let build_and_l l = - let and_constr = Coqlib.build_coq_and () in +exception EmptySubgoals +let build_and_l sigma l = + let and_constr = Universes.constr_of_global @@ Coqlib.build_coq_and () in let conj_constr = coq_conj () in let mk_and p1 p2 = - Term.mkApp(and_constr,[|p1;p2|]) in + mkApp(EConstr.of_constr and_constr,[|p1;p2|]) in let rec is_well_founded t = - match kind_of_term t with + match EConstr.kind sigma t with | Prod(_,_,t') -> is_well_founded t' | App(_,_) -> - let (f,_) = decompose_app t in - eq_constr f (well_founded ()) + let (f,_) = decompose_app sigma t in + EConstr.eq_constr sigma f (well_founded ()) | _ -> false in @@ -1225,13 +1261,13 @@ let build_and_l l = in let l = List.sort compare l in let rec f = function - | [] -> failwith "empty list of subgoals!" + | [] -> raise EmptySubgoals | [p] -> p,tclIDTAC,1 | p1::pl -> let c,tac,nb = f pl in mk_and p1 c, tclTHENS - (Proofview.V82.of_tactic (apply (constr_of_global conj_constr))) + (Proofview.V82.of_tactic (apply (EConstr.of_constr (constr_of_global conj_constr)))) [tclIDTAC; tac ],nb+1 @@ -1245,16 +1281,16 @@ let is_rec_res id = String.equal (String.sub id_name 0 (String.length rec_res_name)) rec_res_name with Invalid_argument _ -> false -let clear_goals = +let clear_goals sigma = let rec clear_goal t = - match kind_of_term t with + match EConstr.kind sigma t with | Prod(Name id as na,t',b) -> let b' = clear_goal b in - if noccurn 1 b' && (is_rec_res id) - then Termops.pop b' + if noccurn sigma 1 b' && (is_rec_res id) + then Vars.lift (-1) b' else if b' == b then t else mkProd(na,t',b') - | _ -> Term.map_constr clear_goal t + | _ -> EConstr.map sigma clear_goal t in List.map clear_goal @@ -1262,41 +1298,41 @@ let clear_goals = let build_new_goal_type () = 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 + let sub_gls_types = clear_goals sigma 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 + let res = build_and_l sigma sub_gls_types in sigma, res let is_opaque_constant c = let cb = Global.lookup_constant c in match cb.Declarations.const_body with - | Declarations.OpaqueDef _ -> Vernacexpr.Opaque None - | Declarations.Undef _ -> Vernacexpr.Opaque None + | Declarations.OpaqueDef _ -> Vernacexpr.Opaque + | Declarations.Undef _ -> Vernacexpr.Opaque | Declarations.Def _ -> Vernacexpr.Transparent let open_new_goal build_proof sigma 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 current_proof_name = Proof_global.get_current_proof_name () in let name = match goal_name with | Some s -> s | None -> try add_suffix current_proof_name "_subproof" with e when CErrors.noncritical e -> - anomaly (Pp.str "open_new_goal with an unamed theorem") + anomaly (Pp.str "open_new_goal with an unamed theorem.") in - let na = next_global_ident_away name [] in - if Termops.occur_existential gls_type then - CErrors.error "\"abstract\" cannot handle existentials"; + let na = next_global_ident_away name Id.Set.empty in + if Termops.occur_existential sigma gls_type then + CErrors.user_err Pp.(str "\"abstract\" cannot handle existentials"); let hook _ _ = let opacity = - let na_ref = Libnames.Ident (Loc.ghost,na) in + let na_ref = CAst.make @@ Libnames.Ident na in let na_global = Smartlocate.global_with_alias na_ref in match na_global with ConstRef c -> is_opaque_constant c - | _ -> anomaly ~label:"equation_lemma" (Pp.str "not a constant") + | _ -> anomaly ~label:"equation_lemma" (Pp.str "not a constant.") in let lemma = mkConst (Names.Constant.make1 (Lib.make_kn na)) in - ref_ := Some lemma ; + ref_ := Value (EConstr.Unsafe.to_constr lemma); let lid = ref [] in let h_num = ref (-1) in let env = Global.env () in @@ -1322,8 +1358,9 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp ); ] gls) (fun g -> - match kind_of_term (pf_concl g) with - | App(f,_) when eq_constr f (well_founded ()) -> + let sigma = project g in + match EConstr.kind sigma (pf_concl g) with + | App(f,_) when EConstr.eq_constr sigma f (well_founded ()) -> Proofview.V82.of_tactic (Auto.h_auto None [] (Some [])) g | _ -> incr h_num; @@ -1336,7 +1373,7 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp (Proofview.V82.of_tactic e_assumption); Eauto.eauto_with_bases (true,5) - [{ Tacexpr.delayed = fun _ sigma -> Sigma.here (Lazy.force refl_equal) sigma}] + [(fun _ sigma -> (sigma, (Lazy.force refl_equal)))] [Hints.Hint_db.empty empty_transparent_state false] ] ) @@ -1366,7 +1403,7 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp (fun c -> Proofview.V82.of_tactic (Tacticals.New.tclTHENLIST [intros; - Simple.apply (fst (interp_constr (Global.env()) Evd.empty c)) (*FIXME*); + Simple.apply (fst (interp_constr (Global.env()) Evd.empty c)) (*FIXME*); Tacticals.New.tclCOMPLETE Auto.default_auto ]) ) @@ -1393,10 +1430,10 @@ let com_terminate nb_args ctx hook = let start_proof ctx (tac_start:tactic) (tac_end:tactic) = - let (evmap, env) = Lemmas.get_current_context() in + let evd, env = Pfedit.get_current_context () in Lemmas.start_proof thm_name (Global, false (* FIXME *), Proof Lemma) ~sign:(Environ.named_context_val env) - ctx (compute_terminate_type nb_args fonctional_ref) hook; + ctx (EConstr.of_constr (compute_terminate_type nb_args fonctional_ref)) 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 @@ -1410,8 +1447,9 @@ let com_terminate using_lemmas tcc_lemma_ref (Some tcc_lemma_name) (new_goal_type); - with Failure "empty list of subgoals!" -> + with EmptySubgoals -> (* a non recursive function declared with measure ! *) + tcc_lemma_ref := Not_needed; defined () @@ -1420,9 +1458,11 @@ let com_terminate let start_equation (f:global_reference) (term_f:global_reference) (cont_tactic:Id.t list -> tactic) g = + let sigma = project g in let ids = pf_ids_of_hyps g in let terminate_constr = constr_of_global term_f in - let nargs = nb_prod (fst (type_of_const terminate_constr)) (*FIXME*) in + let terminate_constr = EConstr.of_constr terminate_constr in + let nargs = nb_prod (project g) (EConstr.of_constr (type_of_const sigma terminate_constr)) in let x = n_x_id ids nargs in observe_tac (str "start_equation") (observe_tclTHENLIST (str "start_equation") [ h_intros x; @@ -1434,34 +1474,35 @@ let start_equation (f:global_reference) (term_f:global_reference) let (com_eqn : int -> Id.t -> global_reference -> global_reference -> global_reference - -> constr -> unit) = + -> Constr.t -> unit) = fun nb_arg eq_name functional_ref f_ref terminate_ref equation_lemma_type -> + let open CVars in let opacity = match terminate_ref with | ConstRef c -> is_opaque_constant c - | _ -> anomaly ~label:"terminate_lemma" (Pp.str "not a constant") + | _ -> anomaly ~label:"terminate_lemma" (Pp.str "not a constant.") in - let (evmap, env) = Lemmas.get_current_context() in - let evmap = Evd.from_ctx (Evd.evar_universe_context evmap) in + let evd, env = Pfedit.get_current_context () in + let evd = Evd.from_ctx (Evd.evar_universe_context evd) 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, false, Proof Lemma) ~sign:(Environ.named_context_val env) - evmap - equation_lemma_type + evd + (EConstr.of_constr equation_lemma_type) (Lemmas.mk_hook (fun _ _ -> ())); ignore (by (Proofview.V82.tactic (start_equation f_ref terminate_ref (fun x -> prove_eq (fun _ -> tclIDTAC) {nb_arg=nb_arg; - f_terminate = constr_of_global terminate_ref; - f_constr = f_constr; + f_terminate = EConstr.of_constr (constr_of_global terminate_ref); + f_constr = EConstr.of_constr f_constr; concl_tac = tclIDTAC; func=functional_ref; - info=(instantiate_lambda - (def_of_const (constr_of_global functional_ref)) - (f_constr::List.map mkVar x) + info=(instantiate_lambda Evd.empty + (EConstr.of_constr (def_of_const (constr_of_global functional_ref))) + (EConstr.of_constr f_constr::List.map mkVar x) ); is_main_branch = true; is_final = true; @@ -1484,27 +1525,33 @@ let (com_eqn : int -> Id.t -> (* Pp.msgnl (str "eqn finished"); *) );; - let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num eq generate_induction_principle using_lemmas : unit = + let open Term in + let open Constr in + let open CVars in let env = Global.env() in - let evd = ref (Evd.from_env env) in - let function_type = interp_type_evars env evd type_of_f in + let evd = Evd.from_env env in + let evd, function_type = interp_type_evars env evd type_of_f in + let function_type = EConstr.Unsafe.to_constr function_type in let env = push_named (Context.Named.Declaration.LocalAssum (function_name,function_type)) env in (* Pp.msgnl (str "function type := " ++ Printer.pr_lconstr function_type); *) - let ty = interp_type_evars env evd ~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 evd, ty = interp_type_evars env evd ~impls:rec_impls eq in + let ty = EConstr.Unsafe.to_constr ty in + let evd, nf = Evarutil.nf_evars_and_universes evd in + let equation_lemma_type = nf_betaiotazeta (EConstr.of_constr (nf ty)) in let function_type = nf function_type in + let equation_lemma_type = EConstr.Unsafe.to_constr equation_lemma_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) -> LocalAssum (x,y)) res_vars) env in - let eq' = nf_zeta env_eq' eq' in + let eq' = nf_zeta env_eq' (EConstr.of_constr eq') in + let eq' = EConstr.Unsafe.to_constr eq' in let res = (* Pp.msgnl (str "res_var :=" ++ Printer.pr_lconstr_env (push_rel_context (List.map (function (x,t) -> (x,None,t)) res_vars) env) eq'); *) (* Pp.msgnl (str "rec_arg_num := " ++ str (string_of_int rec_arg_num)); *) (* Pp.msgnl (str "eq' := " ++ str (string_of_int rec_arg_num)); *) - match kind_of_term eq' with + match Constr.kind eq' with | App(e,[|_;_;eq_fix|]) -> mkLambda (Name function_name,function_type,subst_var function_name (compose_lam res_vars eq_fix)) | _ -> failwith "Recursive Definition (res not eq)" @@ -1515,21 +1562,24 @@ 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) ~ctx:(snd (Evd.universe_context evm)) res in + let functional_ref = + let univs = Entries.Monomorphic_const_entry (Evd.universe_context_set evd) in + declare_fun functional_id (IsDefinition Decl_kinds.Definition) ~univs res + in (* Refresh the global universes, now including those of _F *) - let evm = Evd.from_env (Global.env ()) in + let evd = Evd.from_env (Global.env ()) in let env_with_pre_rec_args = push_rel_context(List.map (function (x,t) -> LocalAssum (x,t)) pre_rec_args) env in let relation, evuctx = - interp_constr env_with_pre_rec_args evm r + interp_constr env_with_pre_rec_args evd r in - let evm = Evd.from_ctx evuctx in + let evd = Evd.from_ctx evuctx in let tcc_lemma_name = add_suffix function_name "_tcc" in - let tcc_lemma_constr = ref None in + let tcc_lemma_constr = ref Undefined in (* let _ = Pp.msgnl (str "relation := " ++ Printer.pr_lconstr_env env_with_pre_rec_args relation) in *) let hook _ _ = let term_ref = Nametab.locate (qualid_of_ident term_id) in let f_ref = declare_f function_name (IsProof Lemma) arg_types term_ref in - let _ = Extraction_plugin.Table.extraction_inline true [Ident (Loc.ghost,term_id)] in + let _ = Extraction_plugin.Table.extraction_inline true [CAst.make @@ Ident term_id] in (* message "start second proof"; *) let stop = try com_eqn (List.length res_vars) equation_id functional_ref f_ref term_ref (subst_var function_name equation_lemma_type); @@ -1538,7 +1588,7 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num begin if do_observe () then Feedback.msg_debug (str "Cannot create equation Lemma " ++ CErrors.print e) - else CErrors.errorlabstrm "Cannot create equation Lemma" + else CErrors.user_err ~hdr:"Cannot create equation Lemma" (str "Cannot create equation lemma." ++ spc () ++ str "This may be because the function is nested-recursive.") ; @@ -1552,23 +1602,26 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num and functional_ref = destConst (constr_of_global functional_ref) and eq_ref = destConst (constr_of_global eq_ref) in generate_induction_principle f_ref tcc_lemma_constr - functional_ref eq_ref rec_arg_num rec_arg_type (nb_prod res) relation; - if Flags.is_verbose () - then msgnl (h 1 (Ppconstr.pr_id function_name ++ + functional_ref eq_ref rec_arg_num + (EConstr.of_constr rec_arg_type) + (nb_prod evd (EConstr.of_constr res)) relation; + Flags.if_verbose + msgnl (h 1 (Ppconstr.pr_id function_name ++ spc () ++ str"is defined" )++ fnl () ++ h 1 (Ppconstr.pr_id equation_id ++ spc () ++ str"is defined" ) ) in - States.with_state_protection_on_exception (fun () -> + (* XXX STATE Why do we need this... why is the toplevel protection not enought *) + funind_purify (fun () -> com_terminate tcc_lemma_name tcc_lemma_constr is_mes functional_ref - rec_arg_type + (EConstr.of_constr rec_arg_type) relation rec_arg_num term_id using_lemmas (List.length res_vars) - evm (Lemmas.mk_hook hook)) + evd (Lemmas.mk_hook hook)) () diff --git a/plugins/funind/recdef.mli b/plugins/funind/recdef.mli index f60eedbe..b95d64ce 100644 --- a/plugins/funind/recdef.mli +++ b/plugins/funind/recdef.mli @@ -1,20 +1,19 @@ +open Constr - -(* val evaluable_of_global_reference : Libnames.global_reference -> Names.evaluable_global_reference *) val tclUSER_if_not_mes : - Proof_type.tactic -> + Tacmach.tactic -> bool -> Names.Id.t list option -> - Proof_type.tactic + Tacmach.tactic val recursive_definition : bool -> Names.Id.t -> Constrintern.internalization_env -> Constrexpr.constr_expr -> Constrexpr.constr_expr -> - int -> Constrexpr.constr_expr -> (Term.pconstant -> - Term.constr option ref -> - Term.pconstant -> - Term.pconstant -> int -> Term.types -> int -> Term.constr -> 'a) -> Constrexpr.constr_expr list -> unit + int -> Constrexpr.constr_expr -> (pconstant -> + Indfun_common.tcc_lemma_value ref -> + pconstant -> + pconstant -> int -> EConstr.types -> int -> EConstr.constr -> 'a) -> Constrexpr.constr_expr list -> unit diff --git a/plugins/funind/recdef_plugin.mlpack b/plugins/funind/recdef_plugin.mlpack index 2b443f2a..755fa4f8 100644 --- a/plugins/funind/recdef_plugin.mlpack +++ b/plugins/funind/recdef_plugin.mlpack @@ -6,5 +6,4 @@ Functional_principles_proofs Functional_principles_types Invfun Indfun -Merge G_indfun diff --git a/plugins/funind/vo.itarget b/plugins/funind/vo.itarget deleted file mode 100644 index 33c96830..00000000 --- a/plugins/funind/vo.itarget +++ /dev/null @@ -1 +0,0 @@ -Recdef.vo |