From 7cfc4e5146be5666419451bdd516f1f3f264d24a Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Sun, 25 Jan 2015 14:42:51 +0100 Subject: Imported Upstream version 8.5~beta1+dfsg --- plugins/funind/Recdef.v | 38 +- plugins/funind/functional_principles_proofs.ml | 474 +++--- plugins/funind/functional_principles_types.ml | 228 +-- plugins/funind/functional_principles_types.mli | 10 +- plugins/funind/g_indfun.ml4 | 167 +- plugins/funind/glob_term_to_relation.ml | 399 +++-- plugins/funind/glob_term_to_relation.mli | 10 +- plugins/funind/glob_termops.ml | 168 +- plugins/funind/glob_termops.mli | 58 +- plugins/funind/indfun.ml | 470 +++--- plugins/funind/indfun.mli | 15 +- plugins/funind/indfun_common.ml | 212 ++- plugins/funind/indfun_common.mli | 52 +- plugins/funind/invfun.ml | 706 +++++--- plugins/funind/merge.ml | 195 +-- plugins/funind/recdef.ml | 2077 ++++++++++++------------ plugins/funind/recdef.mli | 20 + 17 files changed, 2741 insertions(+), 2558 deletions(-) create mode 100644 plugins/funind/recdef.mli (limited to 'plugins/funind') diff --git a/plugins/funind/Recdef.v b/plugins/funind/Recdef.v index 51ede26e..a63941f0 100644 --- a/plugins/funind/Recdef.v +++ b/plugins/funind/Recdef.v @@ -1,10 +1,13 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* A) -> A -> A := end. End Iter. -Theorem SSplus_lt : forall p p' : nat, p < S (S (p + p')). - intro p; intro p'; change (S p <= S (S (p + p'))); - apply le_S; apply Gt.gt_le_S; change (p < S (p + p')); - apply Lt.le_lt_n_Sm; apply Plus.le_plus_l. +Theorem le_lt_SS x y : x <= y -> x < S (S y). +Proof. + intros. now apply Nat.lt_succ_r, Nat.le_le_succ_r. Qed. - -Theorem Splus_lt : forall p p' : nat, p' < S (p + p'). - intro p; intro p'; change (S p' <= S (p + p')); - apply Gt.gt_le_S; change (p' < S (p + p')); apply Lt.le_lt_n_Sm; - apply Plus.le_plus_r. +Theorem Splus_lt x y : y < S (x + y). +Proof. + apply Nat.lt_succ_r. rewrite Nat.add_comm. apply Nat.le_add_r. Qed. -Theorem le_lt_SS : forall x y, x <= y -> x < S (S y). -intro x; intro y; intro H; change (S x <= S (S y)); - apply le_S; apply Gt.gt_le_S; change (x < S y); - apply Lt.le_lt_n_Sm; exact H. +Theorem SSplus_lt x y : x < S (S (x + y)). +Proof. + apply le_lt_SS, Nat.le_add_r. Qed. Inductive max_type (m n:nat) : Set := cmt : forall v, m <= v -> n <= v -> max_type m n. -Definition max : forall m n:nat, max_type m n. -intros m n; case (Compare_dec.le_gt_dec m n). -intros h; exists n; [exact h | apply le_n]. -intros h; exists m; [apply le_n | apply Lt.lt_le_weak; exact h]. +Definition max m n : max_type m n. +Proof. + destruct (Compare_dec.le_gt_dec m n) as [h|h]. + - exists n; [exact h | apply le_n]. + - exists m; [apply le_n | apply Nat.lt_le_incl; exact h]. Defined. + +Definition Acc_intro_generator_function := fun A R => @Acc_intro_generator A R 100. diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index b5876ffa..c8214ada 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -1,45 +1,37 @@ open Printer +open Errors open Util open Term +open Vars +open Context open Namegen open Names open Declarations +open Declareops open Pp -open Entries -open Hiddentac -open Evd open Tacmach open Proof_type open Tacticals open Tactics open Indfun_common open Libnames +open Globnames +open Misctypes -let msgnl = Pp.msgnl - +(* let msgnl = Pp.msgnl *) +(* let observe strm = if do_observe () - then Pp.msgnl strm - else () - -let observennl strm = - if do_observe () - then begin Pp.msg strm;Pp.pp_flush () end + then Pp.msg_debug strm else () - - - let do_observe_tac s tac g = try let v = tac g in (* msgnl (goal ++ fnl () ++ (str s)++(str " ")++(str "finished")); *) v - with reraise -> - let e = Cerrors.process_vernac_interp_error reraise in - let goal = - try (Printer.pr_goal g) - with e when Errors.noncritical e -> assert false - in - msgnl (str "observation "++ s++str " raised exception " ++ + with e -> + let e = Cerrors.process_vernac_interp_error e in + let goal = begin try (Printer.pr_goal g) with _ -> assert false end in + msg_debug (str "observation "++ s++str " raised exception " ++ Errors.print e ++ str " on goal " ++ goal ); raise e;; @@ -49,16 +41,55 @@ let observe_tac_stream s tac g = else tac g let observe_tac s tac g = observe_tac_stream (str s) tac g + *) + + +let debug_queue = Stack.create () + +let rec print_debug_queue b e = + if not (Stack.is_empty debug_queue) + then + begin + let lmsg,goal = Stack.pop debug_queue in + if b then + Pp.msg_debug (lmsg ++ (str " raised exception " ++ Errors.print e) ++ str " on goal " ++ goal) + else + begin + Pp.msg_debug (str " from " ++ lmsg ++ str " on goal " ++ goal); + end; + print_debug_queue false e; + end -(* let tclTRYD tac = *) -(* if !Flags.debug || do_observe () *) -(* then (fun g -> try (\* do_observe_tac "" *\)tac g with _ -> tclIDTAC g) *) -(* else tac *) +let observe strm = + if do_observe () + then Pp.msg_debug strm + else () + +let do_observe_tac s tac g = + let goal = Printer.pr_goal g in + let lmsg = (str "observation : ") ++ s in + Stack.push (lmsg,goal) debug_queue; + try + let v = tac g in + ignore(Stack.pop debug_queue); + v + with reraise -> + let reraise = Errors.push reraise in + if not (Stack.is_empty debug_queue) + then print_debug_queue true (fst (Cerrors.process_vernac_interp_error reraise)); + iraise reraise + +let observe_tac_stream s tac g = + if do_observe () + then do_observe_tac s tac g + else tac g +let observe_tac s = observe_tac_stream (str s) + let list_chop ?(msg="") n l = try - list_chop n l + List.chop n l with Failure (msg') -> failwith (msg ^ msg') @@ -70,17 +101,17 @@ let make_refl_eq constructor type_of_t t = type pte_info = { - proving_tac : (identifier list -> Tacmach.tactic); + proving_tac : (Id.t list -> Tacmach.tactic); is_valid : constr -> bool } -type ptes_info = pte_info Idmap.t +type ptes_info = pte_info Id.Map.t type 'a dynamic_info = { nb_rec_hyps : int; - rec_hyps : identifier list ; - eq_hyps : identifier list; + rec_hyps : Id.t list ; + eq_hyps : Id.t list; info : 'a } @@ -89,28 +120,17 @@ type body_info = constr dynamic_info let finish_proof dynamic_infos g = observe_tac "finish" - ( h_assumption) + (Proofview.V82.of_tactic assumption) g let refine c = - Tacmach.refine_no_check c + Tacmach.refine c let thin l = Tacmach.thin_no_check l - -let cut_replacing id t tac :tactic= - tclTHENS (cut t) - [ tclTHEN (thin_no_check [id]) (introduction_no_check id); - tac - ] - -let intro_erasing id = tclTHEN (thin [id]) (introduction id) - - - -let rec_hyp_id = id_of_string "rec_hyp" +let eq_constr u v = eq_constr_nounivs u v let is_trivial_eq t = let res = try @@ -157,11 +177,11 @@ let change_hyp_with_using msg hyp_id t tac : tactic = fun g -> let prov_id = pf_get_new_id hyp_id g in tclTHENS - ((* observe_tac msg *) (assert_by (Name prov_id) t (tclCOMPLETE tac))) + ((* observe_tac msg *) Proofview.V82.of_tactic (assert_by (Name prov_id) t (Proofview.V82.tactic (tclCOMPLETE tac)))) [tclTHENLIST [ (* observe_tac "change_hyp_with_using thin" *) (thin [hyp_id]); - (* observe_tac "change_hyp_with_using rename " *) (h_rename [prov_id,hyp_id]) + (* observe_tac "change_hyp_with_using rename " *) (Proofview.V82.of_tactic (rename_hyp [prov_id,hyp_id])) ]] g exception TOREMOVE @@ -171,7 +191,7 @@ let prove_trivial_eq h_id context (constructor,type_of_term,term) = let nb_intros = List.length context in tclTHENLIST [ - tclDO nb_intros intro; (* introducing context *) + tclDO nb_intros (Proofview.V82.of_tactic intro); (* introducing context *) (fun g -> let context_hyps = fst (list_chop ~msg:"prove_trivial_eq : " nb_intros (pf_ids_of_hyps g)) @@ -188,7 +208,7 @@ let prove_trivial_eq h_id context (constructor,type_of_term,term) = let find_rectype env c = - let (t, l) = decompose_app (Reduction.whd_betaiotazeta c) in + let (t, l) = decompose_app (Reduction.whd_betaiotazeta env c) in match kind_of_term t with | Ind ind -> (t, l) | Construct _ -> (t,l) @@ -216,7 +236,7 @@ let change_eq env sigma hyp_id (context:rel_context) x t end_of_type = failwith "NoChange"; end in - let eq_constr = Reductionops.is_conv env sigma in + let eq_constr = Evarconv.e_conv env (ref sigma) in if not (noccurn 1 end_of_type) then nochange "dependent"; (* if end_of_type depends on this term we don't touch it *) if not (isApp t) then nochange "not an equality"; @@ -245,12 +265,12 @@ let change_eq env sigma hyp_id (context:rel_context) x t end_of_type = let t2 = destRel t2 in begin try - let t1' = Intmap.find t2 sub in + 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); - Intmap.add t2 t1 sub + Int.Map.add t2 t1 sub end else if isAppConstruct t1 && isAppConstruct t2 then @@ -264,18 +284,17 @@ let change_eq env sigma hyp_id (context:rel_context) x t end_of_type = else if (eq_constr t1 t2) then sub else nochange ~t':(make_refl_eq constructor (Reduction.whd_betadeltaiota env t1) t2) "cannot solve (diff)" in - let sub = compute_substitution Intmap.empty (snd t1) (snd t2) 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 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' = Intmap.fold (fun i t acc -> (i,t)::acc) sub [] in - let sub'' = List.sort (fun (x,_) (y,_) -> Pervasives.compare x y) sub' in + 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)) end_of_type_with_pop - sub'' + sub in let old_context_length = List.length context + 1 in let witness_fun = @@ -284,11 +303,11 @@ let change_eq env sigma hyp_id (context:rel_context) x t end_of_type = ) in let new_type_of_hyp,ctxt_size,witness_fun = - list_fold_left_i + List.fold_left_i (fun i (end_of_type,ctxt_size,witness_fun) ((x',b',t') as decl) -> try - let witness = Intmap.find i sub in - if b' <> None then anomaly "can not redefine a rel!"; + let witness = Int.Map.find i sub in + if not (Option.is_empty b') then anomaly (Pp.str "can not redefine a rel!"); (Termops.pop end_of_type,ctxt_size,mkLetIn(x',witness,t',witness_fun)) with Not_found -> (mkProd_or_LetIn decl end_of_type, ctxt_size + 1, mkLambda_or_LetIn decl witness_fun) @@ -304,12 +323,13 @@ let change_eq env sigma hyp_id (context:rel_context) x t end_of_type = in let prove_new_hyp : tactic = tclTHEN - (tclDO ctxt_size intro) + (tclDO ctxt_size (Proofview.V82.of_tactic intro)) (fun g -> let all_ids = pf_ids_of_hyps g in let new_ids,_ = list_chop ctxt_size all_ids in let to_refine = applist(witness_fun,List.rev_map mkVar new_ids) in - refine to_refine g + let evm, _ = pf_apply Typing.e_type_of g to_refine in + tclTHEN (Refiner.tclEVARS evm) (refine to_refine) g ) in let simpl_eq_tac = @@ -332,14 +352,14 @@ let change_eq env sigma hyp_id (context:rel_context) x t end_of_type = new_ctxt,new_end_of_type,simpl_eq_tac -let is_property ptes_info t_x full_type_of_hyp = +let is_property (ptes_info:ptes_info) t_x full_type_of_hyp = if isApp t_x then let pte,args = destApp t_x in - if isVar pte && array_for_all closed0 args + if isVar pte && Array.for_all closed0 args then try - let info = Idmap.find (destVar pte) ptes_info in + let info = Id.Map.find (destVar pte) ptes_info in info.is_valid full_type_of_hyp with Not_found -> false else false @@ -352,10 +372,10 @@ let isLetIn t = let h_reduce_with_zeta = - h_reduce - (Glob_term.Cbv - {Glob_term.all_flags - with Glob_term.rDelta = false; + reduce + (Genredexpr.Cbv + {Redops.all_flags + with Genredexpr.rDelta = false; }) @@ -374,17 +394,17 @@ let rewrite_until_var arg_num eq_ids : tactic = then tclIDTAC g else match eq_ids with - | [] -> anomaly "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 (Equality.rewriteRL (mkVar eq_id))) + (tclTRY (Proofview.V82.of_tactic (Equality.rewriteRL (mkVar eq_id)))) (do_rewrite eq_ids) g in do_rewrite eq_ids -let rec_pte_id = id_of_string "Hrec" +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 @@ -398,13 +418,8 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = decompose_prod_n_assum (List.length context) reduced_type_of_hyp in tclTHENLIST - [ - h_reduce_with_zeta - (Tacticals.onHyp hyp_id) - ; - scan_type new_context new_typ_of_hyp - - ] + [ h_reduce_with_zeta (Locusops.onHyp hyp_id); + scan_type new_context new_typ_of_hyp ] else if isProd type_of_hyp then begin @@ -413,14 +428,14 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = if is_property 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 = (Idmap.find (destVar pte) ptes_infos).proving_tac 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 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 tclTHENLIST [ - tclDO context_length intro; + tclDO context_length (Proofview.V82.of_tactic intro); (fun g -> let context_hyps_ids = fst (list_chop ~msg:"rec hyp : context_hyps" @@ -434,7 +449,7 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = in (* observe_tac "rec hyp " *) (tclTHENS - (assert_tac (Name rec_pte_id) t_x) + (Proofview.V82.of_tactic (assert_before (Name rec_pte_id) t_x)) [ (* observe_tac "prove rec hyp" *) (prove_rec_hyp eq_hyps); (* observe_tac "prove rec hyp" *) @@ -471,7 +486,7 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = let prove_trivial = let nb_intro = List.length context in tclTHENLIST [ - tclDO nb_intro intro; + tclDO nb_intro (Proofview.V82.of_tactic intro); (fun g -> let context_hyps = fst (list_chop ~msg:"removing True : context_hyps "nb_intro (pf_ids_of_hyps g)) @@ -533,7 +548,7 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = thin [hyp_id],[] -let clean_goal_with_heq ptes_infos continue_tac dyn_infos = +let clean_goal_with_heq ptes_infos continue_tac (dyn_infos:body_info) = fun g -> let env = pf_env g and sigma = project g @@ -562,7 +577,7 @@ let clean_goal_with_heq ptes_infos continue_tac dyn_infos = ] g -let heq_id = id_of_string "Heq" +let heq_id = Id.of_string "Heq" let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos = fun g -> @@ -570,12 +585,12 @@ let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos = tclTHENLIST [ (* We first introduce the variables *) - tclDO nb_first_intro (intro_avoiding dyn_infos.rec_hyps); + tclDO nb_first_intro (Proofview.V82.of_tactic (intro_avoiding dyn_infos.rec_hyps)); (* Then the equation itself *) - intro_using heq_id; + Proofview.V82.of_tactic (intro_using heq_id); onLastHypId (fun heq_id -> tclTHENLIST [ (* Then the new hypothesis *) - tclMAP introduction_no_check dyn_infos.rec_hyps; + tclMAP (fun id -> Proofview.V82.of_tactic (introduction ~check:false id)) dyn_infos.rec_hyps; observe_tac "after_introduction" (fun g' -> (* We get infos on the equations introduced*) let new_term_value_eq = pf_type_of g' (mkVar heq_id) in @@ -585,9 +600,9 @@ let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos = | 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') new_term_value_eq + pr_lconstr_env (pf_env g') Evd.empty new_term_value_eq ); - anomaly "cannot compute new term value" + anomaly (Pp.str "cannot compute new term value") in let fun_body = mkLambda(Anonymous, @@ -615,17 +630,20 @@ let my_orelse tac1 tac2 g = (* observe (str "using snd tac since : " ++ Errors.print e); *) tac2 g -let instanciate_hyps_with_args (do_prove:identifier list -> tactic) hyps args_id = +let instanciate_hyps_with_args (do_prove:Id.t list -> tactic) hyps args_id = let args = Array.of_list (List.map mkVar args_id) in let instanciate_one_hyp hid = my_orelse ( (* we instanciate the hyp if possible *) fun g -> let prov_hid = pf_get_new_id hid g in + let c = mkApp(mkVar hid,args) in + let evm, _ = pf_apply Typing.e_type_of g c in tclTHENLIST[ - pose_proof (Name prov_hid) (mkApp(mkVar hid,args)); + Refiner.tclEVARS evm; + Proofview.V82.of_tactic (pose_proof (Name prov_hid) c); thin [hid]; - h_rename [prov_hid,hid] + Proofview.V82.of_tactic (rename_hyp [prov_hid,hid]) ] g ) ( (* @@ -642,23 +660,23 @@ let instanciate_hyps_with_args (do_prove:identifier list -> tactic) hyps args_id ) ) in - if args_id = [] + if List.is_empty args_id then tclTHENLIST [ - tclMAP (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id)) hyps; + tclMAP (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) hyps; do_prove hyps ] else tclTHENLIST [ - tclMAP (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id)) hyps; + tclMAP (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) hyps; tclMAP instanciate_one_hyp hyps; (fun g -> let all_g_hyps_id = - List.fold_right Idset.add (pf_ids_of_hyps g) Idset.empty + List.fold_right Id.Set.add (pf_ids_of_hyps g) Id.Set.empty in let remaining_hyps = - List.filter (fun id -> Idset.mem id all_g_hyps_id) hyps + List.filter (fun id -> Id.Set.mem id all_g_hyps_id) hyps in do_prove remaining_hyps g ) @@ -687,11 +705,11 @@ let build_proof in tclTHENSEQ [ - h_generalize (term_eq::(List.map mkVar dyn_infos.rec_hyps)); + Simple.generalize (term_eq::(List.map mkVar dyn_infos.rec_hyps)); thin dyn_infos.rec_hyps; - pattern_option [(false,[1]),t] None; + pattern_option [Locus.AllOccurrencesBut [1],t] None; (fun g -> observe_tac "toto" ( - tclTHENSEQ [h_simplest_case t; + tclTHENSEQ [Proofview.V82.of_tactic (Simple.case t); (fun g' -> let g'_nb_prod = nb_prod (pf_concl g') in let nb_instanciate_partial = g'_nb_prod - g_nb_prod in @@ -716,7 +734,7 @@ let build_proof match kind_of_term( pf_concl g) with | Prod _ -> tclTHEN - intro + (Proofview.V82.of_tactic intro) (fun g' -> let (id,_,_) = pf_last_hyp g' in let new_term = @@ -746,6 +764,7 @@ let build_proof begin match kind_of_term f with | App _ -> assert false (* we have collected all the app in decompose_app *) + | Proj _ -> assert false (*FIXME*) | Var _ | Construct _ | Rel _ | Evar _ | Meta _ | Ind _ | Sort _ | Prod _ -> let new_infos = { dyn_infos with @@ -753,7 +772,7 @@ let build_proof } in build_proof_args do_finalize new_infos g - | Const c when not (List.mem c fnames) -> + | Const (c,_) when not (List.mem_f Constant.equal c fnames) -> let new_infos = { dyn_infos with info = (f,args) @@ -775,9 +794,10 @@ let build_proof tclTHENLIST [tclMAP - (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id)) + (fun hyp_id -> + h_reduce_with_zeta (Locusops.onHyp hyp_id)) dyn_infos.rec_hyps; - h_reduce_with_zeta Tacticals.onConcl; + h_reduce_with_zeta Locusops.onConcl; build_proof do_finalize new_infos ] g @@ -797,6 +817,7 @@ let build_proof | Fix _ | CoFix _ -> error ( "Anonymous local (co)fixpoints are not handled yet") + | Proj _ -> error "Prod" | Prod _ -> error "Prod" | LetIn _ -> let new_infos = @@ -807,28 +828,28 @@ let build_proof tclTHENLIST [tclMAP - (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id)) + (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) dyn_infos.rec_hyps; - h_reduce_with_zeta Tacticals.onConcl; + h_reduce_with_zeta Locusops.onConcl; build_proof do_finalize new_infos ] g - | Rel _ -> anomaly "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 "build_proof" (build_proof_aux do_finalize dyn_infos) g + observe_tac_stream (str "build_proof with " ++ Printer.pr_lconstr 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 let tac : tactic = fun g -> - match args with - | [] -> + match args with + | [] -> do_finalize {dyn_infos with info = f_args'} g - | arg::args -> -(* observe (str "build_proof_args with arg := "++ pr_lconstr_env (pf_env g) arg++ *) -(* fnl () ++ *) -(* pr_goal (Tacmach.sig_it g) *) -(* ); *) + | arg::args -> + (* observe (str "build_proof_args with arg := "++ pr_lconstr_env (pf_env g) arg++ *) + (* fnl () ++ *) + (* pr_goal (Tacmach.sig_it g) *) + (* ); *) let do_finalize dyn_infos = let new_arg = dyn_infos.info in (* tclTRYD *) @@ -842,14 +863,14 @@ let build_proof g in (* observe_tac "build_proof_args" *) (tac ) g - in - let do_finish_proof dyn_infos = + in + let do_finish_proof dyn_infos = (* tclTRYD *) (clean_goal_with_heq - ptes_infos - finish_proof dyn_infos) + ptes_infos + finish_proof dyn_infos) in - (* observe_tac "build_proof" *) - (build_proof (clean_goal_with_heq ptes_infos do_finish_proof) dyn_infos) + (* observe_tac "build_proof" *) + (build_proof (clean_goal_with_heq ptes_infos do_finish_proof) dyn_infos) @@ -863,18 +884,11 @@ let build_proof (* Proof of principles from structural functions *) -let is_pte_type t = - isSort ((strip_prod t)) - -let is_pte (_,_,t) = is_pte_type t - - - type static_fix_info = { idx : int; - name : identifier; + name : Id.t; types : types; offset : int; nb_realargs : int; @@ -901,9 +915,6 @@ let prove_rec_hyp fix_info = is_valid = fun _ -> true } - -exception Not_Rec - let generalize_non_dep hyp g = (* observe (str "rec id := " ++ Ppconstr.pr_id hyp); *) let hyps = [hyp] in @@ -911,17 +922,17 @@ let generalize_non_dep hyp g = let hyp_typ = pf_type_of g (mkVar hyp) in let to_revert,_ = Environ.fold_named_context_reverse (fun (clear,keep) (hyp,_,_ as decl) -> - if List.mem hyp hyps - or List.exists (Termops.occur_var_in_decl env hyp) keep - or Termops.occur_var env hyp hyp_typ - or Termops.is_section_variable hyp (* should be dangerous *) + if Id.List.mem hyp hyps + || List.exists (Termops.occur_var_in_decl env hyp) keep + || Termops.occur_var env hyp hyp_typ + || Termops.is_section_variable hyp (* should be dangerous *) then (clear,decl::keep) else (hyp::clear,keep)) ~init:([],[]) (pf_env g) in (* observe (str "to_revert := " ++ prlist_with_sep spc Ppconstr.pr_id to_revert); *) tclTHEN - ((* observe_tac "h_generalize" *) (h_generalize (List.map mkVar to_revert) )) + ((* observe_tac "h_generalize" *) (Simple.generalize (List.map mkVar to_revert) )) ((* observe_tac "thin" *) (thin to_revert)) g @@ -936,11 +947,9 @@ let generate_equation_lemma fnames f fun_num nb_params nb_args rec_args_num = (* observe (str "nb_args := " ++ str (string_of_int nb_args)); *) (* observe (str "nb_params := " ++ str (string_of_int nb_params)); *) (* observe (str "rec_args_num := " ++ str (string_of_int (rec_args_num + 1) )); *) - let f_def = Global.lookup_constant (destConst f) in + let f_def = Global.lookup_constant (fst (destConst f)) in let eq_lhs = mkApp(f,Array.init (nb_params + nb_args) (fun i -> mkRel(nb_params + nb_args - i))) in - let f_body = - force (Option.get (body_of_constant f_def)) - 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 fnames_with_params = @@ -955,20 +964,20 @@ let generate_equation_lemma fnames f fun_num nb_params nb_args rec_args_num = let eq_rhs = nf_betaiotazeta (mkApp(compose_lam params f_body_with_params_and_other_fun,Array.init (nb_params + nb_args) (fun i -> mkRel(nb_params + nb_args - i)))) in (* observe (str "eq_rhs " ++ pr_lconstr eq_rhs); *) let type_ctxt,type_of_f = decompose_prod_n_assum (nb_params + nb_args) - (Typeops.type_of_constant_type (Global.env()) f_def.const_type) in + (Typeops.type_of_constant_type (Global.env ()) (*FIXME*)f_def.const_type) in let eqn = mkApp(Lazy.force eq,[|type_of_f;eq_lhs;eq_rhs|]) in let lemma_type = it_mkProd_or_LetIn eqn type_ctxt in - let f_id = id_of_label (con_label (destConst f)) in + let f_id = Label.to_id (con_label (fst (destConst f))) in let prove_replacement = tclTHENSEQ [ - tclDO (nb_params + rec_args_num + 1) intro; + 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 [(* observe_tac "generalize_non_dep in generate_equation_lemma" *) (generalize_non_dep rec_id); - (* observe_tac "h_case" *) (h_case false (mkVar rec_id,Glob_term.NoBindings)); - intros_reflexivity] g + (* observe_tac "h_case" *) (Proofview.V82.of_tactic (simplest_case (mkVar rec_id))); + (Proofview.V82.of_tactic intros_reflexivity)] g ) ] in @@ -977,11 +986,12 @@ let generate_equation_lemma fnames f fun_num nb_params nb_args rec_args_num = Ensures by: obvious i*) (mk_equation_id f_id) - (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem)) - lemma_type - (fun _ _ -> ()); - Pfedit.by (prove_replacement); - Lemmas.save_named false + (Decl_kinds.Global, false, (Decl_kinds.Proof Decl_kinds.Theorem)) + Evd.empty + lemma_type + (Lemmas.mk_hook (fun _ _ -> ())); + ignore (Pfedit.by (Proofview.V82.tactic prove_replacement)); + Lemmas.save_proof (Vernacexpr.Proved(false,None)) @@ -989,10 +999,10 @@ let generate_equation_lemma fnames f fun_num nb_params nb_args rec_args_num = let do_replace params rec_arg_num rev_args_id f fun_num all_funs g = let equation_lemma = try - let finfos = find_Function_infos (destConst f) in + let finfos = find_Function_infos (fst (destConst f)) (*FIXME*) in mkConst (Option.get finfos.equation_lemma) with (Not_found | Option.IsNone as e) -> - let f_id = id_of_label (con_label (destConst f)) in + let f_id = Label.to_id (con_label (fst (destConst f))) in (*i The next call to mk_equation_id is valid since we will construct the lemma Ensures by: obvious i*) @@ -1001,12 +1011,12 @@ let do_replace params rec_arg_num rev_args_id f fun_num all_funs g = let _ = match e with | Option.IsNone -> - let finfos = find_Function_infos (destConst f) in + let finfos = find_Function_infos (fst (destConst f)) in update_Function {finfos with equation_lemma = Some (match Nametab.locate (qualid_of_ident equation_lemma_id) with ConstRef c -> c - | _ -> Util.anomaly "Not a constant" + | _ -> Errors.anomaly (Pp.str "Not a constant") ) } | _ -> () @@ -1016,12 +1026,12 @@ let do_replace params rec_arg_num rev_args_id f fun_num all_funs g = in let nb_intro_to_do = nb_prod (pf_concl g) in tclTHEN - (tclDO nb_intro_to_do intro) + (tclDO nb_intro_to_do (Proofview.V82.of_tactic intro)) ( fun g' -> let just_introduced = nLastDecls nb_intro_to_do g' in let just_introduced_id = List.map (fun (id,_,_) -> id) just_introduced in - tclTHEN (Equality.rewriteLR equation_lemma) (revert just_introduced_id) g' + tclTHEN (Proofview.V82.of_tactic (Equality.rewriteLR equation_lemma)) (revert just_introduced_id) g' ) g @@ -1034,7 +1044,7 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : (fun na -> let new_id = match na with - Name id -> fresh_id !avoid (string_of_id id) + Name id -> fresh_id !avoid (Id.to_string id) | Anonymous -> fresh_id !avoid "H" in avoid := new_id :: !avoid; @@ -1055,9 +1065,8 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : } in let get_body const = - match body_of_constant (Global.lookup_constant const) with - | Some b -> - let body = force b in + match Global.body_of_constant const with + | Some body -> Tacred.cbv_norm_flags (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA]) (Global.env ()) @@ -1137,7 +1146,7 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : typess in let pte_to_fix,rev_info = - list_fold_left_i + List.fold_left_i (fun i (acc_map,acc_info) (pte,_,_) -> let infos = info_array.(i) in let type_args,_ = decompose_prod infos.types in @@ -1175,14 +1184,14 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : in (* observe (str "binding " ++ Ppconstr.pr_id (Nameops.out_name pte) ++ *) (* str " to " ++ Ppconstr.pr_id info.name); *) - (Idmap.add (Nameops.out_name pte) info acc_map,info::acc_info) + (Id.Map.add (Nameops.out_name pte) info acc_map,info::acc_info) ) 0 - (Idmap.empty,[]) + (Id.Map.empty,[]) (List.rev princ_info.predicates) in pte_to_fix,List.rev rev_info - | _ -> Idmap.empty,[] + | _ -> Id.Map.empty,[] in let mk_fixes : tactic = let pre_info,infos = list_chop fun_num infos in @@ -1194,19 +1203,19 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : (fun fi -> fi.name,fi.idx + 1 ,fi.types) (pre_info@others_infos) in - if other_fix_infos = [] + if List.is_empty other_fix_infos then - (* observe_tac ("h_fix") *) (h_fix (Some this_fix_info.name) (this_fix_info.idx +1)) + (* observe_tac ("h_fix") *) (fix (Some this_fix_info.name) (this_fix_info.idx +1)) else - h_mutual_fix false this_fix_info.name (this_fix_info.idx + 1) - other_fix_infos - | _ -> anomaly "Not a valid information" + 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 - [ (* observe_tac "introducing params" *) (intros_using (List.rev_map id_of_decl princ_info.params)); - (* observe_tac "introducing predictes" *) (intros_using (List.rev_map id_of_decl princ_info.predicates)); - (* observe_tac "introducing branches" *) (intros_using (List.rev_map id_of_decl princ_info.branches)); + [ (* 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)); (* observe_tac "building fixes" *) mk_fixes; ] in @@ -1217,14 +1226,13 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : try let pte = try destVar pte - with e when Errors.noncritical e -> - anomaly "Property is not a variable" + with DestKO -> anomaly (Pp.str "Property is not a variable") in - let fix_info = Idmap.find pte ptes_to_fix in + let fix_info = Id.Map.find pte ptes_to_fix in let nb_args = fix_info.nb_realargs in tclTHENSEQ [ - (* observe_tac ("introducing args") *) (tclDO nb_args intro); + (* observe_tac ("introducing args") *) (tclDO nb_args (Proofview.V82.of_tactic intro)); (fun g -> (* replacement of the function by its body *) let args = nLastDecls nb_args g in let fix_body = fix_info.body_with_param in @@ -1258,7 +1266,7 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : build_proof interactive_proof (Array.to_list fnames) - (Idmap.map prove_rec_hyp ptes_to_fix) + (Id.Map.map prove_rec_hyp ptes_to_fix) in let prove_tac branches = let dyn_infos = @@ -1268,7 +1276,7 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : } in observe_tac "cleaning" (clean_goal_with_heq - (Idmap.map prove_rec_hyp ptes_to_fix) + (Id.Map.map prove_rec_hyp ptes_to_fix) do_prove dyn_infos) in @@ -1288,7 +1296,7 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : let nb_args = min (princ_info.nargs) (List.length ctxt) in tclTHENSEQ [ - tclDO nb_args intro; + tclDO nb_args (Proofview.V82.of_tactic intro); (fun g -> (* replacement of the function by its body *) let args = nLastDecls nb_args g in let args_id = List.map (fun (id,_,_) -> id) args in @@ -1307,12 +1315,12 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : in let fname = destConst (fst (decompose_app (List.hd (List.rev pte_args)))) in tclTHENSEQ - [unfold_in_concl [(Termops.all_occurrences, Names.EvalConstRef fname)]; + [unfold_in_concl [(Locus.AllOccurrences, Names.EvalConstRef (fst fname))]; let do_prove = build_proof interactive_proof (Array.to_list fnames) - (Idmap.map prove_rec_hyp ptes_to_fix) + (Id.Map.map prove_rec_hyp ptes_to_fix) in let prove_tac branches = let dyn_infos = @@ -1322,7 +1330,7 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : } in clean_goal_with_heq - (Idmap.map prove_rec_hyp ptes_to_fix) + (Id.Map.map prove_rec_hyp ptes_to_fix) do_prove dyn_infos in @@ -1346,15 +1354,13 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : (* Proof of principles of general functions *) -let h_id = Recdef.h_id -and 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 -and well_founded = Recdef.well_founded -and h_intros = Recdef.h_intros -and list_rewrite = Recdef.list_rewrite -and evaluable_of_global_reference = Recdef.evaluable_of_global_reference +(* 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 *) +(* and well_founded = Recdef.well_founded *) +(* and list_rewrite = Recdef.list_rewrite *) +(* and evaluable_of_global_reference = Recdef.evaluable_of_global_reference *) @@ -1362,7 +1368,7 @@ and evaluable_of_global_reference = Recdef.evaluable_of_global_reference let prove_with_tcc tcc_lemma_constr eqs : tactic = match !tcc_lemma_constr with - | None -> anomaly "No tcc proof !!" + | None -> anomaly (Pp.str "No tcc proof !!") | Some lemma -> fun gls -> (* let hid = next_ident_away_in_goal h_id (pf_ids_of_hyps gls) in *) @@ -1387,14 +1393,14 @@ let backtrack_eqs_until_hrec hrec eqs : tactic = fun gls -> let eqs = List.map mkVar eqs in let rewrite = - tclFIRST (List.map Equality.rewriteRL eqs ) + tclFIRST (List.map (fun x -> Proofview.V82.of_tactic (Equality.rewriteRL x)) eqs ) in let _,hrec_concl = decompose_prod (pf_type_of gls (mkVar hrec)) in - let f_app = array_last (snd (destApp hrec_concl)) in + let f_app = Array.last (snd (destApp hrec_concl)) in let f = (fst (destApp f_app)) in let rec backtrack : tactic = fun g -> - let f_app = array_last (snd (destApp (pf_concl g))) in + 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 | _ -> tclTHEN rewrite backtrack g @@ -1402,17 +1408,6 @@ let backtrack_eqs_until_hrec hrec eqs : tactic = backtrack gls - -let build_clause eqs = - { - Tacexpr.onhyps = - Some (List.map - (fun id -> (Glob_term.all_occurrences_expr, id), Termops.InHyp) - eqs - ); - Tacexpr.concl_occs = Glob_term.no_occurrences_expr - } - let rec rewrite_eqs_in_eqs eqs = match eqs with | [] -> tclIDTAC @@ -1422,8 +1417,9 @@ let rec rewrite_eqs_in_eqs eqs = (tclMAP (fun id gl -> observe_tac - (Format.sprintf "rewrite %s in %s " (string_of_id eq) (string_of_id id)) - (tclTRY (Equality.general_rewrite_in true Termops.all_occurrences true (* dep proofs also: *) true id (mkVar eq) false)) + (Format.sprintf "rewrite %s in %s " (Id.to_string eq) (Id.to_string id)) + (tclTRY (Proofview.V82.of_tactic (Equality.general_rewrite_in true Locus.AllOccurrences + true (* dep proofs also: *) true id (mkVar eq) false))) gl ) eqs @@ -1435,22 +1431,22 @@ let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic = (tclTHENSEQ [ backtrack_eqs_until_hrec hrec eqs; - (* observe_tac ("new_prove_with_tcc ( applying "^(string_of_id hrec)^" )" ) *) + (* observe_tac ("new_prove_with_tcc ( applying "^(Id.to_string hrec)^" )" ) *) (tclTHENS (* We must have exactly ONE subgoal !*) - (apply (mkVar hrec)) + (Proofview.V82.of_tactic (apply (mkVar hrec))) [ tclTHENSEQ [ - keep (tcc_hyps@eqs); - apply (Lazy.force acc_inv); + (Proofview.V82.of_tactic (keep (tcc_hyps@eqs))); + (Proofview.V82.of_tactic (apply (Lazy.force acc_inv))); (fun g -> if is_mes then - unfold_in_concl [(Termops.all_occurrences, evaluable_of_global_reference (delayed_force ltof_ref))] g + unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference (delayed_force ltof_ref))] g else tclIDTAC g ); observe_tac "rew_and_finish" (tclTHENLIST - [tclTRY(Recdef.list_rewrite false (List.map mkVar eqs)); + [tclTRY(list_rewrite false (List.map (fun v -> (mkVar v,true)) eqs)); observe_tac "rewrite_eqs_in_eqs" (rewrite_eqs_in_eqs eqs); (observe_tac "finishing using" ( @@ -1458,7 +1454,7 @@ let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic = Eauto.eauto_with_bases (true,5) [Evd.empty,Lazy.force refl_equal] - [Auto.Hint_db.empty empty_transparent_state false] + [Hints.Hint_db.empty empty_transparent_state false] ) ) ) @@ -1471,13 +1467,13 @@ let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic = let is_valid_hypothesis predicates_name = - let predicates_name = List.fold_right Idset.add predicates_name Idset.empty in + let predicates_name = List.fold_right Id.Set.add predicates_name Id.Set.empty in let is_pte typ = if isApp typ then let pte,_ = destApp typ in if isVar pte - then Idset.mem (destVar pte) predicates_name + then Id.Set.mem (destVar pte) predicates_name else false else false in @@ -1499,7 +1495,7 @@ let prove_principle_for_gen fun na -> let new_id = match na with - | Name id -> fresh_id !avoid (string_of_id id) + | Name id -> fresh_id !avoid (Id.to_string id) | Anonymous -> fresh_id !avoid "H" in avoid := new_id :: !avoid; @@ -1531,7 +1527,7 @@ let prove_principle_for_gen (* str "real_rec_arg_num := " ++ int real_rec_arg_num ++ fnl () ++ *) (* str "npost_rec_arg := " ++ int npost_rec_arg ); *) let (post_rec_arg,pre_rec_arg) = - Util.list_chop npost_rec_arg princ_info.args + Util.List.chop npost_rec_arg princ_info.args in let rec_arg_id = match List.rev post_rec_arg with @@ -1542,25 +1538,25 @@ let prove_principle_for_gen let subst_constrs = List.map (fun (na,_,_) -> mkVar (Nameops.out_name na)) (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.out_name (fresh_id (Name (Id.of_string "wf_R"))) in let acc_rec_arg_id = - Nameops.out_name (fresh_id (Name (id_of_string ("Acc_"^(string_of_id rec_arg_id))))) + Nameops.out_name (fresh_id (Name (Id.of_string ("Acc_"^(Id.to_string rec_arg_id))))) in let revert l = - tclTHEN (h_generalize (List.map mkVar l)) (clear l) + tclTHEN (Tactics.Simple.generalize (List.map mkVar l)) (clear l) in let fix_id = Nameops.out_name (fresh_id (Name hrec_id)) in let prove_rec_arg_acc g = ((* observe_tac "prove_rec_arg_acc" *) (tclCOMPLETE (tclTHEN - (assert_by (Name wf_thm_id) + (Proofview.V82.of_tactic (assert_by (Name wf_thm_id) (mkApp (delayed_force well_founded,[|input_type;relation|])) - (fun g -> (* observe_tac "prove wf" *) (tclCOMPLETE (wf_tac is_mes)) g)) + (Proofview.V82.tactic (fun g -> (* observe_tac "prove wf" *) (tclCOMPLETE (wf_tac is_mes)) g)))) ( (* observe_tac *) (* "apply wf_thm" *) - h_simplest_apply (mkApp(mkVar wf_thm_id,[|mkVar rec_arg_id|])) + Proofview.V82.of_tactic (Tactics.Simple.apply (mkApp(mkVar wf_thm_id,[|mkVar rec_arg_id|]))) ) ) ) @@ -1570,7 +1566,7 @@ let prove_principle_for_gen let args_ids = List.map (fun (na,_,_) -> Nameops.out_name na) princ_info.args in let lemma = match !tcc_lemma_ref with - | None -> anomaly ( "No tcc proof !!") + | None -> error "No tcc proof !!" | Some lemma -> lemma in (* let rec list_diff del_list check_list = *) @@ -1588,18 +1584,18 @@ let prove_principle_for_gen let hyps = pf_ids_of_hyps gls in let hid = next_ident_away_in_goal - (id_of_string "prov") + (Id.of_string "prov") hyps in tclTHENSEQ [ generalize [lemma]; - h_intro hid; - Elim.h_decompose_and (mkVar hid); + Proofview.V82.of_tactic (Simple.intro hid); + Proofview.V82.of_tactic (Elim.h_decompose_and (mkVar hid)); (fun g -> let new_hyps = pf_ids_of_hyps g in - tcc_list := List.rev (list_subtract new_hyps (hid::hyps)); - if !tcc_list = [] + tcc_list := List.rev (List.subtract Id.equal new_hyps (hid::hyps)); + if List.is_empty !tcc_list then begin tcc_list := [hid]; @@ -1617,22 +1613,22 @@ let prove_principle_for_gen (List.rev_map (fun (na,_,_) -> Nameops.out_name na) (princ_info.args@princ_info.branches@princ_info.predicates@princ_info.params) ); - (* observe_tac "" *) (assert_by + (* observe_tac "" *) Proofview.V82.of_tactic (assert_by (Name acc_rec_arg_id) (mkApp (delayed_force acc_rel,[|input_type;relation;mkVar rec_arg_id|])) - (prove_rec_arg_acc) + (Proofview.V82.tactic prove_rec_arg_acc) ); (* observe_tac "reverting" *) (revert (List.rev (acc_rec_arg_id::args_ids))); (* (fun g -> observe (Printer.pr_goal (sig_it g) ++ fnl () ++ *) (* str "fix arg num" ++ int (List.length args_ids + 1) ); tclIDTAC g); *) - (* observe_tac "h_fix " *) (h_fix (Some fix_id) (List.length args_ids + 1)); + (* observe_tac "h_fix " *) (fix (Some fix_id) (List.length args_ids + 1)); (* (fun g -> observe (Printer.pr_goal (sig_it g) ++ fnl() ++ pr_lconstr_env (pf_env g ) (pf_type_of g (mkVar fix_id) )); tclIDTAC g); *) h_intros (List.rev (acc_rec_arg_id::args_ids)); - Equality.rewriteLR (mkConst eq_ref); + Proofview.V82.of_tactic (Equality.rewriteLR (mkConst eq_ref)); (* observe_tac "finish" *) (fun gl' -> let body = let _,args = destApp (pf_concl gl') in - array_last args + Array.last args in let body_info rec_hyps = { @@ -1677,14 +1673,14 @@ let prove_principle_for_gen is_valid = is_valid_hypothesis predicates_names } in - let ptes_info : pte_info Idmap.t = + let ptes_info : pte_info Id.Map.t = List.fold_left (fun map pte_id -> - Idmap.add pte_id + Id.Map.add pte_id pte_info map ) - Idmap.empty + Id.Map.empty predicates_names in let make_proof rec_hyps = diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index 04fcc8d4..545f8931 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -1,58 +1,25 @@ open Printer +open Errors open Util open Term +open Vars +open Context open Namegen open Names -open Declarations +open Declareops open Pp open Entries -open Hiddentac -open Evd -open Tacmach -open Proof_type -open Tacticals open Tactics open Indfun_common open Functional_principles_proofs +open Misctypes exception Toberemoved_with_rel of int*constr exception Toberemoved - -let pr_elim_scheme el = - let env = Global.env () in - let msg = str "params := " ++ Printer.pr_rel_context env el.params in - let env = Environ.push_rel_context el.params env in - let msg = msg ++ fnl () ++ str "predicates := "++ Printer.pr_rel_context env el.predicates in - let env = Environ.push_rel_context el.predicates env in - let msg = msg ++ fnl () ++ str "branches := " ++ Printer.pr_rel_context env el.branches in - let env = Environ.push_rel_context el.branches env in - let msg = msg ++ fnl () ++ str "args := " ++ Printer.pr_rel_context env el.args in - let env = Environ.push_rel_context el.args env in - msg ++ fnl () ++ str "concl := " ++ pr_lconstr_env env el.concl - - let observe s = if do_observe () - then Pp.msgnl s - - -let pr_elim_scheme el = - let env = Global.env () in - let msg = str "params := " ++ Printer.pr_rel_context env el.params in - let env = Environ.push_rel_context el.params env in - let msg = msg ++ fnl () ++ str "predicates := "++ Printer.pr_rel_context env el.predicates in - let env = Environ.push_rel_context el.predicates env in - let msg = msg ++ fnl () ++ str "branches := " ++ Printer.pr_rel_context env el.branches in - let env = Environ.push_rel_context el.branches env in - let msg = msg ++ fnl () ++ str "args := " ++ Printer.pr_rel_context env el.args in - let env = Environ.push_rel_context el.args env in - msg ++ fnl () ++ str "concl := " ++ pr_lconstr_env env el.concl - - -let observe s = - if do_observe () - then Pp.msgnl s + then Pp.msg_debug s (* Transform an inductive induction principle into @@ -63,14 +30,14 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = let env = Global.env () in let env_with_params = Environ.push_rel_context princ_type_info.params env in let tbl = Hashtbl.create 792 in - let rec change_predicates_names (avoid:identifier list) (predicates:rel_context) : rel_context = + let rec change_predicates_names (avoid:Id.t list) (predicates:rel_context) : rel_context = match predicates with | [] -> [] |(Name x,v,t)::predicates -> let id = Namegen.next_ident_away x avoid in Hashtbl.add tbl id x; (Name id,v,t)::(change_predicates_names (id::avoid) predicates) - | (Anonymous,_,_)::_ -> anomaly "Anonymous property binder " + | (Anonymous,_,_)::_ -> anomaly (Pp.str "Anonymous property binder ") in let avoid = (Termops.ids_of_context env_with_params ) in let princ_type_info = @@ -91,7 +58,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = Nameops.out_name x,None,compose_prod real_args (mkSort new_sort) in let new_predicates = - list_map_i + List.map_i change_predicate_sort 0 princ_type_info.predicates @@ -99,16 +66,16 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = let env_with_params_and_predicates = List.fold_right Environ.push_named new_predicates env_with_params in let rel_as_kn = fst (match princ_type_info.indref with - | Some (Libnames.IndRef ind) -> ind + | Some (Globnames.IndRef ind) -> ind | _ -> error "Not a valid predicate" ) in let ptes_vars = List.map (fun (id,_,_) -> id) new_predicates in let is_pte = - let set = List.fold_right Idset.add ptes_vars Idset.empty in + let set = List.fold_right Id.Set.add ptes_vars Id.Set.empty in fun t -> match kind_of_term t with - | Var id -> Idset.mem id set + | Var id -> Id.Set.mem id set | _ -> false in let pre_princ = @@ -126,17 +93,17 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = let pre_princ = substl (List.map mkVar ptes_vars) pre_princ in let is_dom c = match kind_of_term c with - | Ind((u,_)) -> u = rel_as_kn - | Construct((u,_),_) -> u = rel_as_kn + | Ind((u,_),_) -> MutInd.equal u rel_as_kn + | Construct(((u,_),_),_) -> MutInd.equal u rel_as_kn | _ -> false in let get_fun_num c = match kind_of_term c with - | Ind(_,num) -> num - | Construct((_,num),_) -> num + | Ind((_,num),_) -> num + | Construct(((_,num),_),_) -> num | _ -> assert false in - let dummy_var = mkVar (id_of_string "________") in + 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); *) @@ -157,7 +124,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = compute_new_princ_type_for_binder remove mkLambda env x t b | Ind _ | Construct _ when is_dom pre_princ -> raise Toberemoved | App(f,args) when is_dom f -> - let var_to_be_removed = destRel (array_last args) in + let var_to_be_removed = destRel (Array.last args) in let num = get_fun_num f in raise (Toberemoved_with_rel (var_to_be_removed,mk_replacement pre_princ num args)) | App(f,args) -> @@ -191,7 +158,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = begin try let new_t,binders_to_remove_from_t = compute_new_princ_type remove env t in - let new_x : name = get_name (Termops.ids_of_context env) x in + let new_x : Name.t = get_name (Termops.ids_of_context env) x in let new_env = Environ.push_rel (x,None,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 @@ -220,7 +187,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = try let new_t,binders_to_remove_from_t = compute_new_princ_type remove env t in let new_v,binders_to_remove_from_v = compute_new_princ_type remove env v in - let new_x : name = get_name (Termops.ids_of_context env) x in + let new_x : Name.t = get_name (Termops.ids_of_context env) x in let new_env = Environ.push_rel (x,Some 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 @@ -255,7 +222,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = in let pre_res = replace_vars - (list_map_i (fun i id -> (id, mkRel i)) 1 ptes_vars) + (List.map_i (fun i id -> (id, mkRel i)) 1 ptes_vars) (lift (List.length ptes_vars) pre_res) in it_mkProd_or_LetIn @@ -271,8 +238,10 @@ let change_property_sort toSort princ princName = let princ_info = compute_elim_sig princ in let change_sort_in_predicate (x,v,t) = (x,None, - let args,_ = decompose_prod t in - compose_prod args (mkSort toSort) + let args,ty = decompose_prod t in + let s = destSort ty in + Global.add_constraints (Univ.enforce_leq (univ_of_sort toSort) (univ_of_sort s) Univ.Constraint.empty); + compose_prod args (mkSort toSort) ) in let princName_as_constr = Constrintern.global_reference princName in @@ -288,23 +257,6 @@ let change_property_sort toSort princ princName = ) princ_info.params - -let pp_dur time time' = - str (string_of_float (System.time_difference time time')) - -(* let qed () = save_named true *) -let defined () = - try - Lemmas.save_named false - with - | UserError("extract_proof",msg) -> - Util.errorlabstrm - "defined" - ((try - str "On goal : " ++ fnl () ++ pr_open_subgoals () ++ fnl () - with e when Errors.noncritical e -> mt () - ) ++msg) - let build_functional_principle 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 @@ -319,23 +271,25 @@ let build_functional_principle interactive_proof old_princ_type sorts funs i pro (* Pp.msgnl (str "computing principle type := " ++ System.fmt_time_difference time1 time2); *) observe (str "new_principle_type : " ++ pr_lconstr new_principle_type); let new_princ_name = - next_ident_away_in_goal (id_of_string "___________princ_________") [] + next_ident_away_in_goal (Id.of_string "___________princ_________") [] in + let hook = Lemmas.mk_hook (hook new_principle_type) in begin Lemmas.start_proof new_princ_name - (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem)) - new_principle_type - (hook new_principle_type) + (Decl_kinds.Global,false,(Decl_kinds.Proof Decl_kinds.Theorem)) + (*FIXME*) Evd.empty + new_principle_type + hook ; (* let _tim1 = System.get_time () in *) - Pfedit.by (proof_tac (Array.map mkConst funs) mutr_nparams); + ignore (Pfedit.by (Proofview.V82.tactic (proof_tac (Array.map mkConst funs) mutr_nparams))); (* let _tim2 = System.get_time () in *) (* begin *) (* let dur1 = System.time_difference tim1 tim2 in *) (* Pp.msgnl (str ("Time to compute proof: ") ++ str (string_of_float dur1)); *) (* end; *) - get_proof_clean true + get_proof_clean true, Ephemeron.create hook end @@ -347,7 +301,7 @@ let generate_functional_principle try let f = funs.(i) in - let type_sort = Termops.new_sort_in_family InType in + let type_sort = Universes.new_sort_in_family InType in let new_sorts = match sorts with | None -> Array.make (Array.length funs) (type_sort) @@ -357,42 +311,35 @@ let generate_functional_principle match new_princ_name with | Some (id) -> id,id | None -> - let id_of_f = id_of_label (con_label f) in + let id_of_f = Label.to_id (con_label f) in id_of_f,Indrec.make_elimination_ident id_of_f (family_of_sort type_sort) in let names = ref [new_princ_name] in - let hook new_principle_type _ _ = - if sorts = None + let hook new_principle_type _ _ = + if Option.is_empty sorts then - (* let id_of_f = id_of_label (con_label f) in *) + (* let id_of_f = Label.to_id (con_label f) in *) let register_with_sort fam_sort = - let s = Termops.new_sort_in_family fam_sort in + let s = Universes.new_sort_in_family fam_sort in let name = Indrec.make_elimination_ident base_new_princ_name fam_sort in let value = change_property_sort s new_principle_type new_princ_name in (* Pp.msgnl (str "new principle := " ++ pr_lconstr value); *) - let ce = - { const_entry_body = value; - const_entry_secctx = None; - const_entry_type = None; - const_entry_opaque = false } - in + let ce = Declare.definition_entry value in (*FIXME, no poly, nothing *) ignore( Declare.declare_constant name (Entries.DefinitionEntry ce, - Decl_kinds.IsDefinition (Decl_kinds.Scheme) - ) + Decl_kinds.IsDefinition (Decl_kinds.Scheme)) ); - Flags.if_verbose - (fun id -> Pp.msgnl (Ppconstr.pr_id id ++ str " is defined")) - name; + Declare.definition_message name; names := name :: !names in register_with_sort InProp; register_with_sort InSet in - let (id,(entry,g_kind,hook)) = - build_functional_principle interactive_proof old_princ_type new_sorts funs i proof_tac hook + let ((id,(entry,g_kind)),hook) = + build_functional_principle interactive_proof old_princ_type new_sorts funs i + proof_tac hook in (* Pr 1278 : Don't forget to close the goal if an error is raised !!!! @@ -403,10 +350,10 @@ let generate_functional_principle begin try let id = Pfedit.get_current_proof_name () in - let s = string_of_id id in + let s = Id.to_string id in let n = String.length "___________princ_________" in if String.length s >= n - then if String.sub s 0 n = "___________princ_________" + then if String.equal (String.sub s 0 n) "___________princ_________" then Pfedit.delete_current_proof () else () else () @@ -420,26 +367,25 @@ let generate_functional_principle exception Not_Rec let get_funs_constant mp dp = - let rec get_funs_constant const e : (Names.constant*int) array = + let get_funs_constant const e : (Names.constant*int) array = match kind_of_term ((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 = make_con mp dp (Label.of_id id) in const,i | Anonymous -> - anomaly "Anonymous fix" + anomaly (Pp.str "Anonymous fix") ) na | _ -> [|const,0|] in function const -> let find_constant_body const = - match body_of_constant (Global.lookup_constant const) with - | Some b -> - let body = force b in + match Global.body_of_constant const with + | Some body -> let body = Tacred.cbv_norm_flags (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA]) (Global.env ()) @@ -462,7 +408,7 @@ 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) -> n1 = n2 && eq_constr c1 c2) first_params 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" ) l_params @@ -474,14 +420,15 @@ let get_funs_constant mp dp = match kind_of_term body with | Fix((idxs,_),(na,ta,ca)) -> (idxs,na,ta,ca) | _ -> - if is_first && (List.length l_bodies = 1) + if is_first && Int.equal (List.length l_bodies) 1 then raise Not_Rec else error "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) = - ia1 = ia2 && na1 = na2 && array_equal eq_constr ta1 ta2 && array_equal eq_constr ca1 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 in if not (eq_infos first_infos (extract_info false body)) then error "Not a mutal recursive block" @@ -494,7 +441,7 @@ let get_funs_constant mp dp = exception No_graph_found exception Found_type of int -let make_scheme (fas : (constant*Glob_term.glob_sort) list) : Entries.definition_entry list = +let make_scheme (fas : (constant*glob_sort) list) : Entries.definition_entry list = let env = Global.env () and sigma = Evd.empty in let funs = List.map fst fas in @@ -513,26 +460,27 @@ let make_scheme (fas : (constant*Glob_term.glob_sort) list) : Entries.definition let funs_indexes = let this_block_funs_indexes = Array.to_list this_block_funs_indexes in List.map - (function const -> List.assoc const this_block_funs_indexes) + (function cst -> List.assoc_f Constant.equal cst this_block_funs_indexes) funs in let ind_list = List.map (fun (idx) -> let ind = first_fun_kn,idx in - ind,true,prop_sort + (ind,Univ.Instance.empty)(*FIXME*),true,prop_sort ) funs_indexes in + let sigma, schemes = + Indrec.build_mutual_induction_scheme env sigma ind_list + in let l_schemes = - List.map - (Typing.type_of env sigma) - (Indrec.build_mutual_induction_scheme env sigma ind_list) + List.map (Typing.type_of env sigma) schemes in let i = ref (-1) in let sorts = List.rev_map (fun (_,x) -> - Termops.new_sort_in_family (Pretyping.interp_elimination_sort x) + Universes.new_sort_in_family (Pretyping.interp_elimination_sort x) ) fas in @@ -540,9 +488,9 @@ let make_scheme (fas : (constant*Glob_term.glob_sort) list) : Entries.definition let first_type,other_princ_types = match l_schemes with s::l_schemes -> s,l_schemes - | _ -> anomaly "" + | _ -> anomaly (Pp.str "") in - let (_,(const,_,_)) = + let ((_,(const,_)),_) = try build_functional_principle false first_type @@ -556,10 +504,10 @@ let make_scheme (fas : (constant*Glob_term.glob_sort) list) : Entries.definition begin try let id = Pfedit.get_current_proof_name () in - let s = string_of_id id in + let s = Id.to_string id in let n = String.length "___________princ_________" in if String.length s >= n - then if String.sub s 0 n = "___________princ_________" + then if String.equal (String.sub s 0 n) "___________princ_________" then Pfedit.delete_current_proof () else () else () @@ -574,13 +522,13 @@ let make_scheme (fas : (constant*Glob_term.glob_sort) list) : Entries.definition let finfos = find_Function_infos this_block_funs.(0) in try let equation = Option.get finfos.equation_lemma in - Declarations.is_opaque (Global.lookup_constant equation) + Declareops.is_opaque (Global.lookup_constant equation) with Option.IsNone -> (* non recursive definition *) false in let const = {const with const_entry_opaque = opacity } in (* The others are just deduced *) - if other_princ_types = [] + if List.is_empty other_princ_types then [const] else @@ -590,7 +538,7 @@ let make_scheme (fas : (constant*Glob_term.glob_sort) list) : Entries.definition List.map (compute_new_princ_type_from_rel funs sorts) other_princ_types in let first_princ_body,first_princ_type = const.Entries.const_entry_body, const.Entries.const_entry_type in - let ctxt,fix = decompose_lam_assum first_princ_body in (* the principle has for forall ...., fix .*) + let ctxt,fix = decompose_lam_assum (fst(fst(Future.force first_princ_body))) in (* the principle has for forall ...., fix .*) let (idxs,_),(_,ta,_ as decl) = destFix fix in let other_result = List.map (* we can now compute the other principles *) @@ -616,7 +564,7 @@ let make_scheme (fas : (constant*Glob_term.glob_sort) list) : Entries.definition (* If we reach this point, the two principle are not mutually recursive We fall back to the previous method *) - let (_,(const,_,_)) = + let ((_,(const,_)),_) = build_functional_principle false (List.nth other_princ_types (!i - 1)) @@ -632,7 +580,8 @@ let make_scheme (fas : (constant*Glob_term.glob_sort) list) : Entries.definition Termops.it_mkLambda_or_LetIn (mkFix((idxs,i),decl)) ctxt in {const with - Entries.const_entry_body = princ_body; + Entries.const_entry_body = + (Future.from_val (Term_typing.mk_pure_proof princ_body)); Entries.const_entry_type = Some scheme_type } ) @@ -648,11 +597,11 @@ let build_scheme fas = (fun (_,f,sort) -> let f_as_constant = try - match Nametab.global f with - | Libnames.ConstRef c -> c - | _ -> Util.error "Functional Scheme can only be used with functions" + match Smartlocate.global_with_alias f with + | Globnames.ConstRef c -> c + | _ -> Errors.error "Functional Scheme can only be used with functions" with Not_found -> - Util.error ("Cannot find "^ Libnames.string_of_reference f) + Errors.error ("Cannot find "^ Libnames.string_of_reference f) in (f_as_constant,sort) ) @@ -665,8 +614,7 @@ let build_scheme fas = (Declare.declare_constant princ_id (Entries.DefinitionEntry def_entry,Decl_kinds.IsProof Decl_kinds.Theorem)); - Flags.if_verbose - (fun id -> Pp.msgnl (Ppconstr.pr_id id ++ str " is defined")) princ_id + Declare.definition_message princ_id ) fas bodies_types; @@ -681,10 +629,10 @@ let build_case_scheme fa = (* Constrintern.global_reference id *) (* in *) let funs = (fun (_,f,_) -> - try Libnames.constr_of_global (Nametab.global f) + try fst (Universes.unsafe_constr_of_global (Smartlocate.global_with_alias f)) with Not_found -> - Util.error ("Cannot find "^ Libnames.string_of_reference f)) fa in - let first_fun = destConst funs in + Errors.error ("Cannot find "^ Libnames.string_of_reference f)) fa in + let first_fun,u = destConst funs in let funs_mp,funs_dp,_ = Names.repr_con first_fun in let first_fun_kn = try fst (find_Function_infos first_fun).graph_ind with Not_found -> raise No_graph_found in @@ -696,16 +644,18 @@ let build_case_scheme fa = let prop_sort = InProp in let funs_indexes = let this_block_funs_indexes = Array.to_list this_block_funs_indexes in - List.assoc (destConst funs) this_block_funs_indexes + List.assoc_f Constant.equal (fst (destConst funs)) this_block_funs_indexes in let ind_fun = let ind = first_fun_kn,funs_indexes in - ind,prop_sort + (ind,Univ.Instance.empty)(*FIXME*),prop_sort in - let scheme_type = (Typing.type_of env sigma ) ((fun (ind,sf) -> Indrec.build_case_analysis_scheme_default env sigma ind sf) ind_fun) in + let sigma, scheme = + (fun (ind,sf) -> Indrec.build_case_analysis_scheme_default env sigma ind sf) ind_fun in + let scheme_type = (Typing.type_of env sigma ) scheme in let sorts = (fun (_,_,x) -> - Termops.new_sort_in_family (Pretyping.interp_elimination_sort x) + Universes.new_sort_in_family (Pretyping.interp_elimination_sort x) ) fa in @@ -722,6 +672,6 @@ let build_case_scheme fa = (Some princ_name) this_block_funs 0 - (prove_princ_for_struct false 0 [|destConst funs|]) + (prove_princ_for_struct false 0 [|fst (destConst funs)|]) in () diff --git a/plugins/funind/functional_principles_types.mli b/plugins/funind/functional_principles_types.mli index 1c02c16e..a16b834f 100644 --- a/plugins/funind/functional_principles_types.mli +++ b/plugins/funind/functional_principles_types.mli @@ -1,6 +1,6 @@ open Names open Term - +open Misctypes val generate_functional_principle : (* do we accept interactive proving *) @@ -10,7 +10,7 @@ val generate_functional_principle : (* *) sorts array option -> (* Name of the new principle *) - (identifier) option -> + (Id.t) option -> (* the compute functions to use *) constant array -> (* We prove the nth- principle *) @@ -27,8 +27,8 @@ val compute_new_princ_type_from_rel : constr array -> sorts array -> exception No_graph_found -val make_scheme : (constant*Glob_term.glob_sort) list -> Entries.definition_entry list +val make_scheme : (constant*glob_sort) list -> Entries.definition_entry list -val build_scheme : (identifier*Libnames.reference*Glob_term.glob_sort) list -> unit -val build_case_scheme : (identifier*Libnames.reference*Glob_term.glob_sort) -> unit +val build_scheme : (Id.t*Libnames.reference*glob_sort) list -> unit +val build_case_scheme : (Id.t*Libnames.reference*glob_sort) -> unit diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4 index ffaa2208..fd48ab59 100644 --- a/plugins/funind/g_indfun.ml4 +++ b/plugins/funind/g_indfun.ml4 @@ -1,35 +1,38 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* hov 1 (Ppconstr.pr_id id ++ str " := " ++ cut () ++ prc c) - | loc, Glob_term.AnonHyp n, c -> hov 1 (int n ++ str " := " ++ cut () ++ prc c) + | 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 - | Glob_term.ImplicitBindings l -> + | ImplicitBindings l -> brk (1,1) ++ str "with" ++ brk (1,1) ++ - Util.prlist_with_sep spc prc l - | Glob_term.ExplicitBindings l -> + pr_sequence prc l + | ExplicitBindings l -> brk (1,1) ++ str "with" ++ brk (1,1) ++ - Util.prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l - | Glob_term.NoBindings -> mt () + 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) @@ -69,18 +72,23 @@ END TACTIC EXTEND newfuninv [ "functional" "inversion" quantified_hypothesis(hyp) reference_opt(fname) ] -> [ - Invfun.invfun hyp fname + Proofview.V82.tactic (Invfun.invfun hyp fname) ] END -let pr_intro_as_pat prc _ _ pat = +let pr_intro_as_pat _prc _ _ pat = match pat with - | Some pat -> spc () ++ str "as" ++ spc () ++ pr_intro_pattern pat + | Some pat -> + spc () ++ str "as" ++ spc () ++ (* Miscprint.pr_intro_pattern prc pat *) + str"" | None -> mt () +let out_disjunctive = function + | loc, IntroAction (IntroOrAndPattern l) -> (loc,l) + | _ -> Errors.error "Disjunctive or conjunctive intro pattern expected." -ARGUMENT EXTEND with_names TYPED AS intro_pattern_opt PRINTED BY pr_intro_as_pat +ARGUMENT EXTEND with_names TYPED AS simple_intropattern_opt PRINTED BY pr_intro_as_pat | [ "as" simple_intropattern(ipat) ] -> [ Some ipat ] | [] ->[ None ] END @@ -96,7 +104,7 @@ TACTIC EXTEND newfunind | [c] -> c | c::cl -> applist(c,cl) in - Extratactics.onSomeWithHoles (fun x -> functional_induction true c x pat) princl ] + Extratactics.onSomeWithHoles (fun x -> Proofview.V82.tactic (functional_induction true c x (Option.map out_disjunctive pat))) princl ] END (***** debug only ***) TACTIC EXTEND snewfunind @@ -107,11 +115,11 @@ TACTIC EXTEND snewfunind | [c] -> c | c::cl -> applist(c,cl) in - Extratactics.onSomeWithHoles (fun x -> functional_induction false c x pat) princl ] + Extratactics.onSomeWithHoles (fun x -> Proofview.V82.tactic (functional_induction false c x (Option.map out_disjunctive pat))) princl ] END -let pr_constr_coma_sequence prc _ _ = Util.prlist_with_sep Util.pr_comma prc +let pr_constr_coma_sequence prc _ _ = prlist_with_sep pr_comma prc ARGUMENT EXTEND constr_coma_sequence' TYPED AS constr_list @@ -133,34 +141,37 @@ module Gram = Pcoq.Gram module Vernac = Pcoq.Vernac_ module Tactic = Pcoq.Tactic -module FunctionGram = -struct - let gec s = Gram.entry_create ("Function."^s) - (* types *) - let function_rec_definition_loc : (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) located Gram.entry = gec "function_rec_definition_loc" -end -open FunctionGram +type function_rec_definition_loc_argtype = (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) Loc.located + +let (wit_function_rec_definition_loc : function_rec_definition_loc_argtype Genarg.uniform_genarg_type) = + Genarg.create_arg None "function_rec_definition_loc" + +let function_rec_definition_loc = + Pcoq.create_generic_entry "function_rec_definition_loc" (Genarg.rawwit wit_function_rec_definition_loc) GEXTEND Gram GLOBAL: function_rec_definition_loc ; function_rec_definition_loc: - [ [ g = Vernac.rec_definition -> loc, g ]] + [ [ g = Vernac.rec_definition -> !@loc, g ]] ; - END -type 'a function_rec_definition_loc_argtype = ((Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) located, 'a) Genarg.abstract_argument_type +END -let (wit_function_rec_definition_loc : Genarg.tlevel function_rec_definition_loc_argtype), - (globwit_function_rec_definition_loc : Genarg.glevel function_rec_definition_loc_argtype), - (rawwit_function_rec_definition_loc : Genarg.rlevel function_rec_definition_loc_argtype) = - Genarg.create_arg None "function_rec_definition_loc" +(* TASSI: n'importe quoi ! *) VERNAC COMMAND EXTEND Function - ["Function" ne_function_rec_definition_loc_list_sep(recsl,"with")] -> - [ - do_generate_principle false (List.map snd recsl); - - ] + ["Function" ne_function_rec_definition_loc_list_sep(recsl,"with")] + => [ let hard = List.exists (function + | _,((_,(_,(CMeasureRec _|CWfRec _)),_,_,_),_) -> true + | _,((_,(_,CStructRec),_,_,_),_) -> false) recsl in + match + Vernac_classifier.classify_vernac + (Vernacexpr.VernacFixpoint(None, List.map snd recsl)) + with + | Vernacexpr.VtSideff ids, _ when hard -> + Vernacexpr.(VtStartProof ("Classic", GuaranteesOpacity, ids), VtLater) + | x -> x ] + -> [ do_generate_principle false (List.map snd recsl) ] END let pr_fun_scheme_arg (princ_name,fun_name,s) = @@ -175,23 +186,25 @@ END let warning_error names e = - let e = Cerrors.process_vernac_interp_error e in + let (e, _) = Cerrors.process_vernac_interp_error (e, Exninfo.null) in match e with | Building_graph e -> Pp.msg_warning (str "Cannot define graph(s) for " ++ - h 1 (prlist_with_sep (fun _ -> str","++spc ()) Libnames.pr_reference names) ++ + h 1 (pr_enum Libnames.pr_reference names) ++ if do_observe () then (spc () ++ Errors.print e) else mt ()) | Defining_principle e -> Pp.msg_warning (str "Cannot define principle(s) for "++ - h 1 (prlist_with_sep (fun _ -> str","++spc ()) Libnames.pr_reference names) ++ + h 1 (pr_enum Libnames.pr_reference names) ++ if do_observe () then Errors.print e else mt ()) | _ -> raise e VERNAC COMMAND EXTEND NewFunctionalScheme - ["Functional" "Scheme" ne_fun_scheme_arg_list_sep(fas,"with") ] -> + ["Functional" "Scheme" ne_fun_scheme_arg_list_sep(fas,"with") ] + => [ Vernacexpr.VtSideff(List.map pi1 fas), Vernacexpr.VtLater ] + -> [ begin try @@ -202,13 +215,13 @@ VERNAC COMMAND EXTEND NewFunctionalScheme | (_,fun_name,_)::_ -> begin begin - make_graph (Nametab.global fun_name) + make_graph (Smartlocate.global_with_alias fun_name) end ; try Functional_principles_types.build_scheme fas with Functional_principles_types.No_graph_found -> - Util.error ("Cannot generate induction principle(s)") - | e when Errors.noncritical e -> + Errors.error ("Cannot generate induction principle(s)") + | e when Errors.noncritical e -> let names = List.map (fun (_,na,_) -> na) fas in warning_error names e @@ -225,15 +238,14 @@ END (***** debug only ***) VERNAC COMMAND EXTEND NewFunctionalCase - ["Functional" "Case" fun_scheme_arg(fas) ] -> - [ - Functional_principles_types.build_case_scheme fas - ] + ["Functional" "Case" fun_scheme_arg(fas) ] + => [ Vernacexpr.VtSideff[pi1 fas], Vernacexpr.VtLater ] + -> [ Functional_principles_types.build_case_scheme fas ] END (***** debug only ***) -VERNAC COMMAND EXTEND GenerateGraph -["Generate" "graph" "for" reference(c)] -> [ make_graph (Nametab.global c) ] +VERNAC COMMAND EXTEND GenerateGraph CLASSIFIED AS QUERY +["Generate" "graph" "for" reference(c)] -> [ make_graph (Smartlocate.global_with_alias c) ] END @@ -273,7 +285,7 @@ let constr_head_match u t= if isApp u then let uhd,args= destApp u in - uhd=t + Constr.equal uhd t else false (** [hdMatchSub inu t] returns the list of occurrences of [t] in @@ -296,22 +308,25 @@ let rec hdMatchSub inu (test: constr -> bool) : fapp_info list = else let f,args = decompose_app inu in let freeset = Termops.free_rels inu in - let max_rel = try Util.Intset.max_elt freeset with Not_found -> -1 in - {fname = f; largs = args; free = Util.Intset.is_empty freeset; + let max_rel = try Int.Set.max_elt freeset with Not_found -> -1 in + {fname = f; largs = args; free = Int.Set.is_empty freeset; max_rel = max_rel; onlyvars = List.for_all isVar args } ::subres +let make_eq () = +(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq ()) + let mkEq typ c1 c2 = - mkApp (Coqlib.build_coq_eq(),[| typ; c1; c2|]) + mkApp (make_eq(),[| typ; c1; c2|]) let poseq_unsafe idunsafe cstr gl = let typ = Tacmach.pf_type_of gl cstr in tclTHEN - (Tactics.letin_tac None (Name idunsafe) cstr None allHypsAndConcl) + (Proofview.V82.of_tactic (Tactics.letin_tac None (Name idunsafe) cstr None Locusops.allHypsAndConcl)) (tclTHENFIRST - (Tactics.assert_tac Anonymous (mkEq typ (mkVar idunsafe) cstr)) - Tactics.reflexivity) + (Proofview.V82.of_tactic (Tactics.assert_before Anonymous (mkEq typ (mkVar idunsafe) cstr))) + (Proofview.V82.of_tactic Tactics.reflexivity)) gl @@ -357,7 +372,7 @@ let poseq_list_ids lcstr gl = let find_fapp (test:constr -> bool) g : fapp_info list = let pre_res = hdMatchSub (Tacmach.pf_concl g) test in let res = - List.fold_right (fun x acc -> if List.mem x acc then acc else x::acc) pre_res [] in + List.fold_right (List.add_set Pervasives.(=)) pre_res [] in (prlistconstr (List.map (fun x -> applist (x.fname,x.largs)) res); res) @@ -367,7 +382,7 @@ let find_fapp (test:constr -> bool) g : fapp_info list = an occurence of function [id] in the conclusion of goal [g]. If [id]=[None] then calls to any function are selected. In any case [heuristic] is used to select the most pertinent occurrence. *) -let finduction (oid:identifier option) (heuristic: fapp_info list -> fapp_info list) +let finduction (oid:Id.t option) (heuristic: fapp_info list -> fapp_info list) (nexttac:Proof_type.tactic) g = let test = match oid with | Some id -> @@ -377,7 +392,7 @@ let finduction (oid:identifier option) (heuristic: fapp_info list -> fapp_info l let info_list = find_fapp test g in let ordered_info_list = heuristic info_list in prlistconstr (List.map (fun x -> applist (x.fname,x.largs)) ordered_info_list); - if List.length ordered_info_list = 0 then Util.error "function not found in goal\n"; + if List.is_empty ordered_info_list then Errors.error "function not found in goal\n"; let taclist: Proof_type.tactic list = List.map (fun info -> @@ -419,10 +434,10 @@ TACTIC EXTEND finduction ["finduction" ident(id) natural_opt(oi)] -> [ match oi with - | Some(n) when n<=0 -> Util.error "numerical argument must be > 0" + | Some(n) when n<=0 -> Errors.error "numerical argument must be > 0" | _ -> let heuristic = chose_heuristic oi in - finduction (Some id) heuristic tclIDTAC + Proofview.V82.tactic (finduction (Some id) heuristic tclIDTAC) ] END @@ -432,13 +447,13 @@ TACTIC EXTEND fauto [ "fauto" tactic(tac)] -> [ let heuristic = chose_heuristic None in - finduction None heuristic (Tacinterp.eval_tactic tac) + Proofview.V82.tactic (finduction None heuristic (Proofview.V82.of_tactic (Tacinterp.eval_tactic tac))) ] | [ "fauto" ] -> [ let heuristic = chose_heuristic None in - finduction None heuristic tclIDTAC + Proofview.V82.tactic (finduction None heuristic tclIDTAC) ] END @@ -446,31 +461,31 @@ END TACTIC EXTEND poseq [ "poseq" ident(x) constr(c) ] -> - [ poseq x c ] + [ Proofview.V82.tactic (poseq x c) ] END -VERNAC COMMAND EXTEND Showindinfo +VERNAC COMMAND EXTEND Showindinfo CLASSIFIED AS QUERY [ "showindinfo" ident(x) ] -> [ Merge.showind x ] END -VERNAC COMMAND EXTEND MergeFunind +VERNAC COMMAND EXTEND MergeFunind CLASSIFIED AS SIDEFF [ "Mergeschemes" "(" ident(id1) ne_ident_list(cl1) ")" "with" "(" ident(id2) ne_ident_list(cl2) ")" "using" ident(id) ] -> [ - let f1 = Constrintern.interp_constr Evd.empty (Global.env()) - (CRef (Libnames.Ident (Util.dummy_loc,id1))) in - let f2 = Constrintern.interp_constr Evd.empty (Global.env()) - (CRef (Libnames.Ident (Util.dummy_loc,id2))) in + let f1,ctx = Constrintern.interp_constr (Global.env()) Evd.empty + (CRef (Libnames.Ident (Loc.ghost,id1),None)) in + let f2,ctx' = Constrintern.interp_constr (Global.env()) Evd.empty + (CRef (Libnames.Ident (Loc.ghost,id2),None)) in let f1type = Typing.type_of (Global.env()) Evd.empty f1 in let f2type = Typing.type_of (Global.env()) Evd.empty f2 in let ar1 = List.length (fst (decompose_prod f1type)) in let ar2 = List.length (fst (decompose_prod f2type)) in let _ = - if ar1 <> List.length cl1 then - Util.error ("not the right number of arguments for " ^ string_of_id id1) in + if not (Int.equal ar1 (List.length cl1)) then + Errors.error ("not the right number of arguments for " ^ Id.to_string id1) in let _ = - if ar2 <> List.length cl2 then - Util.error ("not the right number of arguments for " ^ string_of_id id2) in + if not (Int.equal ar2 (List.length cl2)) then + Errors.error ("not the right number of arguments for " ^ Id.to_string id2) in Merge.merge id1 id2 (Array.of_list cl1) (Array.of_list cl2) id ] END diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index b9e0e62a..a2577e2b 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -2,26 +2,30 @@ open Printer open Pp open Names open Term +open Vars open Glob_term -open Libnames +open Glob_ops +open Globnames open Indfun_common +open Errors open Util open Glob_termops +open Misctypes let observe strm = if do_observe () - then Pp.msgnl strm + then Pp.msg_debug strm else () -let observennl strm = +(*let observennl strm = if do_observe () then Pp.msg strm - else () + else ()*) type binder_type = - | Lambda of name - | Prod of name - | LetIn of name + | Lambda of Name.t + | Prod of Name.t + | LetIn of Name.t type glob_context = (binder_type*glob_constr) list @@ -54,7 +58,7 @@ type 'a build_entry_pre_return = type 'a build_entry_return = { result : 'a build_entry_pre_return list; - to_avoid : identifier list + to_avoid : Id.t list } (* @@ -86,7 +90,7 @@ let combine_results in (* and then we flatten the map *) { result = List.concat pre_result; - to_avoid = list_union res1.to_avoid res2.to_avoid + to_avoid = List.union Id.equal res1.to_avoid res2.to_avoid } @@ -111,9 +115,9 @@ let ids_of_binder = function let rec change_vars_in_binder mapping = function [] -> [] | (bt,t)::l -> - let new_mapping = List.fold_right Idmap.remove (ids_of_binder bt) mapping in + let new_mapping = List.fold_right Id.Map.remove (ids_of_binder bt) mapping in (bt,change_vars mapping t):: - (if idmap_is_empty new_mapping + (if Id.Map.is_empty new_mapping then l else change_vars_in_binder new_mapping l ) @@ -122,7 +126,7 @@ 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 List.mem x_id (ids_of_binder bt) + if Id.List.mem x_id (ids_of_binder bt) then l else replace_var_by_term_in_binder x_id term l @@ -130,28 +134,28 @@ let add_bt_names bt = List.append (ids_of_binder bt) let apply_args ctxt body args = let need_convert_id avoid id = - List.exists (is_free_in id) args || List.mem id avoid + List.exists (is_free_in id) args || Id.List.mem id avoid in let need_convert avoid bt = List.exists (need_convert_id avoid) (ids_of_binder bt) in - let next_name_away (na:name) (mapping: identifier Idmap.t) (avoid: identifier list) = + let next_name_away (na:Name.t) (mapping: Id.t Id.Map.t) (avoid: Id.t list) = match na with - | Name id when List.mem id avoid -> + | Name id when Id.List.mem id avoid -> let new_id = Namegen.next_ident_away id avoid in - Name new_id,Idmap.add id new_id mapping,new_id::avoid + Name new_id,Id.Map.add id new_id mapping,new_id::avoid | _ -> na,mapping,avoid in - let next_bt_away bt (avoid:identifier list) = + let next_bt_away bt (avoid:Id.t list) = match bt with | LetIn na -> - let new_na,mapping,new_avoid = next_name_away na Idmap.empty avoid in + let new_na,mapping,new_avoid = next_name_away na Id.Map.empty avoid in LetIn new_na,mapping,new_avoid | Prod na -> - let new_na,mapping,new_avoid = next_name_away na Idmap.empty avoid in + let new_na,mapping,new_avoid = next_name_away na Id.Map.empty avoid in Prod new_na,mapping,new_avoid | Lambda na -> - let new_na,mapping,new_avoid = next_name_away na Idmap.empty avoid in + let new_na,mapping,new_avoid = next_name_away na Id.Map.empty avoid in Lambda new_na,mapping,new_avoid in let rec do_apply avoid ctxt body args = @@ -170,7 +174,7 @@ let apply_args ctxt body args = let new_avoid = id::avoid in let new_id = Namegen.next_ident_away id new_avoid in let new_avoid' = new_id :: new_avoid in - let mapping = Idmap.add id new_id Idmap.empty 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 @@ -266,11 +270,11 @@ let make_discr_match_el = end *) let make_discr_match_brl i = - list_map_i + List.map_i (fun j (_,idl,patl,_) -> - if j=i - then (dummy_loc,idl,patl, mkGRef (Lazy.force coq_True_ref)) - else (dummy_loc,idl,patl, mkGRef (Lazy.force coq_False_ref)) + 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)) ) 0 (* @@ -285,10 +289,6 @@ let make_discr_match brl = make_discr_match_el el, make_discr_match_brl i brl) -let pr_name = function - | Name id -> Ppconstr.pr_id id - | Anonymous -> str "_" - (**********************************************************************) (* functions used to build case expression from lettuple and if ones *) (**********************************************************************) @@ -304,18 +304,17 @@ let build_constructors_of_type ind' argl = Impargs.implicits_of_global constructref in let cst_narg = - Inductiveops.mis_constructor_nargs_env + Inductiveops.constructor_nallargs_env (Global.env ()) construct in - let argl = match argl with - | None -> + let argl = + if List.is_empty argl + then Array.to_list - (Array.init cst_narg (fun _ -> mkGHole ()) + (Array.init (cst_narg - npar) (fun _ -> mkGHole ()) ) - | Some l -> - Array.to_list - (Array.init npar (fun _ -> mkGHole ()))@l + else argl in let pat_as_term = mkGApp(mkGRef (ConstructRef(ind',i+1)),argl) @@ -324,40 +323,6 @@ let build_constructors_of_type ind' argl = ) ind.Declarations.mind_consnames -(* [find_type_of] very naive attempts to discover the type of an if or a letin *) -let rec find_type_of nb b = - let f,_ = glob_decompose_app b in - match f with - | GRef(_,ref) -> - begin - let ind_type = - match ref with - | VarRef _ | ConstRef _ -> - let constr_of_ref = constr_of_global ref in - let type_of_ref = Typing.type_of (Global.env ()) Evd.empty constr_of_ref in - let (_,ret_type) = Reduction.dest_prod (Global.env ()) type_of_ref in - let ret_type,_ = decompose_app ret_type in - if not (isInd ret_type) then - begin -(* Pp.msgnl (str "not an inductive" ++ pr_lconstr ret_type); *) - raise (Invalid_argument "not an inductive") - end; - destInd ret_type - | IndRef ind -> ind - | ConstructRef c -> fst c - in - let _,ind_type_info = Inductive.lookup_mind_specif (Global.env()) ind_type in - if not (Array.length ind_type_info.Declarations.mind_consnames = nb ) - then raise (Invalid_argument "find_type_of : not a valid inductive"); - ind_type - end - | GCast(_,b,_) -> find_type_of nb b - | GApp _ -> assert false (* we have decomposed any application via glob_decompose_app *) - | _ -> raise (Invalid_argument "not a ref") - - - - (******************) (* Main functions *) (******************) @@ -368,14 +333,14 @@ let raw_push_named (na,raw_value,raw_typ) env = match na with | Anonymous -> env | Name id -> - let value = Option.map (Pretyping.Default.understand Evd.empty env) raw_value in - let typ = Pretyping.Default.understand_type Evd.empty env raw_typ in + let value = Option.map (fun x-> fst (Pretyping.understand env Evd.empty x)) raw_value in + let typ,ctx = Pretyping.understand env Evd.empty ~expected_type:Pretyping.IsType raw_typ in Environ.push_named (id,value,typ) env let add_pat_variables pat typ env : Environ.env = let rec add_pat_variables env pat typ : Environ.env = - observe (str "new rel env := " ++ Printer.pr_rel_context_of env); + observe (str "new rel env := " ++ Printer.pr_rel_context_of env Evd.empty); match pat with | PatVar(_,na) -> Environ.push_rel (na,None,typ) env @@ -385,14 +350,14 @@ let add_pat_variables pat typ env : Environ.env = with Not_found -> assert false in let constructors = Inductiveops.get_constructors env indf in - let constructor : Inductiveops.constructor_summary = List.find (fun cs -> cs.Inductiveops.cs_cstr = c) (Array.to_list constructors) in + let constructor : Inductiveops.constructor_summary = List.find (fun cs -> eq_constructor c (fst cs.Inductiveops.cs_cstr)) (Array.to_list constructors) in let cs_args_types :types list = List.map (fun (_,_,t) -> t) constructor.Inductiveops.cs_args in List.fold_left2 add_pat_variables env patl (List.rev cs_args_types) in let new_env = add_pat_variables env pat typ in let res = fst ( - Sign.fold_rel_context + Context.fold_rel_context (fun (na,v,t) (env,ctxt) -> match na with | Anonymous -> assert false @@ -411,7 +376,7 @@ let add_pat_variables pat typ env : Environ.env = ~init:(env,[]) ) in - observe (str "new var env := " ++ Printer.pr_named_context_of res); + observe (str "new var env := " ++ Printer.pr_named_context_of res Evd.empty); res @@ -423,7 +388,7 @@ let rec pattern_to_term_and_type env typ = function mkGVar id | PatCstr(loc,constr,patternl,_) -> let cst_narg = - Inductiveops.mis_constructor_nargs_env + Inductiveops.constructor_nallargs_env (Global.env ()) constr in @@ -432,7 +397,7 @@ let rec pattern_to_term_and_type env typ = function with Not_found -> assert false in let constructors = Inductiveops.get_constructors env indf in - let constructor = List.find (fun cs -> cs.Inductiveops.cs_cstr = constr) (Array.to_list constructors) in + let constructor = List.find (fun cs -> eq_constructor (fst cs.Inductiveops.cs_cstr) constr) (Array.to_list constructors) in let cs_args_types :types list = List.map (fun (_,_,t) -> t) constructor.Inductiveops.cs_args in let _,cstl = Inductiveops.dest_ind_family indf in let csta = Array.of_list cstl in @@ -440,7 +405,7 @@ let rec pattern_to_term_and_type env typ = function Array.to_list (Array.init (cst_narg - List.length patternl) - (fun i -> Detyping.detype false [] (Termops.names_of_rel_context env) csta.(i)) + (fun i -> Detyping.detype false [] env Evd.empty csta.(i)) ) in let patl_as_term = @@ -508,12 +473,12 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = | u::l -> match t with | GLambda(loc,na,_,nat,b) -> - GLetIn(dummy_loc,na,u,aux b l) + GLetIn(Loc.ghost,na,u,aux b l) | _ -> - GApp(dummy_loc,t,l) + GApp(Loc.ghost,t,l) in build_entry_lc env funnames avoid (aux f args) - | GVar(_,id) when Idset.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 @@ -521,10 +486,10 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = a pseudo value "v1 ... vn". The "value" of this branch is then simply [res] *) - let rt_as_constr = Pretyping.Default.understand Evd.empty env rt in + let rt_as_constr,ctx = Pretyping.understand env Evd.empty rt in let rt_typ = Typing.type_of env Evd.empty rt_as_constr in - let res_raw_type = Detyping.detype false [] (Termops.names_of_rel_context env) rt_typ in - let res = fresh_id args_res.to_avoid "res" in + let res_raw_type = Detyping.detype false [] env Evd.empty 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 let new_result = @@ -568,7 +533,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = let new_b = replace_var_by_term id - (GVar(dummy_loc,id)) + (GVar(Loc.ghost,id)) b in (Name new_id,new_b,new_avoid) @@ -629,7 +594,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = and combine the two result *) let v_res = build_entry_lc env funnames avoid v in - let v_as_constr = Pretyping.Default.understand Evd.empty env v in + let v_as_constr,ctx = Pretyping.understand env Evd.empty v in let v_type = Typing.type_of env Evd.empty v_as_constr in let new_env = match n with @@ -645,7 +610,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = let make_discr = make_discr_match brl in build_entry_lc_from_case env funnames make_discr el brl avoid | GIf(_,b,(na,e_option),lhs,rhs) -> - let b_as_constr = Pretyping.Default.understand Evd.empty env b in + let b_as_constr,ctx = Pretyping.understand env Evd.empty b in let b_typ = Typing.type_of env Evd.empty b_as_constr in let (ind,_) = try Inductiveops.find_inductive env Evd.empty b_typ @@ -654,11 +619,11 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = Printer.pr_glob_constr b ++ str " in " ++ Printer.pr_glob_constr rt ++ str ". try again with a cast") in - let case_pats = build_constructors_of_type ind None in - assert (Array.length case_pats = 2); + 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 -> (dummy_loc,[],[case_pats.(i)],x)) + List.map_i + (fun i x -> (Loc.ghost,[],[case_pats.(i)],x)) 0 [lhs;rhs] in @@ -670,14 +635,14 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = | GLetTuple(_,nal,_,b,e) -> begin let nal_as_glob_constr = - Some (List.map + List.map (function Name id -> mkGVar id | Anonymous -> mkGHole () ) - nal) + nal in - let b_as_constr = Pretyping.Default.understand Evd.empty env b in + let b_as_constr,ctx = Pretyping.understand env Evd.empty b in let b_typ = Typing.type_of env Evd.empty b_as_constr in let (ind,_) = try Inductiveops.find_inductive env Evd.empty b_typ @@ -686,10 +651,10 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = Printer.pr_glob_constr b ++ str " in " ++ Printer.pr_glob_constr rt ++ str ". try again with a cast") in - let case_pats = build_constructors_of_type ind nal_as_glob_constr in - assert (Array.length case_pats = 1); + let case_pats = build_constructors_of_type (fst ind) nal_as_glob_constr in + assert (Int.equal (Array.length case_pats) 1); let br = - (dummy_loc,[],[case_pats.(0)],e) + (Loc.ghost,[],[case_pats.(0)],e) in let match_expr = mkGCases(None,[b,(Anonymous,None)],[br]) in build_entry_lc env funnames avoid match_expr @@ -724,7 +689,7 @@ and build_entry_lc_from_case env funname make_discr in let types = List.map (fun (case_arg,_) -> - let case_arg_as_constr = Pretyping.Default.understand Evd.empty env case_arg in + let case_arg_as_constr,ctx = Pretyping.understand env Evd.empty case_arg in Typing.type_of env Evd.empty case_arg_as_constr ) el in @@ -746,7 +711,8 @@ and build_entry_lc_from_case env funname make_discr { result = List.concat (List.map (fun r -> r.result) results); to_avoid = - List.fold_left (fun acc r -> list_union acc r.to_avoid) [] results + List.fold_left (fun acc r -> List.union Id.equal acc r.to_avoid) + [] results } and build_entry_lc_from_case_term env types funname make_discr patterns_to_prevent brl avoid @@ -761,7 +727,7 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve (will be used in the following recursive calls) *) let new_env = List.fold_right2 add_pat_variables patl types env in - let not_those_patterns : (identifier list -> glob_constr -> glob_constr) list = + let not_those_patterns : (Id.t list -> glob_constr -> glob_constr) list = List.map2 (fun pat typ -> fun avoid pat'_as_term -> @@ -775,7 +741,7 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve in let raw_typ_of_id = Detyping.detype false [] - (Termops.names_of_rel_context env_with_pat_ids) typ_of_id + env_with_pat_ids Evd.empty typ_of_id in mkGProd (Name id,raw_typ_of_id,acc)) pat_ids @@ -816,18 +782,18 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve let those_pattern_preconds = (List.flatten ( - list_map3 + List.map3 (fun pat e typ_as_constr -> let this_pat_ids = ids_of_pat pat in - let typ = Detyping.detype false [] (Termops.names_of_rel_context new_env) typ_as_constr in + let typ = Detyping.detype false [] new_env Evd.empty typ_as_constr in let pat_as_term = pattern_to_term pat in List.fold_right (fun id acc -> - if Idset.mem id this_pat_ids + if Id.Set.mem id this_pat_ids then (Prod (Name id), let typ_of_id = Typing.type_of new_env Evd.empty (mkVar id) in let raw_typ_of_id = - Detyping.detype false [] (Termops.names_of_rel_context new_env) typ_of_id + Detyping.detype false [] new_env Evd.empty typ_of_id in raw_typ_of_id )::acc @@ -871,14 +837,14 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve let is_res id = try - String.sub (string_of_id id) 0 3 = "res" + String.equal (String.sub (Id.to_string id) 0 4) "_res" with Invalid_argument _ -> false let same_raw_term rt1 rt2 = match rt1,rt2 with - | GRef(_,r1), GRef (_,r2) -> r1=r2 + | GRef(_,r1,_), GRef (_,r2,_) -> Globnames.eq_gr r1 r2 | GHole _, GHole _ -> true | _ -> false let decompose_raw_eq lhs rhs = @@ -892,7 +858,7 @@ let decompose_raw_eq lhs rhs = 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 && sllhs = slrhs + if same_raw_term lhd rhd && Int.equal sllhs slrhs then (* let _ = assert false in *) List.fold_right2 decompose_raw_eq llhs lrhs acc @@ -928,7 +894,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = let new_t = mkGApp(mkGVar(mk_rel_id this_relname),args'@[res_rt]) in - let t' = Pretyping.Default.understand Evd.empty env new_t in + let t',ctx = Pretyping.understand env Evd.empty new_t in let new_env = Environ.push_rel (n,None,t') env in let new_b,id_to_exclude = rebuild_cons new_env @@ -937,18 +903,18 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = (depth + 1) b in mkGProd(n,new_t,new_b), - Idset.filter not_free_in_t id_to_exclude + Id.Set.filter not_free_in_t id_to_exclude | _ -> (* 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 eq_as_ref = Lazy.force Coqlib.coq_eq_ref && n = Anonymous + | GApp(loc1,GRef(loc2,eq_as_ref,_),[ty;GVar(loc3,id);rt]) + when Globnames.eq_gr eq_as_ref (Lazy.force Coqlib.coq_eq_ref) && n == Anonymous -> begin try observe (str "computing new type for eq : " ++ pr_glob_constr rt); let t' = - try Pretyping.Default.understand Evd.empty env t + try fst (Pretyping.understand env Evd.empty t)(*FIXME*) with e when Errors.noncritical e -> raise Continue in let is_in_b = is_free_in id b in @@ -970,36 +936,36 @@ 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 = Libnames.IndRef (destInd (jmeq ())) in - let ty' = Pretyping.Default.understand Evd.empty env ty in + let jmeq = Globnames.IndRef (fst (destInd (jmeq ()))) in + let ty',ctx = Pretyping.understand env Evd.empty ty in let ind,args' = Inductive.find_inductive env ty' in - let mib,_ = Global.lookup_inductive ind in + let mib,_ = Global.lookup_inductive (fst ind) in let nparam = mib.Declarations.mind_nparams in let params,arg' = - ((Util.list_chop nparam args')) + ((Util.List.chop nparam args')) in let rt_typ = - GApp(Util.dummy_loc, - GRef (Util.dummy_loc,Libnames.IndRef ind), + GApp(Loc.ghost, + GRef (Loc.ghost,Globnames.IndRef (fst ind),None), (List.map (fun p -> Detyping.detype false [] - (Termops.names_of_rel_context env) + env Evd.empty p) params)@(Array.to_list (Array.make (List.length args' - nparam) (mkGHole ())))) in let eq' = - GApp(loc1,GRef(loc2,jmeq),[ty;GVar(loc3,id);rt_typ;rt]) + GApp(loc1,GRef(loc2,jmeq,None),[ty;GVar(loc3,id);rt_typ;rt]) in observe (str "computing new type for jmeq : " ++ pr_glob_constr eq'); - let eq'_as_constr = Pretyping.Default.understand Evd.empty env eq' in + let eq'_as_constr,ctx = Pretyping.understand env Evd.empty eq' in observe (str " computing new type for jmeq : done") ; let new_args = match kind_of_term eq'_as_constr with | App(_,[|_;_;ty;_|]) -> let ty = Array.to_list (snd (destApp ty)) in - let ty' = snd (Util.list_chop nparam 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 @@ -1011,11 +977,13 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = | Anonymous -> acc | Name id' -> (id',Detyping.detype false [] - (Termops.names_of_rel_context env) + env + Evd.empty arg)::acc else if isVar var_as_constr then (destVar var_as_constr,Detyping.detype false [] - (Termops.names_of_rel_context env) + env + Evd.empty arg)::acc else acc ) @@ -1041,7 +1009,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = if is_in_b then b else replace_var_by_term id rt b in let new_env = - let t' = Pretyping.Default.understand Evd.empty env eq' in + let t',ctx = Pretyping.understand env Evd.empty eq' in Environ.push_rel (n,None,t') env in let new_b,id_to_exclude = @@ -1056,10 +1024,10 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = (* J.F:. keep this comment it explain how to remove some meaningless equalities if keep_eq then mkGProd(n,t,new_b),id_to_exclude - else new_b, Idset.add id id_to_exclude + else new_b, Id.Set.add id id_to_exclude *) - | GApp(loc1,GRef(loc2,eq_as_ref),[ty;rt1;rt2]) - when eq_as_ref = Lazy.force Coqlib.coq_eq_ref && n = Anonymous + | GApp(loc1,GRef(loc2,eq_as_ref,_),[ty;rt1;rt2]) + when Globnames.eq_gr eq_as_ref (Lazy.force Coqlib.coq_eq_ref) && n == Anonymous -> begin try @@ -1079,7 +1047,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = else raise Continue with Continue -> observe (str "computing new type for prod : " ++ pr_glob_constr rt); - let t' = Pretyping.Default.understand Evd.empty env t in + let t',ctx = Pretyping.understand env Evd.empty t in let new_env = Environ.push_rel (n,None,t') env in let new_b,id_to_exclude = rebuild_cons new_env @@ -1088,14 +1056,14 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = (depth + 1) b in match n with - | Name id when Idset.mem id id_to_exclude && depth >= nb_args -> - new_b,Idset.remove id - (Idset.filter not_free_in_t id_to_exclude) - | _ -> mkGProd(n,t,new_b),Idset.filter not_free_in_t id_to_exclude + | 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) + | _ -> 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); - let t' = Pretyping.Default.understand Evd.empty env t in + let t',ctx = Pretyping.understand env Evd.empty t in let new_env = Environ.push_rel (n,None,t') env in let new_b,id_to_exclude = rebuild_cons new_env @@ -1104,17 +1072,17 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = (depth + 1) b in match n with - | Name id when Idset.mem id id_to_exclude && depth >= nb_args -> - new_b,Idset.remove id - (Idset.filter not_free_in_t id_to_exclude) - | _ -> mkGProd(n,t,new_b),Idset.filter not_free_in_t id_to_exclude + | 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) + | _ -> mkGProd(n,t,new_b),Id.Set.filter not_free_in_t id_to_exclude end | 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); - let t' = Pretyping.Default.understand Evd.empty env t in + let t',ctx = Pretyping.understand env Evd.empty t in match n with | Name id -> let new_env = Environ.push_rel (n,None,t') env in @@ -1124,19 +1092,19 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = (args@[mkGVar id])new_crossed_types (depth + 1 ) b in - if Idset.mem id id_to_exclude && depth >= nb_args + if Id.Set.mem id id_to_exclude && depth >= nb_args then - new_b, Idset.remove id (Idset.filter not_free_in_t id_to_exclude) + new_b, Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude) else - GProd(dummy_loc,n,k,t,new_b),Idset.filter not_free_in_t id_to_exclude - | _ -> anomaly "Should not have an anonymous function here" + 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") (* We have renamed all the anonymous functions during alpha_renaming phase *) end | GLetIn(_,n,t,b) -> begin let not_free_in_t id = not (is_free_in id t) in - let t' = Pretyping.Default.understand Evd.empty env t in + let t',ctx = Pretyping.understand env Evd.empty t in let type_t' = Typing.type_of env Evd.empty t' in let new_env = Environ.push_rel (n,Some t',type_t') env in let new_b,id_to_exclude = @@ -1145,13 +1113,13 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = args (t::crossed_types) (depth + 1 ) b in match n with - | Name id when Idset.mem id id_to_exclude && depth >= nb_args -> - new_b,Idset.remove id (Idset.filter not_free_in_t id_to_exclude) - | _ -> GLetIn(dummy_loc,n,t,new_b), - Idset.filter not_free_in_t id_to_exclude + | 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), + Id.Set.filter not_free_in_t id_to_exclude end | GLetTuple(_,nal,(na,rto),t,b) -> - assert (rto=None); + assert (Option.is_empty rto); begin let not_free_in_t id = not (is_free_in id t) in let new_t,id_to_exclude' = @@ -1161,7 +1129,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = args (crossed_types) depth t in - let t' = Pretyping.Default.understand Evd.empty env new_t in + let t',ctx = Pretyping.understand env Evd.empty new_t in let new_env = Environ.push_rel (na,None,t') env in let new_b,id_to_exclude = rebuild_cons new_env @@ -1170,15 +1138,15 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = (depth + 1) b in (* match n with *) -(* | Name id when Idset.mem id id_to_exclude -> *) -(* new_b,Idset.remove id (Idset.filter not_free_in_t id_to_exclude) *) +(* | 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(dummy_loc,nal,(na,None),t,new_b), - Idset.filter not_free_in_t (Idset.union id_to_exclude id_to_exclude') + GLetTuple(Loc.ghost,nal,(na,None),t,new_b), + Id.Set.filter not_free_in_t (Id.Set.union id_to_exclude id_to_exclude') end - | _ -> mkGApp(mkGVar relname,args@[rt]),Idset.empty + | _ -> mkGApp(mkGVar relname,args@[rt]),Id.Set.empty (* debuging wrapper *) @@ -1201,7 +1169,7 @@ let rebuild_cons env nb_args relname args crossed_types rt = *) let rec compute_cst_params relnames params = function | GRef _ | GVar _ | GEvar _ | GPatVar _ -> params - | GApp(_,GVar(_,relname'),rtl) when Idset.mem relname' relnames -> + | GApp(_,GVar(_,relname'),rtl) when Id.Set.mem relname' relnames -> compute_cst_params_from_app [] (params,rtl) | GApp(_,f,args) -> List.fold_left (compute_cst_params relnames) params (f::args) @@ -1219,11 +1187,11 @@ and compute_cst_params_from_app acc (params,rtl) = 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_ord id id' == 0 && not is_defined -> + when Id.compare id id' == 0 && not is_defined -> compute_cst_params_from_app (param::acc) (params',rtl') | _ -> List.rev acc -let compute_params_name relnames (args : (Names.name * Glob_term.glob_constr * bool) list array) csts = +let compute_params_name relnames (args : (Name.t * Glob_term.glob_constr * bool) list array) csts = let rels_params = Array.mapi (fun i args -> @@ -1237,12 +1205,12 @@ let compute_params_name relnames (args : (Names.name * Glob_term.glob_constr * b let l = ref [] in let _ = try - list_iter_i + List.iteri (fun i ((n,nt,is_defined) as param) -> - if array_for_all + if Array.for_all (fun l -> let (n',nt',is_defined') = List.nth l i in - n = n' && Topconstr.eq_glob_constr nt nt' && is_defined = is_defined') + Name.equal n n' && Notation_ops.eq_glob_constr nt nt' && (is_defined : bool) == is_defined') rels_params then l := param::!l @@ -1255,22 +1223,23 @@ let compute_params_name relnames (args : (Names.name * Glob_term.glob_constr * b let rec rebuild_return_type rt = match rt with - | Topconstr.CProdN(loc,n,t') -> - Topconstr.CProdN(loc,n,rebuild_return_type t') - | Topconstr.CArrow(loc,t,t') -> - Topconstr.CArrow(loc,t,rebuild_return_type t') - | Topconstr.CLetIn(loc,na,t,t') -> - Topconstr.CLetIn(loc,na,t,rebuild_return_type t') - | _ -> Topconstr.CArrow(dummy_loc,rt,Topconstr.CSort(dummy_loc,GType None)) + | 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 do_build_inductive - funnames (funsargs: (Names.name * glob_constr * bool) list list) - returned_types - (rtl:glob_constr list) = + mp_dp + funnames (funsargs: (Name.t * glob_constr * bool) list list) + returned_types + (rtl:glob_constr list) = let _time1 = System.get_time () in -(* Pp.msgnl (prlist_with_sep fnl Printer.pr_glob_constr rtl); *) - let funnames_as_set = List.fold_right Idset.add funnames Idset.empty in + (* Pp.msgnl (prlist_with_sep fnl Printer.pr_glob_constr rtl); *) + let funnames_as_set = List.fold_right Id.Set.add funnames Id.Set.empty in let funnames = Array.of_list funnames in let funsargs = Array.of_list funsargs in let returned_types = Array.of_list returned_types in @@ -1281,12 +1250,22 @@ let do_build_inductive Ensures by: obvious i*) let relnames = Array.map mk_rel_id funnames in - let relnames_as_set = Array.fold_right Idset.add relnames Idset.empty in + let relnames_as_set = Array.fold_right Id.Set.add relnames Id.Set.empty in (* Construction of the pseudo constructors *) let env = Array.fold_right (fun id env -> - Environ.push_named (id,None,Typing.type_of env Evd.empty (Constrintern.global_reference id)) env + let c = + match mp_dp with + | None -> (Constrintern.global_reference id) + | Some(mp,dp) -> mkConst (make_con mp dp (Label.of_id id)) + in + Environ.push_named (id,None, + try + Typing.type_of env Evd.empty c + with Not_found -> + raise (UserError("do_build_inductive", str "Cannot handle partial fixpoint")) + ) env ) funnames (Global.env ()) @@ -1294,19 +1273,19 @@ let do_build_inductive let resa = Array.map (build_entry_lc env funnames_as_set []) rta in let env_with_graphs = let rel_arity i funargs = (* Reduilding arities (with parameters) *) - let rel_first_args :(Names.name * Glob_term.glob_constr * bool ) list = + let rel_first_args :(Name.t * Glob_term.glob_constr * bool ) list = funargs in List.fold_right (fun (n,t,is_defined) acc -> if is_defined then - Topconstr.CLetIn(dummy_loc,(dummy_loc, n),Constrextern.extern_glob_constr Idset.empty t, + Constrexpr.CLetIn(Loc.ghost,(Loc.ghost, n),with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t, acc) else - Topconstr.CProdN - (dummy_loc, - [[(dummy_loc,n)],Topconstr.default_binder_kind,Constrextern.extern_glob_constr Idset.empty t], + Constrexpr.CProdN + (Loc.ghost, + [[(Loc.ghost,n)],Constrexpr_ops.default_binder_kind,with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t], acc ) ) @@ -1318,8 +1297,9 @@ let do_build_inductive Then save the graphs and reset Printing options to their primitive values *) let rel_arities = Array.mapi rel_arity funsargs in - Util.array_fold_left2 (fun env rel_name rel_ar -> - Environ.push_named (rel_name,None, Constrintern.interp_constr Evd.empty env rel_ar) env) env relnames rel_arities + Util.Array.fold_left2 (fun env rel_name rel_ar -> + Environ.push_named (rel_name,None, + fst (with_full_print (Constrintern.interp_constr env Evd.empty) rel_ar)) env) env relnames rel_arities in (* and of the real constructors*) let constr i res = @@ -1344,9 +1324,9 @@ let do_build_inductive (*i The next call to mk_rel_id is valid since we are constructing the graph Ensures by: obvious i*) - id_of_string ((string_of_id (mk_rel_id funnames.(i)))^"_"^(string_of_int !next_constructor_id)) + Id.of_string ((Id.to_string (mk_rel_id funnames.(i)))^"_"^(string_of_int !next_constructor_id)) in - let rel_constructors i rt : (identifier*glob_constr) list = + let rel_constructors i rt : (Id.t*glob_constr) list = next_constructor_id := (-1); List.map (fun constr -> (mk_constructor_id i),constr) (constr i rt) in @@ -1360,19 +1340,19 @@ let do_build_inductive rel_constructors in let rel_arity i funargs = (* Reduilding arities (with parameters) *) - let rel_first_args :(Names.name * Glob_term.glob_constr * bool ) list = - (snd (list_chop nrel_params funargs)) + let rel_first_args :(Name.t * Glob_term.glob_constr * bool ) list = + (snd (List.chop nrel_params funargs)) in List.fold_right (fun (n,t,is_defined) acc -> if is_defined then - Topconstr.CLetIn(dummy_loc,(dummy_loc, n),Constrextern.extern_glob_constr Idset.empty t, + Constrexpr.CLetIn(Loc.ghost,(Loc.ghost, n),with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t, acc) else - Topconstr.CProdN - (dummy_loc, - [[(dummy_loc,n)],Topconstr.default_binder_kind,Constrextern.extern_glob_constr Idset.empty t], + Constrexpr.CProdN + (Loc.ghost, + [[(Loc.ghost,n)],Constrexpr_ops.default_binder_kind,with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t], acc ) ) @@ -1384,31 +1364,40 @@ let do_build_inductive Then save the graphs and reset Printing options to their primitive values *) let rel_arities = Array.mapi rel_arity funsargs in + let rel_params_ids = + List.fold_left + (fun acc (na,_,_) -> + match na with + Anonymous -> acc + | Name id -> id::acc + ) + [] + rels_params + in let rel_params = List.map (fun (n,t,is_defined) -> if is_defined then - Topconstr.LocalRawDef((dummy_loc,n), Constrextern.extern_glob_constr Idset.empty t) + Constrexpr.LocalRawDef((Loc.ghost,n), Constrextern.extern_glob_constr Id.Set.empty t) else - Topconstr.LocalRawAssum - ([(dummy_loc,n)], Topconstr.default_binder_kind, Constrextern.extern_glob_constr Idset.empty t) + Constrexpr.LocalRawAssum + ([(Loc.ghost,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,((dummy_loc,id), - Flags.with_option - Flags.raw_print - (Constrextern.extern_glob_type Idset.empty) ((* zeta_normalize *) t) + false,((Loc.ghost,id), + with_full_print + (Constrextern.extern_glob_type Id.Set.empty) ((* zeta_normalize *) (alpha_rt rel_params_ids t)) ) )) (rel_constructors) in let rel_ind i ext_rel_constructors = - ((dummy_loc,relnames.(i)), + ((Loc.ghost,relnames.(i)), rel_params, Some rel_arities.(i), ext_rel_constructors),[] @@ -1437,7 +1426,7 @@ let do_build_inductive (* in *) let _time2 = System.get_time () in try - with_full_print (Flags.silently (Command.do_mutual_inductive rel_inds)) true + with_full_print (Flags.silently (Command.do_mutual_inductive rel_inds false false)) Decl_kinds.Finite with | UserError(s,msg) as e -> let _time3 = System.get_time () in @@ -1448,7 +1437,7 @@ let do_build_inductive in let msg = str "while trying to define"++ spc () ++ - Ppvernac.pr_vernac (Vernacexpr.VernacInductive(Decl_kinds.Finite,false,repacked_rel_inds)) + Ppvernac.pr_vernac (Vernacexpr.VernacInductive(false,Decl_kinds.Finite,repacked_rel_inds)) ++ fnl () ++ msg in @@ -1463,7 +1452,7 @@ let do_build_inductive in let msg = str "while trying to define"++ spc () ++ - Ppvernac.pr_vernac (Vernacexpr.VernacInductive(Decl_kinds.Finite,false,repacked_rel_inds)) + Ppvernac.pr_vernac (Vernacexpr.VernacInductive(false,Decl_kinds.Finite,repacked_rel_inds)) ++ fnl () ++ Errors.print reraise in @@ -1472,9 +1461,9 @@ let do_build_inductive -let build_inductive funnames funsargs returned_types rtl = +let build_inductive mp_dp funnames funsargs returned_types rtl = try - do_build_inductive funnames funsargs returned_types rtl + do_build_inductive mp_dp funnames funsargs returned_types rtl with e when Errors.noncritical e -> raise (Building_graph e) diff --git a/plugins/funind/glob_term_to_relation.mli b/plugins/funind/glob_term_to_relation.mli index 5c91292b..b0a05ec3 100644 --- a/plugins/funind/glob_term_to_relation.mli +++ b/plugins/funind/glob_term_to_relation.mli @@ -1,5 +1,4 @@ - - +open Names (* [build_inductive parametrize funnames funargs returned_types bodies] @@ -8,9 +7,10 @@ *) val build_inductive : - Names.identifier list -> (* The list of function name *) - (Names.name*Glob_term.glob_constr*bool) list list -> (* The list of function args *) - Topconstr.constr_expr list -> (* The list of function returned type *) + (ModPath.t * DirPath.t) option -> + Id.t list -> (* The list of function name *) + (Name.t*Glob_term.glob_constr*bool) 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 6cc932b1..291f835e 100644 --- a/plugins/funind/glob_termops.ml +++ b/plugins/funind/glob_termops.ml @@ -1,24 +1,25 @@ open Pp open Glob_term +open Errors open Util open Names -(* Ocaml 3.06 Map.S does not handle is_empty *) -let idmap_is_empty m = m = Idmap.empty +open Decl_kinds +open Misctypes (* Some basic functions to rebuild glob_constr - In each of them the location is Util.dummy_loc + In each of them the location is Loc.ghost *) -let mkGRef ref = GRef(dummy_loc,ref) -let mkGVar id = GVar(dummy_loc,id) -let mkGApp(rt,rtl) = GApp(dummy_loc,rt,rtl) -let mkGLambda(n,t,b) = GLambda(dummy_loc,n,Explicit,t,b) -let mkGProd(n,t,b) = GProd(dummy_loc,n,Explicit,t,b) -let mkGLetIn(n,t,b) = GLetIn(dummy_loc,n,t,b) -let mkGCases(rto,l,brl) = GCases(dummy_loc,Term.RegularStyle,rto,l,brl) -let mkGSort s = GSort(dummy_loc,s) -let mkGHole () = GHole(dummy_loc,Evd.BinderType Anonymous) -let mkGCast(b,t) = GCast(dummy_loc,b,CastConv (Term.DEFAULTcast,t)) +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) (* Some basic functions to decompose glob_constrs @@ -107,7 +108,7 @@ let glob_make_or t1 t2 = mkGApp (mkGRef(Lazy.force Coqlib.coq_or_ref),[t1;t2]) to [P1 \/ ( .... \/ Pn)] *) let rec glob_make_or_list = function - | [] -> raise (Invalid_argument "mk_or") + | [] -> invalid_arg "mk_or" | [e] -> e | e::l -> glob_make_or e (glob_make_or_list l) @@ -115,7 +116,7 @@ let rec glob_make_or_list = function let remove_name_from_mapping mapping na = match na with | Anonymous -> mapping - | Name id -> Idmap.remove id mapping + | Name id -> Id.Map.remove id mapping let change_vars = let rec change_vars mapping rt = @@ -124,7 +125,7 @@ let change_vars = | GVar(loc,id) -> let new_id = try - Idmap.find id mapping + Id.Map.find id mapping with Not_found -> id in GVar(loc,new_id) @@ -179,13 +180,12 @@ let change_vars = | GRec _ -> error "Local (co)fixes are not supported" | GSort _ -> rt | GHole _ -> rt - | GCast(loc,b,CastConv (k,t)) -> - GCast(loc,change_vars mapping b, CastConv (k,change_vars mapping t)) - | GCast(loc,b,CastCoerce) -> - GCast(loc,change_vars mapping b,CastCoerce) + | GCast(loc,b,c) -> + GCast(loc,change_vars mapping b, + Miscops.map_cast_type (change_vars mapping) c) and change_vars_br mapping ((loc,idl,patl,res) as br) = - let new_mapping = List.fold_right Idmap.remove idl mapping in - if idmap_is_empty new_mapping + 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) in @@ -197,27 +197,27 @@ let rec alpha_pat excluded pat = match pat with | PatVar(loc,Anonymous) -> let new_id = Indfun_common.fresh_id excluded "_x" in - PatVar(loc,Name new_id),(new_id::excluded),Idmap.empty + PatVar(loc,Name new_id),(new_id::excluded),Id.Map.empty | PatVar(loc,Name id) -> - if List.mem id excluded + 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), - (Idmap.add id new_id Idmap.empty) - else pat,excluded,Idmap.empty + (Id.Map.add id new_id Id.Map.empty) + else pat,excluded,Id.Map.empty | PatCstr(loc,constr,patl,na) -> let new_na,new_excluded,map = match na with - | Name id when List.mem id excluded -> + | Name id when Id.List.mem id excluded -> let new_id = Namegen.next_ident_away id excluded in - Name new_id,new_id::excluded, Idmap.add id new_id Idmap.empty - | _ -> na,excluded,Idmap.empty + Name new_id,new_id::excluded, Id.Map.add id new_id Id.Map.empty + | _ -> na,excluded,Id.Map.empty in let new_patl,new_excluded,new_map = List.fold_left (fun (patl,excluded,map) pat -> let new_pat,new_excluded,new_map = alpha_pat excluded pat in - (new_pat::patl,new_excluded,Idmap.fold Idmap.add new_map map) + (new_pat::patl,new_excluded,Id.Map.fold Id.Map.add new_map map) ) ([],new_excluded,map) patl @@ -229,9 +229,9 @@ let alpha_patl excluded patl = List.fold_left (fun (patl,excluded,map) pat -> let new_pat,new_excluded,new_map = alpha_pat excluded pat in - new_pat::patl,new_excluded,(Idmap.fold Idmap.add new_map map) + new_pat::patl,new_excluded,(Id.Map.fold Id.Map.add new_map map) ) - ([],excluded,Idmap.empty) + ([],excluded,Id.Map.empty) patl in (List.rev patl,new_excluded,map) @@ -263,7 +263,7 @@ let rec alpha_rt excluded 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 new_id = Namegen.next_ident_away (Id.of_string "_x") 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 @@ -279,10 +279,10 @@ let rec alpha_rt excluded rt = | GLambda(loc,Name id,k,t,b) -> let new_id = Namegen.next_ident_away id excluded in let t,b = - if new_id = id + if Id.equal new_id id then t,b else - let replace = change_vars (Idmap.add id new_id Idmap.empty) in + let replace = change_vars (Id.Map.add id new_id Id.Map.empty) in (t,replace b) in let new_excluded = new_id::excluded in @@ -293,10 +293,10 @@ let rec alpha_rt excluded rt = let new_id = Namegen.next_ident_away id excluded in let new_excluded = new_id::excluded in let t,b = - if new_id = id + if Id.equal new_id id then t,b else - let replace = change_vars (Idmap.add id new_id Idmap.empty) in + let replace = change_vars (Id.Map.add id new_id Id.Map.empty) in (t,replace b) in let new_t = alpha_rt new_excluded t in @@ -305,10 +305,10 @@ let rec alpha_rt excluded rt = | GLetIn(loc,Name id,t,b) -> let new_id = Namegen.next_ident_away id excluded in let t,b = - if new_id = id + if Id.equal new_id id then t,b else - let replace = change_vars (Idmap.add id new_id Idmap.empty) in + let replace = change_vars (Id.Map.add id new_id Id.Map.empty) in (t,replace b) in let new_excluded = new_id::excluded in @@ -325,18 +325,18 @@ let rec alpha_rt excluded rt = | Anonymous -> (na::nal,excluded,mapping) | Name id -> let new_id = Namegen.next_ident_away id excluded in - if new_id = id + if Id.equal new_id id then na::nal,id::excluded,mapping else - (Name new_id)::nal,id::excluded,(Idmap.add id new_id mapping) + (Name new_id)::nal,id::excluded,(Id.Map.add id new_id mapping) ) - ([],excluded,Idmap.empty) + ([],excluded,Id.Map.empty) nal in let new_nal = List.rev rev_new_nal in let new_rto,new_t,new_b = - if idmap_is_empty mapping + if Id.Map.is_empty mapping then rto,t,b else let replace = change_vars mapping in (Option.map replace rto, t,replace b) @@ -359,10 +359,9 @@ let rec alpha_rt excluded rt = | GRec _ -> error "Not handled GRec" | GSort _ -> rt | GHole _ -> rt - | GCast (loc,b,CastConv (k,t)) -> - GCast(loc,alpha_rt excluded b,CastConv(k,alpha_rt excluded t)) - | GCast (loc,b,CastCoerce) -> - GCast(loc,alpha_rt excluded b,CastCoerce) + | GCast (loc,b,c) -> + GCast(loc,alpha_rt excluded b, + Miscops.map_cast_type (alpha_rt excluded) c) | GApp(loc,f,args) -> GApp(loc, alpha_rt excluded f, @@ -385,14 +384,14 @@ and alpha_br excluded (loc,ids,patl,res) = let is_free_in id = let rec is_free_in = function | GRef _ -> false - | GVar(_,id') -> id_ord 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) -> let check_in_b = match n with - | Name id' -> id_ord id' id <> 0 + | Name id' -> not (Id.equal id' id) | _ -> true in is_free_in t || (check_in_b && is_free_in b) @@ -401,7 +400,7 @@ let is_free_in id = List.exists is_free_in_br brl | GLetTuple(_,nal,_,b,t) -> let check_in_nal = - not (List.exists (function Name id' -> id'= id | _ -> false) 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) @@ -410,10 +409,10 @@ let is_free_in id = | GRec _ -> raise (UserError("",str "Not handled GRec")) | GSort _ -> false | GHole _ -> false - | GCast (_,b,CastConv (_,t)) -> is_free_in b || is_free_in t + | 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) = - (not (List.mem id ids)) && is_free_in rt + (not (Id.List.mem id ids)) && is_free_in rt in is_free_in @@ -425,7 +424,7 @@ let rec pattern_to_term = function mkGVar id | PatCstr(loc,constr,patternl,_) -> let cst_narg = - Inductiveops.mis_constructor_nargs_env + Inductiveops.constructor_nallargs_env (Global.env ()) constr in @@ -439,7 +438,7 @@ let rec pattern_to_term = function let patl_as_term = List.map pattern_to_term patternl in - mkGApp(mkGRef(Libnames.ConstructRef constr), + mkGApp(mkGRef(Globnames.ConstructRef constr), implicit_args@patl_as_term ) @@ -449,7 +448,7 @@ let replace_var_by_term x_id term = let rec replace_var_by_pattern rt = match rt with | GRef _ -> rt - | GVar(_,id) when id_ord id x_id == 0 -> term + | GVar(_,id) when Id.compare id x_id == 0 -> term | GVar _ -> rt | GEvar _ -> rt | GPatVar _ -> rt @@ -458,7 +457,7 @@ let replace_var_by_term x_id term = replace_var_by_pattern rt', List.map replace_var_by_pattern rtl ) - | GLambda(_,Name id,_,_,_) when id_ord id x_id == 0 -> rt + | GLambda(_,Name id,_,_,_) when Id.compare id x_id == 0 -> rt | GLambda(loc,name,k,t,b) -> GLambda(loc, name, @@ -466,7 +465,7 @@ let replace_var_by_term x_id term = replace_var_by_pattern t, replace_var_by_pattern b ) - | GProd(_,Name id,_,_,_) when id_ord id x_id == 0 -> rt + | GProd(_,Name id,_,_,_) when Id.compare id x_id == 0 -> rt | GProd(loc,name,k,t,b) -> GProd(loc, name, @@ -474,7 +473,7 @@ let replace_var_by_term x_id term = replace_var_by_pattern t, replace_var_by_pattern b ) - | GLetIn(_,Name id,_,_) when id_ord id x_id == 0 -> rt + | GLetIn(_,Name id,_,_) when Id.compare id x_id == 0 -> rt | GLetIn(loc,name,def,b) -> GLetIn(loc, name, @@ -482,7 +481,7 @@ let replace_var_by_term x_id term = replace_var_by_pattern b ) | GLetTuple(_,nal,_,_,_) - when List.exists (function Name id -> id = x_id | _ -> false) nal -> + when List.exists (function Name id -> Id.equal id x_id | _ -> false) nal -> rt | GLetTuple(loc,nal,(na,rto),def,b) -> GLetTuple(loc, @@ -506,12 +505,11 @@ let replace_var_by_term x_id term = | GRec _ -> raise (UserError("",str "Not handled GRec")) | GSort _ -> rt | GHole _ -> rt - | GCast(loc,b,CastConv(k,t)) -> - GCast(loc,replace_var_by_pattern b,CastConv(k,replace_var_by_pattern t)) - | GCast(loc,b,CastCoerce) -> - GCast(loc,replace_var_by_pattern b,CastCoerce) + | GCast(loc,b,c) -> + GCast(loc,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) = - if List.exists (fun id -> id_ord id x_id == 0) idl + if List.exists (fun id -> Id.compare id x_id == 0) idl then br else (loc,idl,patl,replace_var_by_pattern res) in @@ -529,13 +527,12 @@ let rec are_unifiable_aux = function match eq with | PatVar _,_ | _,PatVar _ -> are_unifiable_aux eqs | PatCstr(_,constructor1,cpl1,_),PatCstr(_,constructor2,cpl2,_) -> - if constructor2 <> constructor1 + if not (eq_constructor constructor2 constructor1) then raise NotUnifiable else let eqs' = - try ((List.combine cpl1 cpl2)@eqs) - with e when Errors.noncritical e -> - anomaly "are_unifiable_aux" + try (List.combine cpl1 cpl2) @ eqs + with Invalid_argument _ -> anomaly (Pp.str "are_unifiable_aux") in are_unifiable_aux eqs' @@ -552,13 +549,12 @@ let rec eq_cases_pattern_aux = function match eq with | PatVar _,PatVar _ -> eq_cases_pattern_aux eqs | PatCstr(_,constructor1,cpl1,_),PatCstr(_,constructor2,cpl2,_) -> - if constructor2 <> constructor1 + if not (eq_constructor constructor2 constructor1) then raise NotUnifiable else let eqs' = - try ((List.combine cpl1 cpl2)@eqs) - with e when Errors.noncritical e -> - anomaly "eq_cases_pattern_aux" + try (List.combine cpl1 cpl2) @ eqs + with Invalid_argument _ -> anomaly (Pp.str "eq_cases_pattern_aux") in eq_cases_pattern_aux eqs' | _ -> raise NotUnifiable @@ -574,13 +570,13 @@ let eq_cases_pattern pat1 pat2 = let ids_of_pat = let rec ids_of_pat ids = function | PatVar(_,Anonymous) -> ids - | PatVar(_,Name id) -> Idset.add id ids + | PatVar(_,Name id) -> Id.Set.add id ids | PatCstr(_,_,patl,_) -> List.fold_left ids_of_pat ids patl in - ids_of_pat Idset.empty + ids_of_pat Id.Set.empty let id_of_name = function - | Names.Anonymous -> id_of_string "x" + | Names.Anonymous -> Id.of_string "x" | Names.Name x -> x (* TODO: finish Rec caes *) @@ -594,7 +590,7 @@ let ids_of_glob_constr c = | 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(k,t)) -> ids_of_glob_constr [] c @ ids_of_glob_constr [] t @ 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) -> @@ -605,7 +601,7 @@ let ids_of_glob_constr c = | (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _) -> [] in (* build the set *) - List.fold_left (fun acc x -> Idset.add x acc) Idset.empty (ids_of_glob_constr [] c) + List.fold_left (fun acc x -> Id.Set.add x acc) Id.Set.empty (ids_of_glob_constr [] c) @@ -662,10 +658,9 @@ let zeta_normalize = | GRec _ -> raise (UserError("",str "Not handled GRec")) | GSort _ -> rt | GHole _ -> rt - | GCast(loc,b,CastConv(k,t)) -> - GCast(loc,zeta_normalize_term b,CastConv(k,zeta_normalize_term t)) - | GCast(loc,b,CastCoerce) -> - GCast(loc,zeta_normalize_term b,CastCoerce) + | 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 @@ -680,7 +675,7 @@ let expand_as = match pat with | PatVar _ -> map | PatCstr(_,_,patl,Name id) -> - Idmap.add id (pattern_to_term pat) (List.fold_left add_as map patl) + Id.Map.add id (pattern_to_term pat) (List.fold_left add_as map patl) | PatCstr(_,_,patl,_) -> List.fold_left add_as map patl in let rec expand_as map rt = @@ -689,7 +684,7 @@ let expand_as = | GVar(_,id) -> begin try - Idmap.find id map + 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) @@ -703,12 +698,13 @@ let expand_as = GIf(loc,expand_as map e,(na,Option.map (expand_as map) po), expand_as map br1, expand_as map br2) | GRec _ -> error "Not handled GRec" - | GCast(loc,b,CastConv(kind,t)) -> GCast(loc,expand_as map b,CastConv(kind,expand_as map t)) - | GCast(loc,b,CastCoerce) -> GCast(loc,expand_as map b,CastCoerce) + | GCast(loc,b,c) -> + GCast(loc,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, 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) in - expand_as Idmap.empty + expand_as Id.Map.empty diff --git a/plugins/funind/glob_termops.mli b/plugins/funind/glob_termops.mli index bfd15357..0f10636f 100644 --- a/plugins/funind/glob_termops.mli +++ b/plugins/funind/glob_termops.mli @@ -1,11 +1,9 @@ +open Names open Glob_term - -(* Ocaml 3.06 Map.S does not handle is_empty *) -val idmap_is_empty : 'a Names.Idmap.t -> bool - +open Misctypes (* [get_pattern_id pat] returns a list of all the variable appearing in [pat] *) -val get_pattern_id : cases_pattern -> Names.identifier list +val get_pattern_id : cases_pattern -> Id.t list (* [pattern_to_term pat] returns a glob_constr corresponding to [pat]. [pat] must not contain occurences of anonymous pattern @@ -14,14 +12,14 @@ val pattern_to_term : cases_pattern -> glob_constr (* Some basic functions to rebuild glob_constr - In each of them the location is Util.dummy_loc + In each of them the location is Util.Loc.ghost *) -val mkGRef : Libnames.global_reference -> glob_constr -val mkGVar : Names.identifier -> glob_constr +val mkGRef : Globnames.global_reference -> glob_constr +val mkGVar : Id.t -> glob_constr val mkGApp : glob_constr*(glob_constr list) -> glob_constr -val mkGLambda : Names.name * glob_constr * glob_constr -> glob_constr -val mkGProd : Names.name * glob_constr * glob_constr -> glob_constr -val mkGLetIn : Names.name * glob_constr * glob_constr -> 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 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 *) @@ -30,15 +28,15 @@ 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 -> (Names.name*glob_constr) list * glob_constr +val glob_decompose_prod : glob_constr -> (Name.t*glob_constr) list * glob_constr val glob_decompose_prod_or_letin : - glob_constr -> (Names.name*glob_constr option*glob_constr option) list * glob_constr -val glob_decompose_prod_n : int -> glob_constr -> (Names.name*glob_constr) list * glob_constr + 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 -> - (Names.name*glob_constr option*glob_constr option) list * glob_constr -val glob_compose_prod : glob_constr -> (Names.name*glob_constr) list -> 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 -> - (Names.name*glob_constr option*glob_constr option) list -> glob_constr + (Name.t*glob_constr option*glob_constr option) list -> glob_constr val glob_decompose_app : glob_constr -> glob_constr*(glob_constr list) @@ -60,7 +58,7 @@ val glob_make_or_list : glob_constr list -> glob_constr (* Replace the var mapped in the glob_constr/context *) -val change_vars : Names.identifier Names.Idmap.t -> glob_constr -> glob_constr +val change_vars : Id.t Id.Map.t -> glob_constr -> glob_constr @@ -72,27 +70,27 @@ val change_vars : Names.identifier Names.Idmap.t -> glob_constr -> glob_constr [avoid] with the variables appearing in the result. *) val alpha_pat : - Names.Idmap.key list -> + Id.Map.key list -> Glob_term.cases_pattern -> - Glob_term.cases_pattern * Names.Idmap.key list * - Names.identifier Names.Idmap.t + Glob_term.cases_pattern * Id.Map.key list * + Id.t Id.Map.t (* [alpha_rt avoid rt] alpha convert [rt] s.t. the result repects barendregt conventions and does not share bound variables with avoid *) -val alpha_rt : Names.identifier list -> glob_constr -> glob_constr +val alpha_rt : Id.t list -> glob_constr -> glob_constr (* same as alpha_rt but for case branches *) -val alpha_br : Names.identifier list -> - Util.loc * Names.identifier list * Glob_term.cases_pattern list * +val alpha_br : Id.t list -> + Loc.t * Id.t list * Glob_term.cases_pattern list * Glob_term.glob_constr -> - Util.loc * Names.identifier list * Glob_term.cases_pattern list * + Loc.t * Id.t list * Glob_term.cases_pattern list * Glob_term.glob_constr (* Reduction function *) val replace_var_by_term : - Names.identifier -> + Id.t -> Glob_term.glob_constr -> Glob_term.glob_constr -> Glob_term.glob_constr @@ -100,7 +98,7 @@ val replace_var_by_term : (* [is_free_in id rt] checks if [id] is a free variable in [rt] *) -val is_free_in : Names.identifier -> glob_constr -> bool +val is_free_in : Id.t -> glob_constr -> bool val are_unifiable : cases_pattern -> cases_pattern -> bool @@ -109,13 +107,13 @@ val eq_cases_pattern : cases_pattern -> cases_pattern -> bool (* - ids_of_pat : cases_pattern -> Idset.t + ids_of_pat : cases_pattern -> Id.Set.t returns the set of variables appearing in a pattern *) -val ids_of_pat : cases_pattern -> Names.Idset.t +val ids_of_pat : cases_pattern -> Id.Set.t (* TODO: finish this function (Fix not treated) *) -val ids_of_glob_constr: glob_constr -> Names.Idset.t +val ids_of_glob_constr: glob_constr -> Id.Set.t (* removing let_in construction in a glob_constr diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index d2c065a0..6dbd61cf 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -1,11 +1,16 @@ +open Errors open Util open Names open Term open Pp open Indfun_common open Libnames +open Globnames open Glob_term open Declarations +open Declareops +open Misctypes +open Decl_kinds let is_rec_info scheme_info = let test_branche min acc (_,_,br) = @@ -14,15 +19,13 @@ let is_rec_info scheme_info = it_mkProd_or_LetIn mkProp (fst (decompose_prod_assum br)) in let free_rels_in_br = Termops.free_rels new_branche in let max = min + scheme_info.Tactics.npredicates in - Util.Intset.exists (fun i -> i >= min && i< max) free_rels_in_br + Int.Set.exists (fun i -> i >= min && i< max) free_rels_in_br ) in - Util.list_fold_left_i test_branche 1 false (List.rev scheme_info.Tactics.branches) + List.fold_left_i test_branche 1 false (List.rev scheme_info.Tactics.branches) let choose_dest_or_ind scheme_info = - if is_rec_info scheme_info - then Tactics.new_induct false - else Tactics.new_destruct false + Tactics.induction_destruct (is_rec_info scheme_info) false let functional_induction with_clean c princl pat = Dumpglob.pause (); @@ -33,7 +36,7 @@ let functional_induction with_clean c princl pat = | None -> (* No principle is given let's find the good one *) begin match kind_of_term f with - | Const c' -> + | Const (c',u) -> let princ_option = let finfo = (* we first try to find out a graph on f *) try find_Function_infos c' @@ -54,7 +57,7 @@ let functional_induction with_clean c princl pat = (or f_rec, f_rect) i*) let princ_name = Indrec.make_elimination_ident - (id_of_label (con_label c')) + (Label.to_id (con_label c')) (Tacticals.elimination_sort_of_goal g) in try @@ -63,7 +66,7 @@ let functional_induction with_clean c princl pat = errorlabstrm "" (str "Cannot find induction principle for " ++Printer.pr_lconstr (mkConst c') ) in - (princ,Glob_term.NoBindings, Tacmach.pf_type_of g princ) + (princ,NoBindings, Tacmach.pf_type_of g princ) | _ -> raise (UserError("",str "functional induction must be used with a function" )) end | Some ((princ,binding)) -> @@ -75,50 +78,43 @@ let functional_induction with_clean c princl pat = if princ_infos.Tactics.farg_in_concl then [c] else [] in - List.map (fun c -> Tacexpr.ElimOnConstr (Evd.empty,(c,NoBindings))) (args@c_list) + 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 (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 Idset.add (destVar a) acc - with e when Errors.noncritical e -> acc - ) + (fun a acc -> try Id.Set.add (destVar a) acc with DestKO -> acc) args - Idset.empty + Id.Set.empty in - let old_idl = List.fold_right Idset.add (Tacmach.pf_ids_of_hyps g) Idset.empty in - let old_idl = Idset.diff old_idl princ_vars in + let old_idl = List.fold_right Id.Set.add (Tacmach.pf_ids_of_hyps g) Id.Set.empty in + let old_idl = Id.Set.diff old_idl princ_vars in let subst_and_reduce g = if with_clean then let idl = - map_succeed - (fun id -> - if Idset.mem id old_idl then failwith "subst_and_reduce"; - id - ) + List.filter (fun id -> not (Id.Set.mem id old_idl)) (Tacmach.pf_ids_of_hyps g) in let flag = - Glob_term.Cbv - {Glob_term.all_flags - with Glob_term.rDelta = false; + Genredexpr.Cbv + {Redops.all_flags + with Genredexpr.rDelta = false; } in Tacticals.tclTHEN - (Tacticals.tclMAP (fun id -> Tacticals.tclTRY (Equality.subst_gen (do_rewrite_dependent ()) [id])) idl ) - (Hiddentac.h_reduce flag Tacticals.allHypsAndConcl) + (Tacticals.tclMAP (fun id -> Tacticals.tclTRY (Proofview.V82.of_tactic (Equality.subst_gen (do_rewrite_dependent ()) [id]))) idl ) + (Tactics.reduce flag Locusops.allHypsAndConcl) g else Tacticals.tclIDTAC g in Tacticals.tclTHEN - (choose_dest_or_ind + (Proofview.V82.of_tactic (choose_dest_or_ind princ_infos - args_as_induction_constr - princ' - (None,pat) - None) + (args_as_induction_constr,princ'))) subst_and_reduce g in @@ -127,14 +123,14 @@ let functional_induction with_clean c princl pat = let rec abstract_glob_constr c = function | [] -> c - | Topconstr.LocalRawDef (x,b)::bl -> Topconstr.mkLetInC(x,b,abstract_glob_constr c bl) - | Topconstr.LocalRawAssum (idl,k,t)::bl -> - List.fold_right (fun x b -> Topconstr.mkLambdaC([x],k,t,b)) idl + | Constrexpr.LocalRawDef (x,b)::bl -> Constrexpr_ops.mkLetInC(x,b,abstract_glob_constr c bl) + | Constrexpr.LocalRawAssum (idl,k,t)::bl -> + List.fold_right (fun x b -> Constrexpr_ops.mkLambdaC([x],k,t,b)) idl (abstract_glob_constr c bl) -let interp_casted_constr_with_implicits sigma env impls c = - Constrintern.intern_gen false sigma env ~impls - ~allow_patvar:false ~ltacvars:([],[]) c +let interp_casted_constr_with_implicits env sigma impls c = + Constrintern.intern_gen Pretyping.WithoutTypeConstraint env ~impls + ~allow_patvar:false c (* Construct a fixpoint as a Glob_term @@ -149,26 +145,21 @@ let build_newrecursive let (rec_sign,rec_impls) = List.fold_left (fun (env,impls) ((_,recname),bl,arityc,_) -> - let arityc = Topconstr.prod_constr_expr arityc bl in - let arity = Constrintern.interp_type sigma env0 arityc in - let impl = Constrintern.compute_internalization_data env0 Constrintern.Recursive arity [] in - (Environ.push_named (recname,None,arity) env, Idmap.add recname impl impls)) + let arityc = Constrexpr_ops.prod_constr_expr arityc bl 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 + (Environ.push_named (recname,None,arity) env, Id.Map.add recname impl impls)) (env0,Constrintern.empty_internalization_env) lnameargsardef in let recdef = (* Declare local notations *) - let fs = States.freeze() in - let def = - try - List.map - (fun (_,bl,_,def) -> - let def = abstract_glob_constr def bl in - interp_casted_constr_with_implicits - sigma rec_sign rec_impls def - ) - lnameargsardef - with reraise -> - States.unfreeze fs; raise reraise in - States.unfreeze fs; def + let f (_,bl,_,def) = + let def = abstract_glob_constr def bl in + interp_casted_constr_with_implicits + rec_sign sigma rec_impls def + in + States.with_state_protection (List.map f) lnameargsardef in recdef,rec_impls @@ -178,15 +169,15 @@ let build_newrecursive l = match body_opt with | Some body -> (fixna,bll,ar,body) - | None -> user_err_loc (dummy_loc,"Function",str "Body of Function must be given") + | None -> user_err_loc (Loc.ghost,"Function",str "Body of Function must be given") ) l in build_newrecursive l' (* Checks whether or not the mutual bloc is recursive *) -let rec is_rec names = - let names = List.fold_right Idset.add names Idset.empty in - let check_id id names = Idset.mem id names in +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 | GRef _ | GEvar _ | GPatVar _ | GSort _ | GHole _ -> false @@ -195,11 +186,11 @@ let rec is_rec names = | 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 Idset.remove na names) b + lookup names t || lookup (Nameops.name_fold Id.Set.remove na names) b | GLetTuple(_,nal,_,t,b) -> lookup names t || lookup (List.fold_left - (fun acc na -> Nameops.name_fold Idset.remove na acc) + (fun acc na -> Nameops.name_fold Id.Set.remove na acc) names nal ) @@ -209,7 +200,7 @@ let rec is_rec names = List.exists (fun (e,_) -> lookup names e) el || List.exists (lookup_br names) brl and lookup_br names (_,idl,_,rt) = - let new_names = List.fold_right Idset.remove idl names in + let new_names = List.fold_right Id.Set.remove idl names in lookup new_names rt in lookup names @@ -217,8 +208,8 @@ let rec is_rec names = let rec local_binders_length = function (* Assume that no `{ ... } contexts occur *) | [] -> 0 - | Topconstr.LocalRawDef _::bl -> 1 + local_binders_length bl - | Topconstr.LocalRawAssum (idl,_,_)::bl -> List.length idl + local_binders_length bl + | Constrexpr.LocalRawDef _::bl -> 1 + local_binders_length bl + | Constrexpr.LocalRawAssum (idl,_,_)::bl -> List.length idl + local_binders_length bl let prepare_body ((name,_,args,types,_),_) rt = let n = local_binders_length args in @@ -226,12 +217,14 @@ let prepare_body ((name,_,args,types,_),_) rt = let fun_args,rt' = chop_rlambda_n n rt in (fun_args,rt') +let process_vernac_interp_error e = + fst (Cerrors.process_vernac_interp_error (e, Exninfo.null)) let derive_inversion fix_names = try (* we first transform the fix_names identifier into their corresponding constant *) let fix_names_as_constant = - List.map (fun id -> destConst (Constrintern.global_reference id)) fix_names + List.map (fun id -> fst (destConst (Constrintern.global_reference id))) fix_names in (* Then we check that the graphs have been defined @@ -248,38 +241,45 @@ let derive_inversion fix_names = Ensures by : register_built i*) (List.map - (fun id -> destInd (Constrintern.global_reference (mk_rel_id id))) + (fun id -> fst (destInd (Constrintern.global_reference (mk_rel_id id)))) fix_names ) with e when Errors.noncritical e -> - let e' = Cerrors.process_vernac_interp_error e in + let e' = process_vernac_interp_error e in msg_warning (str "Cannot build inversion information" ++ if do_observe () then (fnl() ++ Errors.print e') else mt ()) with e when Errors.noncritical e -> () let warning_error names e = - let e = Cerrors.process_vernac_interp_error e in + let e = process_vernac_interp_error e in let e_explain e = match e with - | ToShow e -> spc () ++ Errors.print e - | _ -> if do_observe () then (spc () ++ Errors.print e) else mt () + | ToShow e -> + let e = process_vernac_interp_error e in + spc () ++ Errors.print e + | _ -> + if do_observe () + then + let e = process_vernac_interp_error e in + (spc () ++ Errors.print e) + else mt () in match e with | Building_graph e -> - Pp.msg_warning - (str "Cannot define graph(s) for " ++ - h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++ - e_explain e) + Pp.msg_warning + (str "Cannot define graph(s) for " ++ + h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++ + e_explain e) | Defining_principle e -> - Pp.msg_warning - (str "Cannot define principle(s) for "++ - h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++ - e_explain e) + Pp.msg_warning + (str "Cannot define principle(s) for "++ + h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++ + e_explain e) | _ -> raise e let error_error names e = - let e = Cerrors.process_vernac_interp_error e in + let e = process_vernac_interp_error e in let e_explain e = match e with | ToShow e -> spc () ++ Errors.print e @@ -293,7 +293,7 @@ let error_error names e = e_explain e) | _ -> raise e -let generate_principle on_error +let generate_principle mp_dp 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 -> Tacmach.tactic) : unit = @@ -303,14 +303,14 @@ let generate_principle on_error let funs_types = List.map (function ((_,_,_,types,_),_) -> types) fix_rec_l in try (* We then register the Inductive graphs of the functions *) - Glob_term_to_relation.build_inductive names funs_args funs_types recdefs; + Glob_term_to_relation.build_inductive mp_dp names funs_args funs_types recdefs; if do_built then begin (*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 (dummy_loc,mk_rel_id (List.nth names 0)) in + let f_R_mut = Ident (Loc.ghost,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!") @@ -326,11 +326,10 @@ let generate_principle on_error in let funs_kn = Array.of_list (List.map fname_kn fix_rec_l) in let _ = - list_map_i + List.map_i (fun i x -> - let princ = destConst (Indrec.lookup_eliminator (ind_kn,i) (InProp)) in - let princ_type = Typeops.type_of_constant (Global.env()) princ - in + let princ = Indrec.lookup_eliminator (ind_kn,i) (InProp) in + let princ_type = Global.type_of_global_unsafe princ in Functional_principles_types.generate_functional_principle interactive_proof princ_type @@ -352,15 +351,11 @@ let generate_principle on_error let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) = match fixpoint_exprl with | [((_,fname),_,bl,ret_type,body),_] when not is_rec -> - let body = match body with | Some body -> body | None -> user_err_loc (dummy_loc,"Function",str "Body of Function must be given") in - let ce,imps = - Command.interp_definition bl None body (Some ret_type) - in - Command.declare_definition - fname (Decl_kinds.Global,Decl_kinds.Definition) - ce imps (fun _ _ -> ()) + let body = match body with | Some body -> body | None -> user_err_loc (Loc.ghost,"Function",str "Body of Function must be given") in + Command.do_definition fname (Decl_kinds.Global,(*FIXME*)false,Decl_kinds.Definition) + bl None body (Some ret_type) (Lemmas.mk_hook (fun _ _ -> ())) | _ -> - Command.do_fixpoint fixpoint_exprl + Command.do_fixpoint Global false(*FIXME*) fixpoint_exprl let generate_correction_proof_wf f_ref tcc_lemma_ref is_mes functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation @@ -373,39 +368,39 @@ 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 = Topconstr.prod_constr_expr ret_type args in + let type_of_f = Constrexpr_ops.prod_constr_expr ret_type args in let rec_arg_num = let names = List.map snd - (Topconstr.names_of_local_assums args) + (Constrexpr_ops.names_of_local_assums args) in match wf_arg with | None -> - if List.length names = 1 then 1 + if Int.equal (List.length names) 1 then 1 else error "Recursive argument must be specified" | Some wf_arg -> - list_index (Name wf_arg) names + List.index Name.equal (Name wf_arg) names in let unbounded_eq = let f_app_args = - Topconstr.CAppExpl - (dummy_loc, - (None,(Ident (dummy_loc,fname))) , + Constrexpr.CAppExpl + (Loc.ghost, + (None,(Ident (Loc.ghost,fname)),None) , (List.map (function | _,Anonymous -> assert false - | _,Name e -> (Topconstr.mkIdentC e) + | _,Name e -> (Constrexpr_ops.mkIdentC e) ) - (Topconstr.names_of_local_assums args) + (Constrexpr_ops.names_of_local_assums args) ) ) in - Topconstr.CApp (dummy_loc,(None,Topconstr.mkRefC (Qualid (dummy_loc,(qualid_of_string "Logic.eq")))), + Constrexpr.CApp (Loc.ghost,(None,Constrexpr_ops.mkRefC (Qualid (Loc.ghost,(qualid_of_string "Logic.eq")))), [(f_app_args,None);(body,None)]) in - let eq = Topconstr.prod_constr_expr unbounded_eq args in - let hook f_ref tcc_lemma_ref functional_ref eq_ref rec_arg_num rec_arg_type + let eq = Constrexpr_ops.prod_constr_expr unbounded_eq args in + let hook (f_ref,_) tcc_lemma_ref (functional_ref,_) (eq_ref,_) rec_arg_num rec_arg_type nb_args relation = try pre_hook @@ -433,7 +428,7 @@ let register_mes fname rec_impls wf_mes_expr wf_rel_expr_opt wf_arg using_lemmas | None -> begin match args with - | [Topconstr.LocalRawAssum ([(_,Name x)],k,t)] -> t,x + | [Constrexpr.LocalRawAssum ([(_,Name x)],k,t)] -> t,x | _ -> error "Recursive argument must be specified" end | Some wf_args -> @@ -441,15 +436,15 @@ let register_mes fname rec_impls wf_mes_expr wf_rel_expr_opt wf_arg using_lemmas match List.find (function - | Topconstr.LocalRawAssum(l,k,t) -> + | Constrexpr.LocalRawAssum(l,k,t) -> List.exists - (function (_,Name id) -> id = wf_args | _ -> false) + (function (_,Name id) -> Id.equal id wf_args | _ -> false) l | _ -> false ) args with - | Topconstr.LocalRawAssum(_,k,t) -> t,wf_args + | Constrexpr.LocalRawAssum(_,k,t) -> t,wf_args | _ -> assert false with Not_found -> assert false in @@ -457,31 +452,31 @@ let register_mes fname rec_impls wf_mes_expr wf_rel_expr_opt wf_arg using_lemmas match wf_rel_expr_opt with | None -> let ltof = - let make_dir l = make_dirpath (List.map id_of_string (List.rev l)) in - Libnames.Qualid (dummy_loc,Libnames.qualid_of_path - (Libnames.make_path (make_dir ["Arith";"Wf_nat"]) (id_of_string "ltof"))) + let make_dir l = DirPath.make (List.rev_map Id.of_string l) in + Libnames.Qualid (Loc.ghost,Libnames.qualid_of_path + (Libnames.make_path (make_dir ["Arith";"Wf_nat"]) (Id.of_string "ltof"))) in let fun_from_mes = let applied_mes = - Topconstr.mkAppC(wf_mes_expr,[Topconstr.mkIdentC wf_arg]) in - Topconstr.mkLambdaC ([(dummy_loc,Name wf_arg)],Topconstr.default_binder_kind,wf_arg_type,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) in let wf_rel_from_mes = - Topconstr.mkAppC(Topconstr.mkRefC ltof,[wf_arg_type;fun_from_mes]) + Constrexpr_ops.mkAppC(Constrexpr_ops.mkRefC ltof,[wf_arg_type;fun_from_mes]) in wf_rel_from_mes,true | Some wf_rel_expr -> let wf_rel_with_mes = - let a = Names.id_of_string "___a" in - let b = Names.id_of_string "___b" in - Topconstr.mkLambdaC( - [dummy_loc,Name a;dummy_loc,Name b], - Topconstr.Default Lib.Explicit, + 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], + Constrexpr.Default Explicit, wf_arg_type, - Topconstr.mkAppC(wf_rel_expr, + Constrexpr_ops.mkAppC(wf_rel_expr, [ - Topconstr.mkAppC(wf_mes_expr,[Topconstr.mkIdentC a]); - Topconstr.mkAppC(wf_mes_expr,[Topconstr.mkIdentC b]) + Constrexpr_ops.mkAppC(wf_mes_expr,[Constrexpr_ops.mkIdentC a]); + Constrexpr_ops.mkAppC(wf_mes_expr,[Constrexpr_ops.mkIdentC b]) ]) ) in @@ -493,124 +488,62 @@ let register_mes fname rec_impls wf_mes_expr wf_rel_expr_opt wf_arg using_lemmas let map_option f = function | None -> None | Some v -> Some (f v) - -let decompose_lambda_n_assum_constr_expr = - let rec decompose_lambda_n_assum_constr_expr acc n e = - if n = 0 then (List.rev acc,e) - else - match e with - | Topconstr.CLambdaN(_, [],e') -> decompose_lambda_n_assum_constr_expr acc n e' - | Topconstr.CLambdaN(lambda_loc,(nal,bk,nal_type)::bl,e') -> - let nal_length = List.length nal in - if nal_length <= n - then - decompose_lambda_n_assum_constr_expr - (Topconstr.LocalRawAssum(nal,bk,nal_type)::acc) - (n - nal_length) - (Topconstr.CLambdaN(lambda_loc,bl,e')) - else - let nal_keep,nal_expr = list_chop n nal in - (List.rev (Topconstr.LocalRawAssum(nal_keep,bk,nal_type)::acc), - Topconstr.CLambdaN(lambda_loc,(nal_expr,bk,nal_type)::bl,e') - ) - | Topconstr.CLetIn(_, na,nav,e') -> - decompose_lambda_n_assum_constr_expr - (Topconstr.LocalRawDef(na,nav)::acc) (pred n) e' - | _ -> error "Not enough product or assumption" - in - decompose_lambda_n_assum_constr_expr [] - -let decompose_prod_n_assum_constr_expr = - let rec decompose_prod_n_assum_constr_expr acc n e = - (* Pp.msgnl (str "n := " ++ int n ++ fnl ()++ *) - (* str "e := " ++ Ppconstr.pr_lconstr_expr e); *) - if n = 0 then - (* let _ = Pp.msgnl (str "return_type := " ++ Ppconstr.pr_lconstr_expr e) in *) - (List.rev acc,e) - else - match e with - | Topconstr.CProdN(_, [],e') -> decompose_prod_n_assum_constr_expr acc n e' - | Topconstr.CProdN(lambda_loc,(nal,bk,nal_type)::bl,e') -> - let nal_length = List.length nal in - if nal_length <= n - then - (* let _ = Pp.msgnl (str "first case") in *) - decompose_prod_n_assum_constr_expr - (Topconstr.LocalRawAssum(nal,bk,nal_type)::acc) - (n - nal_length) - (if bl = [] then e' else (Topconstr.CLambdaN(lambda_loc,bl,e'))) - else - (* let _ = Pp.msgnl (str "second case") in *) - let nal_keep,nal_expr = list_chop n nal in - (List.rev (Topconstr.LocalRawAssum(nal_keep,bk,nal_type)::acc), - Topconstr.CLambdaN(lambda_loc,(nal_expr,bk,nal_type)::bl,e') - ) - | Topconstr.CArrow(_,premisse,concl) -> - (* let _ = Pp.msgnl (str "arrow case") in *) - decompose_prod_n_assum_constr_expr - (Topconstr.LocalRawAssum([dummy_loc,Names.Anonymous], - Topconstr.Default Lib.Explicit,premisse) - ::acc) - (pred n) - concl - | Topconstr.CLetIn(_, na,nav,e') -> - decompose_prod_n_assum_constr_expr - (Topconstr.LocalRawDef(na,nav)::acc) (pred n) e' - | _ -> error "Not enough product or assumption" - in - decompose_prod_n_assum_constr_expr [] +open Constrexpr open Topconstr - -let id_of_name = function - | Name id -> id - | _ -> assert false - let rec rebuild_bl (aux,assoc) bl typ = +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) - | (Topconstr.LocalRawAssum(nal,bk,_))::bl',typ -> + | (Constrexpr.LocalRawAssum(nal,bk,_))::bl',typ -> rebuild_nal (aux,assoc) bk bl' nal (List.length nal) typ - | (Topconstr.LocalRawDef(na,_))::bl',CLetIn(_,_,nat,typ') -> - rebuild_bl ((Topconstr.LocalRawDef(na,replace_vars_constr_expr assoc nat)::aux),assoc) + | (Constrexpr.LocalRawDef(na,_))::bl',Constrexpr.CLetIn(_,_,nat,typ') -> + rebuild_bl ((Constrexpr.LocalRawDef(na,replace_vars_constr_expr assoc nat)::aux),assoc) bl' typ' | _ -> assert false and rebuild_nal (aux,assoc) bk bl' nal lnal typ = match nal,typ with | [], _ -> rebuild_bl (aux,assoc) bl' typ - | na::nal,CArrow(_,nat,typ') -> - rebuild_nal - ((LocalRawAssum([na],bk,replace_vars_constr_expr assoc nat))::aux,assoc) - bk bl' nal (pred lnal) 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 - rebuild_bl ((LocalRawAssum(nal,bk,replace_vars_constr_expr assoc nal't)::aux),(List.rev_append (List.combine (List.map id_of_name (List.map snd old_nal')) (List.map id_of_name (List.map snd nal))) assoc)) bl' - (if new_nal' = [] && rest = [] - then typ' - else if new_nal' = [] - then CProdN(dummy_loc,rest,typ') - else CProdN(dummy_loc,((new_nal',bk',nal't)::rest),typ')) + 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 - rebuild_nal ((LocalRawAssum(captured_nal,bk,replace_vars_constr_expr assoc nal't)::aux), (List.rev_append (List.combine (List.map id_of_name (List.map snd captured_nal)) ((List.map id_of_name (List.map snd nal)))) assoc)) - bk bl' non_captured_nal (lnal - lnal') (CProdN(dummy_loc,rest,typ')) + 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 let recompute_binder_list (fixpoint_exprl : (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) = let fixl,ntns = Command.extract_fixpoint_components false fixpoint_exprl in - let ((_,_,typel),_) = Command.interp_fixpoint fixl ntns in + let ((_,_,typel),_,_) = Command.interp_fixpoint fixl ntns in let constr_expr_typel = - with_full_print (List.map (Constrextern.extern_constr false (Global.env ()))) typel in + with_full_print (List.map (Constrextern.extern_constr false (Global.env ()) Evd.empty)) 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 ([],[]) bl fix_typ in + let new_bl',new_ret_type,_ = rebuild_bl ([],Id.Map.empty) 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 @@ -618,23 +551,24 @@ let recompute_binder_list (fixpoint_exprl : (Vernacexpr.fixpoint_expr * Vernacex fixpoint_exprl_with_new_bl -let do_generate_principle on_error register_built interactive_proof +let do_generate_principle mp_dp on_error register_built interactive_proof (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) :unit = - List.iter (fun (_,l) -> if l <> [] then error "Function does not support notations for now") fixpoint_exprl; + List.iter (fun (_,l) -> if not (List.is_empty l) then error "Function does not support notations for now") fixpoint_exprl; let _is_struct = match fixpoint_exprl with - | [((_,(wf_x,Topconstr.CWfRec wf_rel),_,_,_),_) as fixpoint_expr] -> + | [((_,(wf_x,Constrexpr.CWfRec wf_rel),_,_,_),_) as fixpoint_expr] -> let ((((_,name),_,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 (dummy_loc,"Function",str "Body of Function must be given") 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 recdefs,rec_impls = build_newrecursive fixpoint_exprl in let using_lemmas = [] in let pre_hook = generate_principle + mp_dp on_error true register_built @@ -645,7 +579,7 @@ let do_generate_principle on_error register_built interactive_proof if register_built then register_wf name rec_impls wf_rel (map_option snd wf_x) using_lemmas args types body pre_hook; false - |[((_,(wf_x,Topconstr.CMeasureRec(wf_mes,wf_rel_opt)),_,_,_),_) as fixpoint_expr] -> + |[((_,(wf_x,Constrexpr.CMeasureRec(wf_mes,wf_rel_opt)),_,_,_),_) as fixpoint_expr] -> let ((((_,name),_,args,types,body)),_) as fixpoint_expr = match recompute_binder_list [fixpoint_expr] with | [e] -> e @@ -654,9 +588,10 @@ let do_generate_principle 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 (dummy_loc,"Function",str "Body of Function must be given") 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 pre_hook = generate_principle + mp_dp on_error true register_built @@ -670,7 +605,7 @@ let do_generate_principle on_error register_built interactive_proof | _ -> List.iter (function ((_na,(_,ord),_args,_body,_type),_not) -> match ord with - | Topconstr.CMeasureRec _ | Topconstr.CWfRec _ -> + | Constrexpr.CMeasureRec _ | Constrexpr.CWfRec _ -> error ("Cannot use mutual definition with well-founded recursion or measure") | _ -> () @@ -685,6 +620,7 @@ let do_generate_principle on_error register_built interactive_proof let is_rec = List.exists (is_rec fix_names) recdefs in if register_built then register_struct is_rec fixpoint_exprl; generate_principle + mp_dp on_error false register_built @@ -697,18 +633,15 @@ let do_generate_principle on_error register_built interactive_proof in () -open Topconstr let rec add_args id new_args b = match b with - | CRef r -> + | CRef (r,_) -> begin match r with - | Libnames.Ident(loc,fname) when fname = id -> - CAppExpl(dummy_loc,(None,r),new_args) + | Libnames.Ident(loc,fname) when Id.equal fname id -> + CAppExpl(Loc.ghost,(None,r,None),new_args) | _ -> b end - | CFix _ | CCoFix _ -> anomaly "add_args : todo" - | CArrow(loc,b1,b2) -> - CArrow(loc,add_args id new_args b1, add_args id new_args b2) + | 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, @@ -719,12 +652,12 @@ let rec add_args id new_args b = add_args id new_args b1) | CLetIn(loc,na,b1,b2) -> CLetIn(loc,na,add_args id new_args b1,add_args id new_args b2) - | CAppExpl(loc,(pf,r),exprl) -> + | CAppExpl(loc,(pf,r,us),exprl) -> begin match r with - | Libnames.Ident(loc,fname) when fname = id -> - CAppExpl(loc,(pf,r),new_args@(List.map (add_args id new_args) exprl)) - | _ -> CAppExpl(loc,(pf,r),List.map (add_args id new_args) exprl) + | 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) end | CApp(loc,(pf,b),bl) -> CApp(loc,(pf,add_args id new_args b), @@ -733,7 +666,7 @@ let rec add_args id new_args b = CCases(loc,sty,Option.map (add_args id new_args) b_option, List.map (fun (b,(na,b_option)) -> add_args id new_args b, - (na,Option.map (add_args id new_args) b_option)) cel, + (na, b_option)) cel, List.map (fun (loc,cpl,e) -> (loc,cpl,add_args id new_args e)) cal ) | CLetTuple(loc,nal,(na,b_option),b1,b2) -> @@ -752,32 +685,29 @@ let rec add_args id new_args b = | CPatVar _ -> b | CEvar _ -> b | CSort _ -> b - | CCast(loc,b1,CastConv(ck,b2)) -> - CCast(loc,add_args id new_args b1,CastConv(ck,add_args id new_args b2)) - | CCast(loc,b1,CastCoerce) -> - CCast(loc,add_args id new_args b1,CastCoerce) + | CCast(loc,b1,b2) -> + CCast(loc,add_args id new_args b1, + Miscops.map_cast_type (add_args id new_args) b2) | CRecord (loc, w, pars) -> CRecord (loc, (match w with Some w -> Some (add_args id new_args w) | _ -> None), List.map (fun (e,o) -> e, add_args id new_args o) pars) - | CNotation _ -> anomaly "add_args : CNotation" - | CGeneralization _ -> anomaly "add_args : CGeneralization" + | CNotation _ -> anomaly ~label:"add_args " (Pp.str "CNotation") + | CGeneralization _ -> anomaly ~label:"add_args " (Pp.str "CGeneralization") | CPrim _ -> b - | CDelimiters _ -> anomaly "add_args : CDelimiters" -exception Stop of Topconstr.constr_expr + | CDelimiters _ -> anomaly ~label:"add_args " (Pp.str "CDelimiters") +exception Stop of Constrexpr.constr_expr (* [chop_n_arrow n t] chops the [n] first arrows in [t] - Acts on Topconstr.constr_expr + Acts on Constrexpr.constr_expr *) 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 - | Topconstr.CArrow(_,_,t) -> (* If we have an arrow, we discard it and recall [chop_n_arrow] *) - chop_n_arrow (n-1) t - | Topconstr.CProdN(_,nal_ta',t') -> (* If we have a forall, to result are possible : + | Constrexpr.CProdN(_,nal_ta',t') -> (* If we have a forall, to result 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 @@ -796,8 +726,8 @@ let rec chop_n_arrow n t = aux (n - nal_l) nal_ta' else let new_t' = - Topconstr.CProdN(dummy_loc, - ((snd (list_chop n nal)),k,t'')::nal_ta',t') + Constrexpr.CProdN(Loc.ghost, + ((snd (List.chop n nal)),k,t'')::nal_ta',t') in raise (Stop new_t') in @@ -806,13 +736,13 @@ let rec chop_n_arrow n t = chop_n_arrow new_n t' with Stop t -> t end - | _ -> anomaly "Not enough products" + | _ -> anomaly (Pp.str "Not enough products") -let rec get_args b t : Topconstr.local_binder list * - Topconstr.constr_expr * Topconstr.constr_expr = +let rec get_args b t : Constrexpr.local_binder list * + Constrexpr.constr_expr * Constrexpr.constr_expr = match b with - | Topconstr.CLambdaN (loc, (nal_ta), b') -> + | Constrexpr.CLambdaN (loc, (nal_ta), b') -> begin let n = (List.fold_left (fun n (nal,_,_) -> @@ -820,7 +750,7 @@ let rec get_args b t : Topconstr.local_binder list * in let nal_tas,b'',t'' = get_args b' (chop_n_arrow n t) in (List.map (fun (nal,k,ta) -> - (Topconstr.LocalRawAssum (nal,k,ta))) nal_ta)@nal_tas, b'',t'' + (Constrexpr.LocalRawAssum (nal,k,ta))) nal_ta)@nal_tas, b'',t'' end | _ -> [],b,t @@ -836,17 +766,15 @@ let make_graph (f_ref:global_reference) = | _ -> raise (UserError ("", str "Not a function reference") ) in Dumpglob.pause (); - (match body_of_constant c_body with + (match Global.body_of_constant_body c_body with | None -> error "Cannot build a graph over an axiom !" - | Some b -> + | Some body -> let env = Global.env () in - let body = (force b) in let extern_body,extern_type = - with_full_print - (fun () -> - (Constrextern.extern_constr false env body, - Constrextern.extern_type false env - (Typeops.type_of_constant_type env c_body.const_type) + with_full_print (fun () -> + (Constrextern.extern_constr false env Evd.empty body, + Constrextern.extern_type false env Evd.empty + ((*FIXNE*) Typeops.type_of_constant_type env c_body.const_type) ) ) () @@ -854,7 +782,7 @@ let make_graph (f_ref:global_reference) = let (nal_tas,b,t) = get_args extern_body extern_type in let expr_list = match b with - | Topconstr.CFix(loc,l_id,fixexprl) -> + | Constrexpr.CFix(loc,l_id,fixexprl) -> let l = List.map (fun (id,(n,recexp),bl,t,b) -> @@ -863,34 +791,34 @@ let make_graph (f_ref:global_reference) = List.flatten (List.map (function - | Topconstr.LocalRawDef (na,_)-> [] - | Topconstr.LocalRawAssum (nal,_,_) -> + | Constrexpr.LocalRawDef (na,_)-> [] + | Constrexpr.LocalRawAssum (nal,_,_) -> List.map (fun (loc,n) -> - CRef(Libnames.Ident(loc, Nameops.out_name n))) + CRef(Libnames.Ident(loc, Nameops.out_name n),None)) nal ) nal_tas ) in let b' = add_args (snd id) new_args b in - (((id, ( Some (dummy_loc,rec_id),CStructRec),nal_tas@bl,t,Some b'),[]):(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list)) + (((id, ( Some (Loc.ghost,rec_id),CStructRec),nal_tas@bl,t,Some b'),[]):(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list)) ) fixexprl in l | _ -> - let id = id_of_label (con_label c) in - [((dummy_loc,id),(None,Topconstr.CStructRec),nal_tas,t,Some b),[]] + let id = Label.to_id (con_label c) in + [((Loc.ghost,id),(None,Constrexpr.CStructRec),nal_tas,t,Some b),[]] in - do_generate_principle error_error false false expr_list; - (* We register the infos *) let mp,dp,_ = repr_con c in + do_generate_principle (Some (mp,dp)) 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 (((_,id),_,_,_,_),_) -> add_Function false (make_con mp dp (Label.of_id id))) expr_list); Dumpglob.continue () -let do_generate_principle = do_generate_principle warning_error true +let do_generate_principle = do_generate_principle None warning_error true diff --git a/plugins/funind/indfun.mli b/plugins/funind/indfun.mli index e65b5808..e7206914 100644 --- a/plugins/funind/indfun.mli +++ b/plugins/funind/indfun.mli @@ -1,11 +1,4 @@ -open Util -open Names -open Term -open Pp -open Indfun_common -open Libnames -open Glob_term -open Declarations +open Misctypes val do_generate_principle : bool -> @@ -16,9 +9,9 @@ val do_generate_principle : val functional_induction : bool -> Term.constr -> - (Term.constr * Term.constr Glob_term.bindings) option -> - Genarg.intro_pattern_expr Util.located option -> + (Term.constr * Term.constr bindings) option -> + Tacexpr.or_and_intro_pattern option -> Proof_type.goal Tacmach.sigma -> Proof_type.goal list Evd.sigma -val make_graph : Libnames.global_reference -> unit +val make_graph : Globnames.global_reference -> unit diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index 827191b1..76f8c6d2 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -1,9 +1,9 @@ open Names open Pp - open Libnames - -let mk_prefix pre id = id_of_string (pre^(string_of_id id)) +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" let mk_complete_id id = Nameops.add_suffix (mk_rel_id id) "_complete" @@ -12,10 +12,7 @@ let mk_equation_id id = Nameops.add_suffix id "_equation" let msgnl m = () -let invalid_argument s = raise (Invalid_argument s) - - -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) avoid let fresh_name avoid s = Name (fresh_id avoid s) @@ -29,7 +26,7 @@ let array_get_start a = (Array.length a - 1) (fun i -> a.(i)) with Invalid_argument "index out of bounds" -> - invalid_argument "array_get_start" + invalid_arg "array_get_start" let id_of_name = function Name id -> id @@ -51,10 +48,8 @@ let locate_constant ref = let locate_with_msg msg f x = - try - f x - with - | Not_found -> raise (Util.UserError("", msg)) + try f x + with Not_found -> raise (Errors.UserError("", msg)) let filter_map filter f = @@ -78,7 +73,7 @@ let chop_rlambda_n = | 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 | _ -> - raise (Util.UserError("chop_rlambda_n", + raise (Errors.UserError("chop_rlambda_n", str "chop_rlambda_n: Not enough Lambdas")) in chop_lambda_n [] @@ -90,7 +85,7 @@ let chop_rprod_n = else match rt with | Glob_term.GProd(_,name,k,t,b) -> chop_prod_n ((name,t)::acc) (n-1) b - | _ -> raise (Util.UserError("chop_rprod_n",str "chop_rprod_n: Not enough products")) + | _ -> raise (Errors.UserError("chop_rprod_n",str "chop_rprod_n: Not enough products")) in chop_prod_n [] @@ -111,34 +106,27 @@ let list_add_set_eq eq_fun x l = let const_of_id id = let _,princ_ref = - qualid_of_reference (Libnames.Ident (Util.dummy_loc,id)) + qualid_of_reference (Libnames.Ident (Loc.ghost,id)) in try Nametab.locate_constant princ_ref - with Not_found -> Util.error ("cannot find "^ string_of_id id) + with Not_found -> Errors.error ("cannot find "^ Id.to_string id) let def_of_const t = match (Term.kind_of_term t) with Term.Const sp -> - (try (match Declarations.body_of_constant (Global.lookup_constant sp) with - | Some c -> Declarations.force c + (try (match Environ.constant_opt_value_in (Global.env()) sp with + | Some c -> c | _ -> assert false) - with e when Errors.noncritical e -> assert false) + with Not_found -> assert false) |_ -> assert false let coq_constant s = Coqlib.gen_constant_in_modules "RecursiveDefinition" Coqlib.init_modules s;; -let constant sl s = - constr_of_global - (Nametab.locate (make_qualid(Names.make_dirpath - (List.map id_of_string (List.rev sl))) - (id_of_string s)));; - let find_reference sl s = - (Nametab.locate (make_qualid(Names.make_dirpath - (List.map id_of_string (List.rev sl))) - (id_of_string 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") @@ -147,47 +135,40 @@ let refl_equal = lazy(coq_constant "eq_refl") (* Copy of the standart save mechanism but without the much too *) (* slow reduction function *) (*****************************************************************) -open Declarations open Entries open Decl_kinds open Declare -let definition_message id = - Flags.if_verbose message ((string_of_id id) ^ " is defined") +let definition_message = Declare.definition_message -let save with_clean id const (locality,kind) hook = - let {const_entry_body = pft; - const_entry_secctx = _; - const_entry_type = tpo; - const_entry_opaque = opacity } = const in +let get_locality = function +| Discharge -> true +| Local -> true +| Global -> false + +let save with_clean id const (locality,_,kind) hook = + let fix_exn = Future.fix_exn_of const.Entries.const_entry_body in let l,r = match locality with - | Local when Lib.sections_are_opened () -> - let k = logical_kind_of_goal_kind kind in - let c = SectionLocalDef (pft, tpo, opacity) in + | Discharge when Lib.sections_are_opened () -> + let k = Kindops.logical_kind_of_goal_kind kind in + let c = SectionLocalDef const in let _ = declare_variable id (Lib.cwd(), c, k) in (Local, VarRef id) - | Local -> - let k = logical_kind_of_goal_kind kind in - let kn = declare_constant id (DefinitionEntry const, k) in - (Global, ConstRef kn) - | Global -> - let k = logical_kind_of_goal_kind kind in - let kn = declare_constant id (DefinitionEntry const, k) in - (Global, ConstRef kn) in + | Discharge | Local | Global -> + let local = get_locality locality in + let k = Kindops.logical_kind_of_goal_kind kind in + let kn = declare_constant id ~local (DefinitionEntry const, k) in + (locality, ConstRef kn) + in if with_clean then Pfedit.delete_current_proof (); - hook l r; + Ephemeron.iter_opt hook (fun f -> Lemmas.call_hook fix_exn f l r); definition_message id let cook_proof _ = - let (id,(entry,_,strength,hook)) = Pfedit.cook_proof (fun _ -> ()) in - (id,(entry,strength,hook)) - -let new_save_named opacity = - let id,(const,persistence,hook) = cook_proof true in - let const = { const with const_entry_opaque = opacity } in - save true id const persistence hook + let (id,(entry,_,strength)) = Pfedit.cook_proof () in + (id,(entry,strength)) let get_proof_clean do_reduce = let result = cook_proof do_reduce in @@ -197,7 +178,8 @@ let get_proof_clean do_reduce = let with_full_print f a = let old_implicit_args = Impargs.is_implicit_args () and old_strict_implicit_args = Impargs.is_strict_implicit_args () - and old_contextual_implicit_args = Impargs.is_contextual_implicit_args () in + and old_contextual_implicit_args = Impargs.is_contextual_implicit_args () + in let old_rawprint = !Flags.raw_print in Flags.raw_print := true; Impargs.make_implicit_args false; @@ -248,8 +230,9 @@ type function_info = (* let function_table = ref ([] : function_db) *) -let from_function = ref Cmap.empty -let from_graph = ref Indmap.empty +let from_function = Summary.ref Cmap_env.empty ~name:"functions_db_fn" +let from_graph = Summary.ref Indmap.empty ~name:"functions_db_gr" + (* let rec do_cache_info finfo = function | [] -> raise Not_found @@ -272,15 +255,14 @@ let cache_Function (_,(finfos)) = *) let cache_Function (_,finfos) = - from_function := Cmap.add finfos.function_constant finfos !from_function; + from_function := Cmap_env.add finfos.function_constant finfos !from_function; from_graph := Indmap.add finfos.graph_ind finfos !from_graph let load_Function _ = cache_Function -let open_Function _ = cache_Function let subst_Function (subst,finfos) = - let do_subst_con c = fst (Mod_subst.subst_con subst c) - and do_subst_ind (kn,i) = (Mod_subst.subst_ind subst kn,i) + let do_subst_con c = Mod_subst.subst_constant subst c + and do_subst_ind i = Mod_subst.subst_ind subst i in let function_constant' = do_subst_con finfos.function_constant in let graph_ind' = do_subst_ind finfos.graph_ind in @@ -346,22 +328,29 @@ let discharge_Function (_,finfos) = } open Term + +let pr_ocst c = + Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) c (mt ()) + let pr_info f_info = - str "function_constant := " ++ Printer.pr_lconstr (mkConst f_info.function_constant)++ fnl () ++ - str "function_constant_type := " ++ - (try Printer.pr_lconstr (Global.type_of_global (ConstRef f_info.function_constant)) - with e when Errors.noncritical e -> mt ()) ++ fnl () ++ - str "equation_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.equation_lemma (mt ()) ) ++ fnl () ++ - str "completeness_lemma :=" ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.completeness_lemma (mt ()) ) ++ fnl () ++ - str "correctness_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.correctness_lemma (mt ()) ) ++ fnl () ++ - str "rect_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.rect_lemma (mt ()) ) ++ fnl () ++ - str "rec_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.rec_lemma (mt ()) ) ++ fnl () ++ - str "prop_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.prop_lemma (mt ()) ) ++ fnl () ++ - str "graph_ind := " ++ Printer.pr_lconstr (mkInd f_info.graph_ind) ++ fnl () + str "function_constant := " ++ + Printer.pr_lconstr (mkConst f_info.function_constant)++ fnl () ++ + str "function_constant_type := " ++ + (try + Printer.pr_lconstr + (Global.type_of_global_unsafe (ConstRef f_info.function_constant)) + with e when Errors.noncritical e -> mt ()) ++ fnl () ++ + str "equation_lemma := " ++ pr_ocst f_info.equation_lemma ++ fnl () ++ + str "completeness_lemma :=" ++ pr_ocst f_info.completeness_lemma ++ fnl () ++ + str "correctness_lemma := " ++ pr_ocst f_info.correctness_lemma ++ fnl () ++ + 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 () let pr_table tb = - let l = Cmap.fold (fun k v acc -> v::acc) tb [] in - Util.prlist_with_sep fnl pr_info l + let l = Cmap_env.fold (fun k v acc -> v::acc) tb [] in + Pp.prlist_with_sep fnl pr_info l let in_Function : function_info -> Libobject.obj = Libobject.declare_object @@ -375,36 +364,16 @@ let in_Function : function_info -> Libobject.obj = } - -(* Synchronisation with reset *) -let freeze () = - !from_function,!from_graph -let unfreeze (functions,graphs) = -(* Pp.msgnl (str "unfreezing function_table : " ++ pr_table l); *) - from_function := functions; - from_graph := graphs - -let init () = -(* Pp.msgnl (str "reseting function_table"); *) - from_function := Cmap.empty; - from_graph := Indmap.empty - -let _ = - Summary.declare_summary "functions_db_sum" - { Summary.freeze_function = freeze; - Summary.unfreeze_function = unfreeze; - Summary.init_function = init } - let find_or_none id = try Some - (match Nametab.locate (qualid_of_ident id) with ConstRef c -> c | _ -> Util.anomaly "Not a constant" + (match Nametab.locate (qualid_of_ident id) with ConstRef c -> c | _ -> Errors.anomaly (Pp.str "Not a constant") ) with Not_found -> None let find_Function_infos f = - Cmap.find f !from_function + Cmap_env.find f !from_function let find_Function_of_graph ind = @@ -416,7 +385,7 @@ let update_Function finfo = let add_Function is_general f = - let f_id = id_of_label (con_label f) in + let f_id = Label.to_id (con_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) @@ -425,7 +394,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 | _ -> Util.anomaly "Not an inductive" + with | IndRef ind -> ind | _ -> Errors.anomaly (Pp.str "Not an inductive") in let finfos = { function_constant = f; @@ -475,8 +444,7 @@ let function_debug_sig = let _ = declare_bool_option function_debug_sig -let do_observe () = - !function_debug = true +let do_observe () = !function_debug @@ -499,25 +467,37 @@ exception Building_graph of exn exception Defining_principle of exn exception ToShow of exn -let init_constant dir s = - try - Coqlib.gen_constant "Function" dir s - with e when Errors.noncritical e -> raise (ToShow e) - let jmeq () = try - (Coqlib.check_required_library ["Coq";"Logic";"JMeq"]; - init_constant ["Logic";"JMeq"] "JMeq") - with e when Errors.noncritical e -> raise (ToShow e) - -let jmeq_rec () = - try - Coqlib.check_required_library ["Coq";"Logic";"JMeq"]; - init_constant ["Logic";"JMeq"] "JMeq_rec" + Coqlib.check_required_library Coqlib.jmeq_module_name; + Coqlib.gen_constant "Function" ["Logic";"JMeq"] "JMeq" with e when Errors.noncritical e -> raise (ToShow e) let jmeq_refl () = try - Coqlib.check_required_library ["Coq";"Logic";"JMeq"]; - init_constant ["Logic";"JMeq"] "JMeq_refl" + Coqlib.check_required_library Coqlib.jmeq_module_name; + Coqlib.gen_constant "Function" ["Logic";"JMeq"] "JMeq_refl" with e when Errors.noncritical e -> raise (ToShow e) + +let h_intros l = + tclMAP (fun x -> Proofview.V82.of_tactic (Tactics.Simple.intro x)) 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 ltof_ref = function () -> (find_reference ["Coq";"Arith";"Wf_nat"] "ltof") + +let evaluable_of_global_reference r = (* Tacred.evaluable_of_global_reference (Global.env ()) *) + match r with + ConstRef sp -> EvalConstRef sp + | VarRef id -> EvalVarRef id + | _ -> assert false;; + +let list_rewrite (rev:bool) (eqs: (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())));; diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli index e0076735..67ddf374 100644 --- a/plugins/funind/indfun_common.mli +++ b/plugins/funind/indfun_common.mli @@ -5,23 +5,21 @@ open Pp The mk_?_id function build different name w.r.t. a function Each of their use is justified in the code *) -val mk_rel_id : identifier -> identifier -val mk_correct_id : identifier -> identifier -val mk_complete_id : identifier -> identifier -val mk_equation_id : identifier -> identifier +val mk_rel_id : Id.t -> Id.t +val mk_correct_id : Id.t -> Id.t +val mk_complete_id : Id.t -> Id.t +val mk_equation_id : Id.t -> Id.t val msgnl : std_ppcmds -> unit -val invalid_argument : string -> 'a - -val fresh_id : identifier list -> string -> identifier -val fresh_name : identifier list -> string -> name -val get_name : identifier list -> ?default:string -> name -> name +val fresh_id : Id.t list -> string -> Id.t +val fresh_name : Id.t list -> string -> Name.t +val get_name : Id.t list -> ?default:string -> Name.t -> Name.t val array_get_start : 'a array -> 'a array -val id_of_name : name -> identifier +val id_of_name : Name.t -> Id.t val locate_ind : Libnames.reference -> inductive val locate_constant : Libnames.reference -> constant @@ -36,38 +34,31 @@ val list_add_set_eq : ('a -> 'a -> bool) -> 'a -> 'a list -> 'a list val chop_rlambda_n : int -> Glob_term.glob_constr -> - (name*Glob_term.glob_constr*bool) list * Glob_term.glob_constr + (Name.t*Glob_term.glob_constr*bool) list * Glob_term.glob_constr val chop_rprod_n : int -> Glob_term.glob_constr -> - (name*Glob_term.glob_constr) list * 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 const_of_id: identifier -> constant +val const_of_id: Id.t -> constant val jmeq : unit -> Term.constr val jmeq_refl : unit -> Term.constr -(* [save_named] is a copy of [Command.save_named] but uses - [nf_betaiotazeta] instead of [nf_betaiotaevar_preserving_vm_cast] -*) - -val new_save_named : bool -> unit - -val save : bool -> identifier -> Entries.definition_entry -> Decl_kinds.goal_kind -> - Tacexpr.declaration_hook -> unit +val save : bool -> Id.t -> Entries.definition_entry -> Decl_kinds.goal_kind -> + unit Lemmas.declaration_hook Ephemeron.key -> unit (* [get_proof_clean do_reduce] : returns the proof name, definition, kind and hook and abort the proof *) val get_proof_clean : bool -> - Names.identifier * - (Entries.definition_entry * Decl_kinds.goal_kind * - Tacexpr.declaration_hook) + Names.Id.t * + (Entries.definition_entry * Decl_kinds.goal_kind) -(* [with_full_print f a] applies [f] to [a] in full printing environment +(* [with_full_print f a] applies [f] to [a] in full printing environment. This function preserves the print settings *) @@ -112,3 +103,14 @@ exception Defining_principle of exn exception ToShow of exn val is_strict_tcc : unit -> bool + +val h_intros: Names.Id.t list -> Proof_type.tactic +val h_id : Names.Id.t +val hrec_id : Names.Id.t +val acc_inv_id : Term.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 evaluable_of_global_reference : Globnames.global_reference -> Names.evaluable_global_reference +val list_rewrite : bool -> (Term.constr*bool) list -> Proof_type.tactic diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index c770c7ce..0c7b0a0b 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -1,39 +1,40 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* hov 1 (Ppconstr.pr_id id ++ str " := " ++ Pp.cut () ++ prc c) - | loc, Glob_term.AnonHyp n, c -> hov 1 (int n ++ str " := " ++ Pp.cut () ++ prc c) + | 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 - | Glob_term.ImplicitBindings l -> + | ImplicitBindings l -> brk (1,1) ++ str "with" ++ brk (1,1) ++ - Util.prlist_with_sep spc prc l - | Glob_term.ExplicitBindings l -> + pr_sequence prc l + | ExplicitBindings l -> brk (1,1) ++ str "with" ++ brk (1,1) ++ - Util.prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l - | Glob_term.NoBindings -> mt () + pr_sequence (fun b -> str"(" ++ pr_binding prlc b ++ str")") l + | NoBindings -> mt () let pr_with_bindings prc prlc (c,bl) = @@ -45,17 +46,17 @@ let pr_constr_with_binding prc (c,bl) : Pp.std_ppcmds = pr_with_bindings prc prc (c,bl) (* The local debuging mechanism *) -let msgnl = Pp.msgnl +(* let msgnl = Pp.msgnl *) let observe strm = if do_observe () - then Pp.msgnl strm + then Pp.msg_debug strm else () -let observennl strm = +(*let observennl strm = if do_observe () then begin Pp.msg strm;Pp.pp_flush () end - else () + else ()*) let do_observe_tac s tac g = @@ -64,22 +65,25 @@ let do_observe_tac s tac g = with e when Errors.noncritical e -> assert false in try - let v = tac g in msgnl (goal ++ fnl () ++ s ++(str " ")++(str "finished")); v + let v = tac g in + msgnl (goal ++ fnl () ++ s ++(str " ")++(str "finished")); v with reraise -> - let e' = Cerrors.process_vernac_interp_error reraise in + let reraise = Errors.push reraise in + let e = Cerrors.process_vernac_interp_error reraise in msgnl (str "observation "++ s++str " raised exception " ++ - Errors.print e' ++ str " on goal " ++ goal ); - raise reraise;; - + Errors.iprint e ++ str " on goal " ++ goal ); + iraise reraise;; -let observe_tac_msg s tac g = - if do_observe () +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 = - observe_tac_msg (str s) tac g + +let observe_tac s tac g = + if do_observe () + then do_observe_tac (str s) tac g + else tac g (* [nf_zeta] $\zeta$-normalization of a term *) let nf_zeta = @@ -109,57 +113,47 @@ let id_to_constr id = let generate_type g_to_f f graph i = (*i we deduce the number of arguments of the function and its returned type from the graph i*) - let graph_arity = Inductive.type_of_inductive (Global.env()) (Global.lookup_inductive (destInd graph)) in + let gr,u = destInd graph in + let graph_arity = Inductive.type_of_inductive (Global.env()) + (Global.lookup_inductive gr, u) in let ctxt,_ = decompose_prod_assum graph_arity in let fun_ctxt,res_type = match ctxt with - | [] | [_] -> anomaly "Not a valid context" + | [] | [_] -> anomaly (Pp.str "Not a valid context") | (_,_,res_type)::fun_ctxt -> fun_ctxt,res_type in - let nb_args = List.length fun_ctxt in - let args_from_decl i decl = - match decl with - | (_,Some _,_) -> incr i; failwith "args_from_decl" - | _ -> let j = !i in incr i;mkRel (nb_args - j + 1) + let rec args_from_decl i accu = function + | [] -> accu + | (_, Some _, _) :: l -> + args_from_decl (succ i) accu l + | _ :: l -> + let t = mkRel i in + args_from_decl (succ i) (t :: accu) l in (*i We need to name the vars [res] and [fv] i*) - let res_id = - Namegen.next_ident_away_in_goal - (id_of_string "res") - (map_succeed (function (Name id,_,_) -> id | (Anonymous,_,_) -> failwith "") fun_ctxt) - in - let fv_id = - Namegen.next_ident_away_in_goal - (id_of_string "fv") - (res_id::(map_succeed (function (Name id,_,_) -> id | (Anonymous,_,_) -> failwith "Anonymous!") fun_ctxt)) - in + let filter = function (Name id,_,_) -> Some id | (Anonymous,_,_) -> None in + let named_ctxt = 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 (*i we can then type the argument to be applied to the function [f] i*) - let args_as_rels = - let i = ref 0 in - Array.of_list ((map_succeed (args_from_decl i) (List.rev fun_ctxt))) - in - let args_as_rels = Array.map Termops.pop args_as_rels in + let args_as_rels = Array.of_list (args_from_decl 1 [] fun_ctxt) in (*i the hypothesis [res = fv] can then be computed We will need to lift it by one in order to use it as a conclusion i*) + let make_eq () = +(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq ()) + in let res_eq_f_of_args = - mkApp(Coqlib.build_coq_eq (),[|lift 2 res_type;mkRel 1;mkRel 2|]) + mkApp(make_eq (),[|lift 2 res_type;mkRel 1;mkRel 2|]) in (*i The hypothesis [graph\ x_1\ldots x_n\ res] can then be computed We will need to lift it by one in order to use it as a conclusion i*) - let graph_applied = - let args_and_res_as_rels = - let i = ref 0 in - Array.of_list ((map_succeed (args_from_decl i) (List.rev ((Name res_id,None,res_type)::fun_ctxt))) ) - in - let args_and_res_as_rels = - Array.mapi (fun i c -> if i <> Array.length args_and_res_as_rels - 1 then lift 1 c else c) args_and_res_as_rels - in - mkApp(graph,args_and_res_as_rels) - in + let args_and_res_as_rels = Array.of_list (args_from_decl 3 [] fun_ctxt) in + let args_and_res_as_rels = Array.append args_and_res_as_rels [|mkRel 1|] in + let graph_applied = mkApp(graph, args_and_res_as_rels) in (*i The [pre_context] is the defined to be the context corresponding to \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res, \] i*) @@ -178,7 +172,7 @@ let generate_type g_to_f f graph i = WARNING: while convertible, [type_of body] and [type] can be non equal *) let find_induction_principle f = - let f_as_constant = match kind_of_term f with + let f_as_constant,u = match kind_of_term f with | Const c' -> c' | _ -> error "Must be used with a function" in @@ -195,7 +189,7 @@ let find_induction_principle f = (* let fname = *) (* match kind_of_term f with *) (* | Const c' -> *) -(* id_of_label (con_label c') *) +(* Label.to_id (con_label c') *) (* | _ -> error "Must be used with a function" *) (* in *) @@ -217,6 +211,11 @@ let rec generate_fresh_id x avoid i = let id = Namegen.next_ident_away_in_goal x avoid in id::(generate_fresh_id x (id::avoid) (pred i)) +let make_eq () = +(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq ()) +let make_eq_refl () = +(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq_refl ()) + (* [prove_fun_correct functional_induction funs_constr graphs_constr schemes lemmas_types_infos i ] is the tactic used to prove correctness lemma. @@ -242,6 +241,261 @@ let rec generate_fresh_id x avoid i = \end{enumerate} *) +let prove_fun_correct functional_induction funs_constr graphs_constr schemes lemmas_types_infos i : 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 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 + (* The number of args of the function is then easilly computable *) + let nb_fun_args = nb_prod (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 funcitonnal principle is defined in the + environement 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 ids = principle_id :: ids in + (* We get the branches of the principle *) + let branches = List.rev princ_infos.branches in + (* and built the intro pattern for each of them *) + let intro_pats = + List.map + (fun (_,_,br_type) -> + List.map + (fun id -> Loc.ghost, IntroNaming (IntroIdentifier id)) + (generate_fresh_id (Id.of_string "y") ids (List.length (fst (decompose_prod_assum br_type)))) + ) + 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 + (* 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 + (* The tactic to prove the ith branch of the principle *) + let prove_branche i g = + (* We get the identifiers of this branch *) + (* + let this_branche_ids = + List.fold_right + (fun (_,pat) acc -> + match pat with + | Genarg.IntroIdentifier id -> Id.Set.add id acc + | _ -> anomaly (Pp.str "Not an identifier") + ) + (List.nth intro_pats (pred i)) + Id.Set.empty + in + let pre_args g = + List.fold_right + (fun (id,b,t) pre_args -> + if Id.Set.mem id this_branche_ids + then + match b with + | None -> id::pre_args + | Some b -> pre_args + else pre_args + ) + (pf_hyps g) + ([]) + in + let pre_args g = List.rev (pre_args g) in + let pre_tac g = + List.fold_right + (fun (id,b,t) pre_tac -> + if Id.Set.mem id this_branche_ids + then + match b with + | None -> pre_tac + | Some b -> + tclTHEN (h_reduce (Glob_term.Unfold([Glob_term.AllOccurrences,EvalVarRef id])) allHyps) pre_tac + else pre_tac + ) + (pf_hyps g) + tclIDTAC + in +*) + let pre_args = + List.fold_right + (fun (_,pat) acc -> + match pat with + | IntroNaming (IntroIdentifier id) -> id::acc + | _ -> anomaly (Pp.str "Not an identifier") + ) + (List.nth intro_pats (pred i)) + [] + in + (* and get the real args of the branch by unfolding the defined constant *) + (* + We can then recompute the arguments of the constructor. + For each [hid] introduced by this branch, if [hid] has type + $forall res, res=fv -> graph.(j)\ x_1\ x_n res$ the corresponding arguments of the constructor are + [ fv (hid fv (refl_equal fv)) ]. + If [hid] has another type the corresponding argument of the constructor is [hid] + *) + let constructor_args g = + List.fold_right + (fun hid acc -> + let type_of_hid = pf_type_of g (mkVar hid) in + match kind_of_term type_of_hid with + | Prod(_,_,t') -> + begin + match kind_of_term t' with + | Prod(_,t'',t''') -> + begin + match kind_of_term t'',kind_of_term t''' with + | App(eq,args), App(graph',_) + when + (eq_constr eq eq_ind) && + Array.exists (eq_constr graph') graphs_constr -> + (args.(2)::(mkApp(mkVar hid,[|args.(2);(mkApp(eq_construct,[|args.(0);args.(2)|]))|])) + ::acc) + | _ -> mkVar hid :: acc + end + | _ -> mkVar hid :: acc + end + | _ -> mkVar hid :: acc + ) pre_args [] + in + (* in fact we must also add the parameters to the constructor args *) + let constructor_args g = + let params_id = fst (List.chop princ_infos.nparams args_names) in + (List.map mkVar params_id)@((constructor_args g)) + in + (* We then get the constructor corresponding to this branch and + modifies the references has needed i.e. + if the constructor is the last one of the current inductive then + add one the number of the inductive to take and add the number of constructor of the previous + graph to the minimal constructor number + *) + let constructor = + let constructor_num = i - !min_constr_number in + let length = Array.length (mib.Declarations.mind_packets.(!ind_number).Declarations.mind_consnames) in + if constructor_num <= length + then + begin + (kn,!ind_number),constructor_num + end + else + begin + incr ind_number; + min_constr_number := !min_constr_number + length ; + (kn,!ind_number),1 + end + in + (* we can then build the final proof term *) + let app_constructor g = applist((mkConstruct(constructor)),constructor_args g) in + (* an apply the tactic *) + let res,hres = + match generate_fresh_id (Id.of_string "z") (ids(* @this_branche_ids *)) 2 with + | [res;hres] -> res,hres + | _ -> assert false + in + (* observe (str "constructor := " ++ Printer.pr_lconstr_env (pf_env g) app_constructor); *) + ( + tclTHENSEQ + [ + observe_tac("h_intro_patterns ") (let l = (List.nth intro_pats (pred i)) in + match l with + | [] -> tclIDTAC + | _ -> Proofview.V82.of_tactic (intro_patterns l)); + (* unfolding of all the defined variables introduced by this branch *) + (* observe_tac "unfolding" pre_tac; *) + (* $zeta$ normalizing of the conclusion *) + reduce + (Genredexpr.Cbv + { Redops.all_flags with + Genredexpr.rDelta = false ; + Genredexpr.rConst = [] + } + ) + Locusops.onConcl; + observe_tac ("toto ") tclIDTAC; + + (* introducing the 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))); + (* Conclusion *) + observe_tac "exact" (fun g -> Proofview.V82.of_tactic (exact_check (app_constructor g)) g) + ] + ) + g + in + (* end of branche proof *) + let lemmas = + Array.map + (fun (_,(ctxt,concl)) -> + match ctxt with + | [] | [_] | [_;_] -> anomaly (Pp.str "bad context") + | hres::res::(x,_,t)::ctxt -> + Termops.it_mkLambda_or_LetIn + (Termops.it_mkProd_or_LetIn concl [hres;res]) + ((x,None,t)::ctxt) + ) + lemmas_types_infos + in + let param_names = fst (List.chop princ_infos.nparams args_names) in + let params = List.map mkVar param_names in + let lemmas = Array.to_list (Array.map (fun c -> applist(c,params)) lemmas) in + (* The bindings of the principle + that is the params of the principle and the different lemma types + *) + let bindings = + let params_bindings,avoid = + List.fold_left2 + (fun (bindings,avoid) (x,_,_) p -> + let id = Namegen.next_ident_away (Nameops.out_name x) avoid in + (*(Loc.ghost,Glob_term.NamedHyp id,p)*)p::bindings,id::avoid + ) + ([],pf_ids_of_hyps g) + princ_infos.params + (List.rev params) + in + let lemmas_bindings = + List.rev (fst (List.fold_left2 + (fun (bindings,avoid) (x,_,_) p -> + let id = Namegen.next_ident_away (Nameops.out_name x) avoid in + (*(Loc.ghost,Glob_term.NamedHyp id,(nf_zeta p))*) (nf_zeta p)::bindings,id::avoid) + ([],avoid) + princ_infos.predicates + (lemmas))) + in + (* Glob_term.ExplicitBindings *) (params_bindings@lemmas_bindings) + in + tclTHENSEQ + [ + observe_tac "principle" (Proofview.V82.of_tactic (assert_by + (Name principle_id) + princ_type + (exact_check f_principle))); + observe_tac "intro args_names" (tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) args_names); + (* observe_tac "titi" (pose_proof (Name (Id.of_string "__")) (Reductionops.nf_beta Evd.empty ((mkApp (mkVar principle_id,Array.of_list bindings))))); *) + observe_tac "idtac" tclIDTAC; + tclTHEN_i + (observe_tac "functional_induction" ( + (fun gl -> + let term = mkApp (mkVar principle_id,Array.of_list bindings) in + let gl', _ty = pf_eapply Typing.e_type_of gl term in + Proofview.V82.of_tactic (apply term) gl') + )) + (fun i g -> observe_tac ("proving branche "^string_of_int i) (prove_branche i) g ) + ] + g + + +(* let prove_fun_correct functional_induction funs_constr graphs_constr schemes lemmas_types_infos i : tactic = fun g -> (* first of all we recreate the lemmas types to be used as predicates of the induction principle @@ -252,7 +506,7 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem Array.map (fun (_,(ctxt,concl)) -> match ctxt with - | [] | [_] | [_;_] -> anomaly "bad context" + | [] | [_] | [_;_] -> anomaly (Pp.str "bad context") | hres::res::(x,_,t)::ctxt -> Termops.it_mkLambda_or_LetIn (Termops.it_mkProd_or_LetIn concl [hres;res]) @@ -270,13 +524,13 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem let princ_infos = Tactics.compute_elim_sig princ_type in (* The number of args of the function is then easilly computable *) let nb_fun_args = nb_prod (pf_concl g) - 2 in - let args_names = generate_fresh_id (id_of_string "x") [] nb_fun_args 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 funcitonnal principle is defined in the environement 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") ids in let ids = principle_id :: ids in (* We get the branches of the principle *) let branches = List.rev princ_infos.branches in @@ -285,44 +539,43 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem List.map (fun (_,_,br_type) -> List.map - (fun id -> dummy_loc, Genarg.IntroIdentifier id) - (generate_fresh_id (id_of_string "y") ids (List.length (fst (decompose_prod_assum br_type)))) + (fun id -> Loc.ghost, Genarg.IntroIdentifier id) + (generate_fresh_id (Id.of_string "y") ids (List.length (fst (decompose_prod_assum br_type)))) ) branches in (* before building the full intro pattern for the principle *) + let pat = Some (Loc.ghost,Genarg.IntroOrAndPattern intro_pats) in let eq_ind = Coqlib.build_coq_eq () in let eq_construct = mkConstruct((destInd eq_ind),1) in (* The next to referencies will be used to find out which constructor to apply in each branch *) let ind_number = ref 0 and min_constr_number = ref 0 in (* The tactic to prove the ith branch of the principle *) - let this_branche_ids empty add i = - List.fold_right - (fun (_,pat) acc -> - match pat with - | Genarg.IntroIdentifier id -> add id acc - | _ -> anomaly "Not an identifier" - ) - (List.nth intro_pats (pred i)) - empty - in let prove_branche i g = (* We get the identifiers of this branch *) + let this_branche_ids = + List.fold_right + (fun (_,pat) acc -> + match pat with + | Genarg.IntroIdentifier id -> Id.Set.add id acc + | _ -> anomaly (Pp.str "Not an identifier") + ) + (List.nth intro_pats (pred i)) + Id.Set.empty + in (* and get the real args of the branch by unfolding the defined constant *) let pre_args,pre_tac = List.fold_right (fun (id,b,t) (pre_args,pre_tac) -> - if Idset.mem id (this_branche_ids Idset.empty Idset.add i) + if Id.Set.mem id this_branche_ids then match b with - | None -> - (id::pre_args,pre_tac) + | None -> (id::pre_args,pre_tac) | Some b -> (pre_args, - tclTHEN (h_reduce (Glob_term.Unfold([Glob_term.all_occurrences_expr,EvalVarRef id])) allHyps) pre_tac + tclTHEN (h_reduce (Glob_term.Unfold([Glob_term.AllOccurrences,EvalVarRef id])) allHyps) pre_tac ) - else (pre_args,pre_tac) ) (pf_hyps g) @@ -333,7 +586,6 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem For each [hid] introduced by this branch, if [hid] has type $forall res, res=fv -> graph.(j)\ x_1\ x_n res$ the corresponding arguments of the constructor are [ fv (hid fv (refl_equal fv)) ]. - If [hid] has another type the corresponding argument of the constructor is [hid] *) let constructor_args = @@ -350,9 +602,9 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem | App(eq,args), App(graph',_) when (eq_constr eq eq_ind) && - array_exists (eq_constr graph') graphs_constr -> - ((mkApp(mkVar hid,[|args.(2);(mkApp(eq_construct,[|args.(0);args.(2)|]))|])) - ::args.(2)::acc) + Array.exists (eq_constr graph') graphs_constr -> + ((mkApp(mkVar hid,[|args.(2);(mkApp(eq_construct,[|args.(0);args.(2)|]))|])) + ::args.(2)::acc) | _ -> mkVar hid :: acc end | _ -> mkVar hid :: acc @@ -362,7 +614,7 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem in (* in fact we must also add the parameters to the constructor args *) let constructor_args = - let params_id = fst (list_chop princ_infos.nparams args_names) in + let params_id = fst (List.chop princ_infos.nparams args_names) in (List.map mkVar params_id)@(List.rev constructor_args) in (* We then get the constructor corresponding to this branch and @@ -390,11 +642,11 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem let app_constructor = applist((mkConstruct(constructor)),constructor_args) in (* an apply the tactic *) let res,hres = - match generate_fresh_id (id_of_string "z") (ids(* @this_branche_ids *)) 2 with + match generate_fresh_id (Id.of_string "z") (ids(* @this_branche_ids *)) 2 with | [res;hres] -> res,hres | _ -> assert false in - observe_tac_msg (str "constructor := " ++ Printer.pr_lconstr_env (pf_env g) app_constructor) + observe (str "constructor := " ++ Printer.pr_lconstr_env (pf_env g) app_constructor); ( tclTHENSEQ [ @@ -414,13 +666,13 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem (* replacing [res] with its value *) observe_tac "rewriting res value" (Equality.rewriteLR (mkVar hres)); (* Conclusion *) - observe_tac "exact" (h_exact app_constructor) + observe_tac "exact" (exact_check app_constructor) ] ) g in (* end of branche proof *) - let param_names = fst (list_chop princ_infos.nparams args_names) in + let param_names = fst (List.chop princ_infos.nparams args_names) in let params = List.map mkVar param_names in let lemmas = Array.to_list (Array.map (fun c -> applist(c,params)) lemmas) in (* The bindings of the principle @@ -431,7 +683,7 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem List.fold_left2 (fun (bindings,avoid) (x,_,_) p -> let id = Namegen.next_ident_away (Nameops.out_name x) avoid in - (dummy_loc,Glob_term.NamedHyp id,p)::bindings,id::avoid + (Loc.ghost,Glob_term.NamedHyp id,p)::bindings,id::avoid ) ([],pf_ids_of_hyps g) princ_infos.params @@ -441,7 +693,7 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem List.rev (fst (List.fold_left2 (fun (bindings,avoid) (x,_,_) p -> let id = Namegen.next_ident_away (Nameops.out_name x) avoid in - (dummy_loc,Glob_term.NamedHyp id,(nf_zeta p))::bindings,id::avoid) + (Loc.ghost,Glob_term.NamedHyp id,(nf_zeta p))::bindings,id::avoid) ([],avoid) princ_infos.predicates (lemmas))) @@ -453,18 +705,21 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem observe_tac "principle" (assert_by (Name principle_id) princ_type - (h_exact f_principle)); + (exact_check f_principle)); tclTHEN_i (observe_tac "functional_induction" ( fun g -> observe (pr_constr_with_binding (Printer.pr_lconstr_env (pf_env g)) (mkVar principle_id,bindings)); - h_apply false false [dummy_loc,(mkVar principle_id,bindings)] g + functional_induction false (applist(funs_constr.(i),List.map mkVar args_names)) + (Some (mkVar principle_id,bindings)) + pat g )) - (fun i g -> observe_tac ("proving branche "^string_of_int i) - (tclTHEN (tclMAP h_intro (this_branche_ids [] (fun a b -> a::b) i)) (prove_branche i)) g ) + (fun i g -> observe_tac ("proving branche "^string_of_int i) (prove_branche i) g ) ] g +*) + (* [generalize_dependent_of x hyp g] generalize every hypothesis which depends of [x] but [hyp] @@ -472,8 +727,8 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem let generalize_dependent_of x hyp g = tclMAP (function - | (id,None,t) when not (id = hyp) && - (Termops.occur_var (pf_env g) x t) -> tclTHEN (h_generalize [mkVar id]) (thin [id]) + | (id,None,t) when not (Id.equal id hyp) && + (Termops.occur_var (pf_env g) x t) -> tclTHEN (Tactics.Simple.generalize [mkVar id]) (thin [id]) | _ -> tclIDTAC ) (pf_hyps g) @@ -490,7 +745,7 @@ let rec intros_with_rewrite g = observe_tac "intros_with_rewrite" intros_with_rewrite_aux g and intros_with_rewrite_aux : tactic = fun g -> - let eq_ind = Coqlib.build_coq_eq () in + let eq_ind = make_eq () in match kind_of_term (pf_concl g) with | Prod(_,t,t') -> begin @@ -498,66 +753,79 @@ and intros_with_rewrite_aux : tactic = | App(eq,args) when (eq_constr 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 [ h_intro id; thin [id]; intros_with_rewrite ] g - + 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[ + unfold_in_concl [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(1)))]; + tclMAP (fun id -> tclTRY(unfold_in_hyp [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(1)))] ((destVar 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[ + unfold_in_concl [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(2)))]; + tclMAP (fun id -> tclTRY(unfold_in_hyp [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(2)))] ((destVar args.(2)),Locus.InHyp) )) + (pf_ids_of_hyps g); + intros_with_rewrite + ] g else if isVar args.(1) then - let id = pf_get_new_id (id_of_string "y") g in - tclTHENSEQ [ h_intro id; + 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; - tclTRY (Equality.rewriteLR (mkVar id)); + tclTRY (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar id))); intros_with_rewrite ] g else if isVar args.(2) then - let id = pf_get_new_id (id_of_string "y") g in - tclTHENSEQ [ h_intro id; + 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; - tclTRY (Equality.rewriteRL (mkVar id)); + tclTRY (Proofview.V82.of_tactic (Equality.rewriteRL (mkVar id))); intros_with_rewrite ] g else begin - let id = pf_get_new_id (id_of_string "y") g in + let id = pf_get_new_id (Id.of_string "y") g in tclTHENSEQ[ - h_intro id; - tclTRY (Equality.rewriteLR (mkVar id)); + 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 ()) -> - Tauto.tauto g + Proofview.V82.of_tactic Tauto.tauto g | Case(_,_,v,_) -> tclTHENSEQ[ - h_case false (v,Glob_term.NoBindings); + Proofview.V82.of_tactic (simplest_case v); intros_with_rewrite ] g | LetIn _ -> tclTHENSEQ[ - h_reduce - (Glob_term.Cbv - {Glob_term.all_flags - with Glob_term.rDelta = false; + reduce + (Genredexpr.Cbv + {Redops.all_flags + with Genredexpr.rDelta = false; }) - onConcl + Locusops.onConcl ; intros_with_rewrite ] g | _ -> - let id = pf_get_new_id (id_of_string "y") g in - tclTHENSEQ [ h_intro id;intros_with_rewrite] 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 end | LetIn _ -> tclTHENSEQ[ - h_reduce - (Glob_term.Cbv - {Glob_term.all_flags - with Glob_term.rDelta = false; + reduce + (Genredexpr.Cbv + {Redops.all_flags + with Genredexpr.rDelta = false; }) - onConcl + Locusops.onConcl ; intros_with_rewrite ] g @@ -569,14 +837,14 @@ let rec reflexivity_with_destruct_cases g = match kind_of_term (snd (destApp (pf_concl g))).(2) with | Case(_,_,v,_) -> tclTHENSEQ[ - h_case false (v,Glob_term.NoBindings); - intros; + Proofview.V82.of_tactic (simplest_case v); + Proofview.V82.of_tactic intros; observe_tac "reflexivity_with_destruct_cases" reflexivity_with_destruct_cases ] - | _ -> reflexivity - with e when Errors.noncritical e -> reflexivity + | _ -> Proofview.V82.of_tactic reflexivity + with e when Errors.noncritical e -> Proofview.V82.of_tactic reflexivity in - let eq_ind = Coqlib.build_coq_eq () in + let eq_ind = make_eq () in let discr_inject = Tacticals.onAllHypsAndConcl ( fun sc g -> @@ -586,15 +854,15 @@ let rec reflexivity_with_destruct_cases g = match kind_of_term (pf_type_of g (mkVar id)) with | App(eq,[|_;t1;t2|]) when eq_constr eq eq_ind -> if Equality.discriminable (pf_env g) (project g) t1 t2 - then Equality.discrHyp id g + then Proofview.V82.of_tactic (Equality.discrHyp id) g else if Equality.injectable (pf_env g) (project g) t1 t2 - then tclTHENSEQ [Equality.injHyp id;thin [id];intros_with_rewrite] g + then tclTHENSEQ [Proofview.V82.of_tactic (Equality.injHyp None id);thin [id];intros_with_rewrite] g else tclIDTAC g | _ -> tclIDTAC g ) in (tclFIRST - [ observe_tac "reflexivity_with_destruct_cases : reflexivity" reflexivity; + [ observe_tac "reflexivity_with_destruct_cases : reflexivity" (Proofview.V82.of_tactic reflexivity); observe_tac "reflexivity_with_destruct_cases : destruct_case" ((destruct_case ())); (* We reach this point ONLY if the same value is matched (at least) two times @@ -654,23 +922,24 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = and compute a fresh name for each of them *) let nb_fun_args = nb_prod (pf_concl g) - 2 in - let args_names = generate_fresh_id (id_of_string "x") [] nb_fun_args 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) *) let res,hres,graph_principle_id = - match generate_fresh_id (id_of_string "z") ids 3 with + match generate_fresh_id (Id.of_string "z") ids 3 with | [res;hres;graph_principle_id] -> res,hres,graph_principle_id | _ -> assert false in let ids = res::hres::graph_principle_id::ids in - (* we also compute fresh names for each hyptohesis of each branche of the principle *) + (* we also compute fresh names for each hyptohesis of each branch + of the principle *) let branches = List.rev princ_infos.branches in let intro_pats = List.map (fun (_,_,br_type) -> List.map (fun id -> id) - (generate_fresh_id (id_of_string "y") ids (nb_prod br_type)) + (generate_fresh_id (Id.of_string "y") ids (nb_prod br_type)) ) branches in @@ -680,28 +949,34 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = *) let rewrite_tac j ids : tactic = let graph_def = graphs.(j) in - let infos = try find_Function_infos (destConst funcs.(j)) with Not_found -> error "No graph found" in - if infos.is_general || Rtree.is_infinite graph_def.mind_recargs + let infos = + try find_Function_infos (fst (destConst funcs.(j))) + with Not_found -> error "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 "Cannot find equation lemma" + with Option.IsNone -> anomaly (Pp.str "Cannot find equation lemma") in tclTHENSEQ[ - tclMAP h_intro ids; - Equality.rewriteLR (mkConst eq_lemma); - (* Don't forget to $\zeta$ normlize the term since the principles have been $\zeta$-normalized *) - h_reduce - (Glob_term.Cbv - {Glob_term.all_flags - with Glob_term.rDelta = false; + 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 + have been $\zeta$-normalized *) + reduce + (Genredexpr.Cbv + {Redops.all_flags + with Genredexpr.rDelta = false; }) - onConcl + Locusops.onConcl ; - h_generalize (List.map mkVar ids); + Simple.generalize (List.map mkVar ids); thin ids ] - else unfold_in_concl [(Termops.all_occurrences, Names.EvalConstRef (destConst f))] + else + unfold_in_concl [(Locus.AllOccurrences, Names.EvalConstRef (fst (destConst f)))] in (* The proof of each branche itself *) let ind_number = ref 0 in @@ -725,21 +1000,21 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = (* we expand the definition of the function *) observe_tac "rewrite_tac" (rewrite_tac this_ind_number this_branche_ids); (* introduce hypothesis with some rewrite *) - observe_tac "intros_with_rewrite" intros_with_rewrite; + observe_tac "intros_with_rewrite (all)" intros_with_rewrite; (* The proof is (almost) complete *) observe_tac "reflexivity" (reflexivity_with_destruct_cases) ] g in - let params_names = fst (list_chop princ_infos.nparams args_names) in + let params_names = fst (List.chop princ_infos.nparams args_names) in let params = List.map mkVar params_names in tclTHENSEQ - [ tclMAP h_intro (args_names@[res;hres]); + [ tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) (args_names@[res;hres]); observe_tac "h_generalize" - (h_generalize [mkApp(applist(graph_principle,params),Array.map (fun c -> applist(c,params)) lemmas)]); - h_intro graph_principle_id; + (Simple.generalize [mkApp(applist(graph_principle,params),Array.map (fun c -> applist(c,params)) lemmas)]); + Proofview.V82.of_tactic (Simple.intro graph_principle_id); observe_tac "" (tclTHEN_i - (observe_tac "elim" ((elim false (mkVar hres,Glob_term.NoBindings) (Some (mkVar graph_principle_id,Glob_term.NoBindings))))) + (observe_tac "elim" (Proofview.V82.of_tactic (elim false None (mkVar hres,NoBindings) (Some (mkVar graph_principle_id,NoBindings))))) (fun i g -> observe_tac "prove_branche" (prove_branche i) g )) ] g @@ -747,7 +1022,7 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = -let do_save () = Lemmas.save_named false +let do_save () = Lemmas.save_proof (Vernacexpr.Proved(false,None)) (* [derive_correctness make_scheme functional_induction funs graphs] create correctness and completeness @@ -758,15 +1033,14 @@ let do_save () = Lemmas.save_named false *) let derive_correctness make_scheme functional_induction (funs: constant list) (graphs:inductive list) = - let previous_state = States.freeze () in let funs = Array.of_list funs and graphs = Array.of_list graphs in let funs_constr = Array.map mkConst funs in - try + States.with_state_protection_on_exception (fun () -> let graphs_constr = Array.map mkInd graphs in let lemmas_types_infos = - Util.array_map2_i + Util.Array.map2_i (fun i f_constr graph -> - let const_of_f = destConst f_constr in + let const_of_f,u = destConst f_constr in let (type_of_lemma_ctxt,type_of_lemma_concl) as type_info = generate_type false const_of_f graph i in @@ -783,15 +1057,15 @@ let derive_correctness make_scheme functional_induction (funs: constant list) (g if the block contains only one function we can safely reuse [f_rect] *) try - if Array.length funs_constr <> 1 then raise Not_found; + if not (Int.equal (Array.length funs_constr) 1) then raise Not_found; [| find_induction_principle funs_constr.(0) |] with Not_found -> Array.of_list (List.map (fun entry -> - (entry.Entries.const_entry_body, Option.get entry.Entries.const_entry_type ) + (fst (fst(Future.force entry.Entries.const_entry_body)), Option.get entry.Entries.const_entry_type ) ) - (make_scheme (array_map_to_list (fun const -> const,Glob_term.GType None) funs)) + (make_scheme (Array.map_to_list (fun const -> const,GType []) funs)) ) in let proving_tac = @@ -799,28 +1073,29 @@ let derive_correctness make_scheme functional_induction (funs: constant list) (g in Array.iteri (fun i f_as_constant -> - let f_id = id_of_label (con_label f_as_constant) in + let f_id = Label.to_id (con_label f_as_constant) in (*i The next call to mk_correct_id is valid since we are constructing the lemma Ensures by: obvious i*) let lem_id = mk_correct_id f_id in Lemmas.start_proof lem_id - (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem)) - (fst lemmas_types_infos.(i)) - (fun _ _ -> ()); - Pfedit.by - (observe_tac ("prove correctness ("^(string_of_id f_id)^")") - (proving_tac i)); + (Decl_kinds.Global,false(*FIXME*),(Decl_kinds.Proof Decl_kinds.Theorem)) + (*FIXME*) Evd.empty + (fst lemmas_types_infos.(i)) + (Lemmas.mk_hook (fun _ _ -> ())); + ignore (Pfedit.by + (Proofview.V82.tactic (observe_tac ("prove correctness ("^(Id.to_string f_id)^")") + (proving_tac i)))); do_save (); let finfo = find_Function_infos f_as_constant in - let lem_cst = destConst (Constrintern.global_reference lem_id) in + let lem_cst = fst (destConst (Constrintern.global_reference lem_id)) in update_Function {finfo with correctness_lemma = Some lem_cst} ) funs; let lemmas_types_infos = - Util.array_map2_i + Util.Array.map2_i (fun i f_constr graph -> - let const_of_f = destConst f_constr in + let const_of_f = fst (destConst f_constr) in let (type_of_lemma_ctxt,type_of_lemma_concl) as type_info = generate_type true const_of_f graph i in @@ -832,51 +1107,46 @@ let derive_correctness make_scheme functional_induction (funs: constant list) (g funs_constr graphs_constr in - let kn,_ as graph_ind = destInd graphs_constr.(0) in + let kn,_ as graph_ind = fst (destInd graphs_constr.(0)) in let mib,mip = Global.lookup_inductive graph_ind in - let schemes = - Array.of_list + let sigma, scheme = (Indrec.build_mutual_induction_scheme (Global.env ()) Evd.empty (Array.to_list (Array.mapi - (fun i _ -> (kn,i),true,InType) + (fun i _ -> ((kn,i),Univ.Instance.empty)(*FIXME*),true,InType) mib.Declarations.mind_packets ) ) ) in + let schemes = + Array.of_list scheme + in let proving_tac = prove_fun_complete funs_constr mib.Declarations.mind_packets schemes lemmas_types_infos in Array.iteri (fun i f_as_constant -> - let f_id = id_of_label (con_label f_as_constant) in + let f_id = Label.to_id (con_label f_as_constant) in (*i The next call to mk_complete_id is valid since we are constructing the lemma Ensures by: obvious i*) let lem_id = mk_complete_id f_id in Lemmas.start_proof lem_id - (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem)) - (fst lemmas_types_infos.(i)) - (fun _ _ -> ()); - Pfedit.by - (observe_tac ("prove completeness ("^(string_of_id f_id)^")") - (proving_tac i)); + (Decl_kinds.Global,false(*FIXME*),(Decl_kinds.Proof Decl_kinds.Theorem)) + (*FIXME*) Evd.empty + (fst lemmas_types_infos.(i)) + (Lemmas.mk_hook (fun _ _ -> ())); + ignore (Pfedit.by + (Proofview.V82.tactic (observe_tac ("prove completeness ("^(Id.to_string f_id)^")") + (proving_tac i)))); do_save (); let finfo = find_Function_infos f_as_constant in - let lem_cst = destConst (Constrintern.global_reference lem_id) in + let lem_cst,u = destConst (Constrintern.global_reference lem_id) in update_Function {finfo with completeness_lemma = Some lem_cst} ) - funs; - with reraise -> - (* In case of problem, we reset all the lemmas *) - Pfedit.delete_all_proofs (); - States.unfreeze previous_state; - raise reraise - - - - + funs) + () (***********************************************) @@ -890,13 +1160,13 @@ let revert_graph kn post_tac hid g = let typ = pf_type_of g (mkVar hid) in match kind_of_term typ with | App(i,args) when isInd i -> - let ((kn',num) as ind') = destInd i in - if kn = kn' + let ((kn',num) as ind'),u = destInd i in + if MutInd.equal kn kn' then (* We have generated a graph hypothesis so that we must change it if we can *) let info = try find_Function_of_graph ind' with Not_found -> (* The graphs are mutually recursive but we cannot find one of them !*) - anomaly "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 @@ -904,12 +1174,12 @@ let revert_graph kn post_tac hid g = match info.completeness_lemma with | None -> tclIDTAC g | Some f_complete -> - let f_args,res = array_chop (Array.length args - 1) args in + let f_args,res = Array.chop (Array.length args - 1) args in tclTHENSEQ [ - h_generalize [applist(mkConst f_complete,(Array.to_list f_args)@[res.(0);mkVar hid])]; + Simple.generalize [applist(mkConst f_complete,(Array.to_list f_args)@[res.(0);mkVar hid])]; thin [hid]; - h_intro hid; + Proofview.V82.of_tactic (Simple.intro hid); post_tac hid ] g @@ -937,26 +1207,26 @@ let revert_graph kn post_tac hid g = let functional_inversion kn hid fconst f_correct : tactic = fun g -> - let old_ids = List.fold_right Idset.add (pf_ids_of_hyps g) Idset.empty in + let old_ids = List.fold_right Id.Set.add (pf_ids_of_hyps g) Id.Set.empty in let type_of_h = pf_type_of g (mkVar hid) in match kind_of_term type_of_h with - | App(eq,args) when eq_constr eq (Coqlib.build_coq_eq ()) -> + | App(eq,args) when eq_constr eq (make_eq ()) -> let pre_tac,f_args,res = match kind_of_term args.(1),kind_of_term args.(2) with | App(f,f_args),_ when eq_constr f fconst -> - ((fun hid -> h_symmetry (onHyp hid)),f_args,args.(2)) + ((fun hid -> Proofview.V82.of_tactic (intros_symmetry (Locusops.onHyp hid))),f_args,args.(2)) |_,App(f,f_args) when eq_constr f fconst -> ((fun hid -> tclIDTAC),f_args,args.(1)) | _ -> (fun hid -> tclFAIL 1 (mt ())),[||],args.(2) in tclTHENSEQ[ pre_tac hid; - h_generalize [applist(f_correct,(Array.to_list f_args)@[res;mkVar hid])]; + Simple.generalize [applist(f_correct,(Array.to_list f_args)@[res;mkVar hid])]; thin [hid]; - h_intro hid; - Inv.inv FullInversion None (Glob_term.NamedHyp hid); + Proofview.V82.of_tactic (Simple.intro hid); + Proofview.V82.of_tactic (Inv.inv FullInversion None (NamedHyp hid)); (fun g -> - let new_ids = List.filter (fun id -> not (Idset.mem id old_ids)) (pf_ids_of_hyps g) in + let new_ids = List.filter (fun id -> not (Id.Set.mem id old_ids)) (pf_ids_of_hyps g) in tclMAP (revert_graph kn pre_tac) (hid::new_ids) g ); ] g @@ -968,14 +1238,16 @@ let invfun qhyp f = let f = match f with | ConstRef f -> f - | _ -> raise (Util.UserError("",str "Not a function")) + | _ -> raise (Errors.UserError("",str "Not a function")) in try let finfos = find_Function_infos f in let f_correct = mkConst(Option.get finfos.correctness_lemma) and kn = fst finfos.graph_ind in - Tactics.try_intros_until (fun hid -> functional_inversion kn hid (mkConst f) f_correct) qhyp + Proofview.V82.of_tactic ( + Tactics.try_intros_until (fun hid -> Proofview.V82.tactic (functional_inversion kn hid (mkConst f) f_correct)) qhyp + ) with | Not_found -> error "No graph found" | Option.IsNone -> error "Cannot use equivalence with graph!" @@ -985,16 +1257,17 @@ let invfun qhyp f g = match f with | Some f -> invfun qhyp f g | None -> + Proofview.V82.of_tactic begin Tactics.try_intros_until - (fun hid g -> + (fun hid -> Proofview.V82.tactic begin fun g -> let hyp_typ = pf_type_of g (mkVar hid) in match kind_of_term hyp_typ with - | App(eq,args) when eq_constr eq (Coqlib.build_coq_eq ()) -> + | App(eq,args) when eq_constr eq (make_eq ()) -> begin let f1,_ = decompose_app args.(1) in try if not (isConst f1) then failwith ""; - let finfos = find_Function_infos (destConst f1) in + let finfos = find_Function_infos (fst (destConst f1)) in let f_correct = mkConst(Option.get finfos.correctness_lemma) and kn = fst finfos.graph_ind in @@ -1003,14 +1276,14 @@ let invfun qhyp f g = try let f2,_ = decompose_app args.(2) in if not (isConst f2) then failwith ""; - let finfos = find_Function_infos (destConst f2) in + let finfos = find_Function_infos (fst (destConst f2)) in let f_correct = mkConst(Option.get finfos.correctness_lemma) and kn = fst finfos.graph_ind in functional_inversion kn hid f2 f_correct g with | Failure "" -> - errorlabstrm "" (str "Hypothesis" ++ Ppconstr.pr_id hid ++ str " must contain at leat one Function") + errorlabstrm "" (str "Hypothesis " ++ Ppconstr.pr_id hid ++ str " must contain at least one Function") | Option.IsNone -> if do_observe () then @@ -1023,6 +1296,7 @@ let invfun qhyp f g = else errorlabstrm "" (str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid) end | _ -> errorlabstrm "" (Ppconstr.pr_id hid ++ str " must be an equality ") - ) + end) qhyp + end g diff --git a/plugins/funind/merge.ml b/plugins/funind/merge.ml index e1f10be2..ea699580 100644 --- a/plugins/funind/merge.ml +++ b/plugins/funind/merge.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* x,lift n y) ldecl -let understand = Pretyping.Default.understand Evd.empty (Global.env()) +let understand = Pretyping.understand (Global.env()) Evd.empty (** Operations on names and identifiers *) let id_of_name = function - Anonymous -> id_of_string "H" + Anonymous -> Id.of_string "H" | Name id -> id;; -let name_of_string str = Name (id_of_string str) -let string_of_name nme = string_of_id (id_of_name nme) +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) -> Pervasives.compare x f = 0 + | 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 (dummy_loc,id)) in - let _ = ignore (Constrintern.intern_constr Evd.empty (Global.env()) ans) in + let ans = CRef (Libnames.Ident (Loc.ghost,id), None) in + let _ = ignore (Constrintern.intern_constr (Global.env()) ans) in true with e when Errors.noncritical e -> false (** [next_ident_fresh id] returns a fresh identifier (ie not linked in global env) with base [id]. *) -let next_ident_fresh (id:identifier) = +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 @@ -128,19 +131,15 @@ let prNamedRLDecl s lc = prstr "\n"; end -let showind (id:identifier) = +let showind (id:Id.t) = let cstrid = Constrintern.global_reference id in let ind1,cstrlist = Inductiveops.find_inductive (Global.env()) Evd.empty cstrid in - let mib1,ib1 = Inductive.lookup_mind_specif (Global.env()) ind1 in + let mib1,ib1 = Inductive.lookup_mind_specif (Global.env()) (fst ind1) in List.iter (fun (nm, optcstr, tp) -> print_string (string_of_name nm^":"); prconstr tp; print_string "\n") ib1.mind_arity_ctxt; - (match ib1.mind_arity with - | Monomorphic x -> - Printf.printf "arity :"; prconstr x.mind_user_arity - | Polymorphic x -> - Printf.printf "arity : universe?"); + Printf.printf "arity :"; prconstr (Inductiveops.type_of_inductive (Global.env ()) ind1); Array.iteri (fun i x -> Printf.printf"type constr %d :" i ; prconstr x) ib1.mind_user_lc @@ -152,23 +151,15 @@ exception Found of int (* Array scanning *) let array_prfx (arr: 'a array) (pred: int -> 'a -> bool): int = - try - for i=0 to Array.length arr - 1 do if pred i (arr.(i)) then raise (Found i) done; - Array.length arr (* all elt are positive *) - with Found i -> i - -let array_fold_lefti (f: int -> 'a -> 'b -> 'a) (acc:'a) (arr:'b array): 'a = - let i = ref 0 in - Array.fold_left - (fun acc x -> - let res = f !i acc x in i := !i + 1; res) - acc arr +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]. *) +(* 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 + 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 @@ -234,7 +225,7 @@ let linkmonad f lnkvar = let linklift lnkvar i = linkmonad (fun x -> x+i) lnkvar (* This map is used to deal with debruijn linked indices. *) -module Link = Map.Make (struct type t = int let compare = Pervasives.compare end) +module Link = Map.Make (Int) let pr_links l = Printf.printf "links:\n"; @@ -254,7 +245,7 @@ type 'a merged_arg = type merge_infos = { - ident:identifier; (** new inductive name *) + ident:Id.t; (** new inductive name *) mib1: mutual_inductive_body; oib1: one_inductive_body; mib2: mutual_inductive_body; @@ -357,17 +348,17 @@ let filter_shift_stable_right (lnk:int merged_arg array) (l:'a list): 'a list = (** {1 Utilities for merging} *) -let ind1name = id_of_string "__ind1" -let ind2name = id_of_string "__ind2" +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 not mib1.mind_finite then error "First argument is coinductive"; - if not mib2.mind_finite then error "Second argument is coinductive"; - if mib1.mind_ntypes <> 1 then error "First argument is mutual"; - if mib2.mind_ntypes <> 1 then error "Second argument is mutual"; + 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"; () (* @@ -381,11 +372,11 @@ let build_raw_params prms_decl avoid = 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 @ (Idset.elements (ids_of_glob_constr dummy_glob_constr))) + comblist, res , (avoid @ (Id.Set.elements (ids_of_glob_constr dummy_glob_constr))) *) let ids_of_rawlist avoid rawl = - List.fold_left Idset.union avoid (List.map ids_of_glob_constr rawl) + List.fold_left Id.Set.union avoid (List.map ids_of_glob_constr rawl) @@ -463,7 +454,7 @@ let shift_linked_params mib1 mib2 (lnk1:linked_var array) (lnk2:linked_var array ([],[],[],[]) arity_ctxt in (* let arity_ctxt2 = build_raw_params oib2.mind_arity_ctxt - (Idset.elements (ids_of_glob_constr oib1.mind_arity_ctxt)) in*) + (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 @@ -514,16 +505,16 @@ let rec merge_app c1 c2 id1 id2 shift filter_shift_stable = | GApp(_,f1, arr1), GApp(_,f2,arr2) when isVarf id1 f1 && isVarf id2 f2 -> let _ = prstr "\nICI1!\n";Pp.flush_all() in let args = filter_shift_stable lnk (arr1 @ arr2) in - GApp (dummy_loc,GVar (dummy_loc,shift.ident) , args) + 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";Pp.flush_all() in let newtrm = merge_app trm c2 id1 id2 shift filter_shift_stable in - GLetIn(dummy_loc,nme,bdy,newtrm) + GLetIn(Loc.ghost,nme,bdy,newtrm) | _, GLetIn(_,nme,bdy,trm) -> let _ = prstr "\nICI3!\n";Pp.flush_all() in let newtrm = merge_app c1 trm id1 id2 shift filter_shift_stable in - GLetIn(dummy_loc,nme,bdy,newtrm) + GLetIn(Loc.ghost,nme,bdy,newtrm) | _ -> let _ = prstr "\nICI4!\n";Pp.flush_all() in raise NoMerge @@ -532,16 +523,16 @@ let rec merge_app_unsafe c1 c2 shift filter_shift_stable = match c1 , c2 with | GApp(_,f1, arr1), GApp(_,f2,arr2) -> let args = filter_shift_stable lnk (arr1 @ arr2) in - GApp (dummy_loc,GVar(dummy_loc,shift.ident) , args) + 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";Pp.flush_all() in let newtrm = merge_app_unsafe trm c2 shift filter_shift_stable in - GLetIn(dummy_loc,nme,bdy,newtrm) + GLetIn(Loc.ghost,nme,bdy,newtrm) | _, GLetIn(_,nme,bdy,trm) -> let _ = prstr "\nICI3 '!\n";Pp.flush_all() in let newtrm = merge_app_unsafe c1 trm shift filter_shift_stable in - GLetIn(dummy_loc,nme,bdy,newtrm) + GLetIn(Loc.ghost,nme,bdy,newtrm) | _ -> let _ = prstr "\nICI4 '!\n";Pp.flush_all() in raise NoMerge @@ -550,8 +541,8 @@ let rec merge_app_unsafe c1 c2 shift filter_shift_stable = 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:(Names.name * glob_constr option * glob_constr option) list) - filter_shift_stable : (Names.name * glob_constr option * glob_constr option) list = + (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)) @@ -567,11 +558,11 @@ let rec merge_rec_hyps shift accrec | e::lt -> e :: merge_rec_hyps shift accrec lt filter_shift_stable -let rec build_suppl_reccall (accrec:(name * glob_constr) list) concl2 shift = +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:identifier) ltyp = +let find_app (nme:Id.t) ltyp = try ignore (List.map @@ -591,9 +582,9 @@ let prnt_prod_or_letin nm letbdy typ = let rec merge_types shift accrec1 - (ltyp1:(name * glob_constr option * glob_constr option) list) - (concl1:glob_constr) (ltyp2:(name * glob_constr option * glob_constr option) list) concl2 - : (name * glob_constr option * glob_constr option) list * glob_constr = + (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 @@ -603,7 +594,7 @@ let rec merge_types shift accrec1 let res = match ltyp1 with | [] -> - let isrec1 = (accrec1<>[]) in + let isrec1 = not (List.is_empty accrec1) in let isrec2 = find_app ind2name ltyp2 in let rechyps = if isrec1 && isrec2 @@ -657,22 +648,22 @@ let rec merge_types shift accrec1 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:identifier array) (allargs2:identifier array) +let build_link_map_aux (allargs1:Id.t array) (allargs2:Id.t array) (lnk:int merged_arg array) = - array_fold_lefti + Array.fold_left_i (fun i acc e -> - if i = Array.length lnk - 1 then acc (* functional arg, not in allargs *) + 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 -> Idmap.add allargs2.(i) allargs1.(j) acc + | Prm_linked j | Arg_linked j -> Id.Map.add allargs2.(i) allargs1.(j) acc | _ -> acc) - Idmap.empty lnk + Id.Map.empty lnk let build_link_map allargs1 allargs2 lnk = let allargs1 = - Array.of_list (List.rev (List.map (fun (x,_,_) -> id_of_name x) allargs1)) in + Array.of_list (List.rev_map (fun (x,_,_) -> id_of_name x) allargs1) in let allargs2 = - Array.of_list (List.rev (List.map (fun (x,_,_) -> id_of_name x) allargs2)) in + Array.of_list (List.rev_map (fun (x,_,_) -> id_of_name x) allargs2) in build_link_map_aux allargs1 allargs2 lnk @@ -749,18 +740,18 @@ let fresh_cstror_suffix , cstror_suffix_init = (** [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:identifier = - let id = string_of_id shift.ident ^ "_" ^ fresh_cstror_suffix () in - next_ident_fresh (id_of_string id) +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 rec merge_constructors (shift:merge_infos) (avoid:Idset.t) - (typcstr1:(identifier * glob_constr) list) - (typcstr2:(identifier * glob_constr) list) : (identifier * glob_constr) list = +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) -> @@ -776,20 +767,20 @@ let rec merge_constructors (shift:merge_infos) (avoid:Idset.t) (** [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 rec merge_inductive_body (shift:merge_infos) avoid (oib1:one_inductive_body) +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 (Idset.elements avoid) [] substindtyp 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 = Idset.union avoid (ids_of_rawlist avoid lcstr1) in + 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 = Idset.union avoid (ids_of_rawlist avoid lcstr2) 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)) @@ -810,14 +801,14 @@ let rec merge_inductive_body (shift:merge_infos) avoid (oib1:one_inductive_body) [lnk]. [shift] information on parameters of the new inductive. For the moment, inductives are supposed to be non mutual. *) -let rec merge_mutual_inductive_body +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 Idset.empty mib1.mind_packets.(0) mib2.mind_packets.(0) + 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 Idset.empty) x + 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 @@ -828,15 +819,15 @@ let merge_rec_params_and_arity prms1 prms2 shift (concl:constr) = let _ = prNamedRConstr (string_of_name nme) tp in let _ = prstr " ; " in let typ = glob_constr_to_constr_expr tp in - LocalRawAssum ([(dummy_loc,nme)], Topconstr.default_binder_kind, typ) :: acc) + LocalRawAssum ([(Loc.ghost,nme)], Constrexpr_ops.default_binder_kind, typ) :: acc) [] params in - let concl = Constrextern.extern_constr false (Global.env()) concl in + let concl = Constrextern.extern_constr false (Global.env()) Evd.empty concl in let arity,_ = List.fold_left (fun (acc,env) (nm,_,c) -> - let typ = Constrextern.extern_constr false env c in + let typ = Constrextern.extern_constr false env Evd.empty c in let newenv = Environ.push_rel (nm,None,c) env in - CProdN (dummy_loc, [[(dummy_loc,nm)],Topconstr.default_binder_kind,typ] , acc) , newenv) + 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 @@ -849,33 +840,22 @@ let merge_rec_params_and_arity prms1 prms2 shift (concl:constr) = [rawlist], named ident. FIXME: params et cstr_expr (arity) *) let glob_constr_list_to_inductive_expr prms1 prms2 mib1 mib2 shift - (rawlist:(identifier * glob_constr) list) = - let lident = dummy_loc, shift.ident in + (rawlist:(Id.t * glob_constr) list) = + let lident = Loc.ghost, shift.ident 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, ((dummy_loc,id),glob_constr_to_constr_expr 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:rel_declaration) (t2:glob_constr) = - match rdecl with - | (nme,None,t) -> - let traw = Detyping.detype false [] [] t in - GProd (dummy_loc,nme,Explicit,traw,t2) - | (_,Some _,_) -> assert false - - - - let mkProd_reldecl (rdecl:rel_declaration) (t2:glob_constr) = match rdecl with | (nme,None,t) -> - let traw = Detyping.detype false [] [] t in - GProd (dummy_loc,nme,Explicit,traw,t2) + let traw = Detyping.detype false [] (Global.env()) Evd.empty t in + GProd (Loc.ghost,nme,Explicit,traw,t2) | (_,Some _,_) -> assert false @@ -893,7 +873,7 @@ let merge_inductive (ind1: inductive) (ind2: inductive) let prms1,prms2, rawlist = merge_mutual_inductive_body mib1 mib2 shift_prm in let _ = prstr "\nrawlist : " in let _ = - List.iter (fun (nm,tp) -> prNamedRConstr (string_of_id nm) tp;prstr "\n") rawlist in + 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 = @@ -904,15 +884,16 @@ let merge_inductive (ind1: inductive) (ind2: inductive) let indexpr = glob_constr_list_to_inductive_expr prms1 prms2 mib1 mib2 shift_prm rawlist in (* Declare inductive *) let indl,_,_ = Command.extract_mutual_inductive_declaration_components [(indexpr,[])] in - let mie,impls = Command.interp_mutual_inductive indl [] true (* means: not coinductive *) in + let mie,impls = Command.interp_mutual_inductive indl [] + false (*FIXMEnon-poly *) 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 Declare.UserVerbose mie impls) + ignore (Command.declare_mutual_inductive_with_eliminations mie impls) (* Find infos on identifier id. *) -let find_Function_infos_safe (id:identifier): Indfun_common.function_info = +let find_Function_infos_safe (id:Id.t): Indfun_common.function_info = let kn_of_id x = - let f_ref = Libnames.Ident (dummy_loc,x) in + 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) @@ -927,8 +908,8 @@ let find_Function_infos_safe (id:identifier): Indfun_common.function_info = Warning: For the moment, repetitions of an id in [args1] or [args2] are not supported. *) -let merge (id1:identifier) (id2:identifier) (args1:identifier array) - (args2:identifier array) id : unit = +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) ?? *) @@ -938,7 +919,7 @@ let merge (id1:identifier) (id2:identifier) (args1:identifier array) as above: vars may be linked inside args2?? *) Array.mapi (fun i c -> - match array_find_i (fun i x -> x=c) args1 with + match Array.findi (fun i x -> Id.equal x c) args1 with | Some j -> Linked j | None -> Unlinked) args2 in @@ -955,7 +936,7 @@ let remove_last_arg c = let xnolast = List.rev (List.tl (List.rev x)) in compose_prod xnolast y -let rec remove_n_fst_list n l = if n=0 then l else remove_n_fst_list (n-1) (List.tl l) +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 = @@ -977,7 +958,7 @@ let funify_branches relinfo nfuns branch = | _ -> assert false in let is_dom c = match kind_of_term c with - | Ind((u,_)) | Construct((u,_),_) -> u = mut_induct + | Ind(((u,_),_)) | Construct(((u,_),_),_) -> MutInd.equal u mut_induct | _ -> false in let _dom_i c = assert (is_dom c); diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index a33ae1d6..5558556e 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -1,59 +1,111 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* + (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))))) + ) + |_ -> assert false + +let type_of_const t = + match (kind_of_term t) with + Const sp -> Typeops.type_of_constant (Global.env()) sp + |_ -> assert false + +let constr_of_global x = + fst (Universes.unsafe_constr_of_global 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") + + +let nf_zeta env = + Reductionops.clos_norm_flags (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA]) + env + Evd.empty + + +let nf_betaiotazeta = (* Reductionops.local_strong Reductionops.whd_betaiotazeta *) + let clos_norm_flags flgs env sigma t = + Closure.norm_val (Closure.create_clos_infos flgs env) (Closure.inject (Reductionops.nf_evar sigma t)) in + clos_norm_flags Closure.betaiotazeta Environ.empty_env Evd.empty + + + + + +(* Generic values *) let pf_get_new_ids idl g = let ids = pf_ids_of_hyps g in List.fold_right @@ -61,14 +113,98 @@ let pf_get_new_ids idl g = idl [] -let pf_get_new_id id g = - List.hd (pf_get_new_ids [id] g) +let compute_renamed_type gls c = + rename_bound_vars_as_displayed (*no avoid*) [] (*no rels*) [] + (pf_type_of gls c) +let h'_id = Id.of_string "h'" +let teq_id = Id.of_string "teq" +let ano_id = Id.of_string "anonymous" +let x_id = Id.of_string "x" +let k_id = Id.of_string "k" +let v_id = Id.of_string "v" +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 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)) +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") +let le_trans = function () -> (coq_constant arith_Nat "le_trans") +let le_lt_trans = function () -> (coq_constant arith_Nat "le_lt_trans") +let lt_S_n = function () -> (coq_constant arith_Lt "lt_S_n") +let le_n = function () -> (coq_init_constant "le_n") +let coq_sig_ref = function () -> (find_reference ["Coq";"Init";"Specif"] "sig") +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 coq_conj = function () -> find_reference Coqlib.logic_module_name "conj" + +let f_S t = mkApp(delayed_force coq_S, [|t|]);; -let h_intros l = - tclMAP h_intro l +let rec n_x_id ids n = + if Int.equal n 0 then [] + else let x = next_ident_away_in_goal x_id ids in + x::n_x_id (x::ids) (n-1);; -let debug_queue = Stack.create () +let simpl_iter clause = + reduce + (Lazy + {rBeta=true;rIota=true;rZeta= true; rDelta=false; + rConst = [ EvalConstRef (const_of_ref (delayed_force iter_ref))]}) + clause + +(* Others ugly things ... *) +let (value_f:constr list -> global_reference -> constr) = + fun al fterm -> + let d0 = Loc.ghost in + let rev_x_id_l = + ( + List.fold_left + (fun x_id_l _ -> + let x_id = next_ident_away_in_goal x_id x_id_l in + x_id::x_id_l + ) + [] + al + ) + in + let context = List.map + (fun (x, c) -> Name x, None, c) (List.combine rev_x_id_l (List.rev al)) + 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), + (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)]) + in + let body = fst (understand env Evd.empty glob_body)(*FIXME*) in + it_mkLambda_or_LetIn body context + +let (declare_f : Id.t -> logical_kind -> constr list -> global_reference -> global_reference) = + fun f_id kind input_type fterm_ref -> + declare_fun f_id kind (value_f input_type fterm_ref);; + + + +(* Debuging mechanism *) +let debug_queue = Stack.create () let rec print_debug_queue b e = if not (Stack.is_empty debug_queue) @@ -76,267 +212,445 @@ let rec print_debug_queue b e = begin let lmsg,goal = Stack.pop debug_queue in if b then - msgnl (lmsg ++ (str " raised exception " ++ Errors.print e) ++ str " on goal " ++ goal) + Pp.msg_debug (lmsg ++ (str " raised exception " ++ Errors.print e) ++ str " on goal " ++ goal) else begin - msgnl (str " from " ++ lmsg ++ str " on goal " ++ goal); + Pp.msg_debug (str " from " ++ lmsg ++ str " on goal " ++ goal); end; print_debug_queue false e; end - +let observe strm = + if do_observe () + then Pp.msg_debug strm + else () + let do_observe_tac s tac g = let goal = Printer.pr_goal g in - let lmsg = (str "recdef : ") ++ (str s) in + let lmsg = (str "recdef : ") ++ s in + observe (s++fnl()); Stack.push (lmsg,goal) debug_queue; try let v = tac g in ignore(Stack.pop debug_queue); v with reraise -> + let reraise = Errors.push reraise in if not (Stack.is_empty debug_queue) - then - print_debug_queue true reraise; - raise reraise + then print_debug_queue true (fst (Cerrors.process_vernac_interp_error reraise)); + iraise reraise let observe_tac s tac g = - if Tacinterp.get_debug () <> Tactic_debug.DebugOff + if do_observe () then do_observe_tac s tac g else tac g -let hyp_ids = List.map id_of_string - ["x";"v";"k";"def";"p";"h";"n";"h'"; "anonymous"; "teq"; "rec_res"; - "hspec";"heq"; "hrec"; "hex"; "teq"; "pmax";"hle"];; - -let rec nthtl = function - l, 0 -> l | _::tl, n -> nthtl (tl, n-1) | [], _ -> [];; - -let hyp_id n l = List.nth l n;; - -let (x_id:identifier) = hyp_id 0 hyp_ids;; -let (v_id:identifier) = hyp_id 1 hyp_ids;; -let (k_id:identifier) = hyp_id 2 hyp_ids;; -let (def_id:identifier) = hyp_id 3 hyp_ids;; -let (p_id:identifier) = hyp_id 4 hyp_ids;; -let (h_id:identifier) = hyp_id 5 hyp_ids;; -let (n_id:identifier) = hyp_id 6 hyp_ids;; -let (h'_id:identifier) = hyp_id 7 hyp_ids;; -let (ano_id:identifier) = hyp_id 8 hyp_ids;; -let (rec_res_id:identifier) = hyp_id 10 hyp_ids;; -let (hspec_id:identifier) = hyp_id 11 hyp_ids;; -let (heq_id:identifier) = hyp_id 12 hyp_ids;; -let (hrec_id:identifier) = hyp_id 13 hyp_ids;; -let (hex_id:identifier) = hyp_id 14 hyp_ids;; -let (teq_id:identifier) = hyp_id 15 hyp_ids;; -let (pmax_id:identifier) = hyp_id 16 hyp_ids;; -let (hle_id:identifier) = hyp_id 17 hyp_ids;; - -let message s = if Flags.is_verbose () then msgnl(str s);; +(* Conclusion tactics *) -let def_of_const t = - match (kind_of_term t) with - Const sp -> - (try (match body_of_constant (Global.lookup_constant sp) with - | Some c -> Declarations.force c - | _ -> assert false) - with e when Errors.noncritical e -> - anomaly ("Cannot find definition of constant "^ - (string_of_id (id_of_label (con_label sp)))) - ) - |_ -> assert false +(* The boolean value is_mes expresses that the termination is expressed + using a measure function instead of a well-founded relation. *) +let tclUSER tac is_mes l g = + let clear_tac = + match l with + | None -> clear [] + | Some l -> tclMAP (fun id -> tclTRY (clear [id])) (List.rev l) + in + tclTHENLIST + [ + clear_tac; + if is_mes + then tclTHENLIST + [ + unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference + (delayed_force Indfun_common.ltof_ref))]; + tac + ] + else tac + ] + g -let type_of_const t = - match (kind_of_term t) with - Const sp -> Typeops.type_of_constant (Global.env()) sp - |_ -> assert false +let tclUSER_if_not_mes concl_tac is_mes names_to_suppress = + if is_mes + then tclCOMPLETE (fun gl -> Proofview.V82.of_tactic (Simple.apply (delayed_force well_founded_ltof)) gl) + else (* tclTHEN (Simple.apply (delayed_force acc_intro_generator_function) ) *) (tclUSER concl_tac is_mes names_to_suppress) + + + + -let arg_type t = - match kind_of_term (def_of_const t) with - Lambda(a,b,c) -> b - | _ -> assert false;; - -let evaluable_of_global_reference r = - match r with - ConstRef sp -> EvalConstRef sp - | VarRef id -> EvalVarRef id - | _ -> assert false;; - - -let rank_for_arg_list h = - let predicate a b = - try List.for_all2 eq_constr a b with - Invalid_argument _ -> false in - let rec rank_aux i = function - | [] -> None - | x::tl -> if predicate h x then Some i else rank_aux (i+1) tl in - rank_aux 0;; - -let rec check_not_nested f t = - match kind_of_term t with - | App(g, _) when eq_constr f g -> - errorlabstrm "recdef" (str "Nested recursive function are not allowed with Function") - | Var(_) when eq_constr t f -> errorlabstrm "recdef" (str "Nested recursive function are not allowed with Function") - | _ -> iter_constr (check_not_nested f) t - - - - -let rec (find_call_occs : int -> int -> constr -> constr -> - (constr list -> constr) * constr list list) = - fun nb_arg nb_lam f expr -> - match (kind_of_term expr) with - App (g, args) when eq_constr g f -> - if Array.length args <> nb_arg then errorlabstrm "recdef" (str "Partial application of function " ++ Printer.pr_lconstr expr ++ str " in its body is not allowed while using Function"); - Array.iter (check_not_nested f) args; - (fun l -> List.hd l), [Array.to_list args] - | App (g, args) -> - let (largs: constr list) = Array.to_list args in - let rec find_aux = function - [] -> (fun x -> []), [] - | a::upper_tl -> - (match find_aux upper_tl with - (cf, ((arg1::args) as args_for_upper_tl)) -> - (match find_call_occs nb_arg nb_lam f a with - cf2, (_ :: _ as other_args) -> - let rec avoid_duplicates args = - match args with - | [] -> (fun _ -> []), [] - | h::tl -> - let recomb_tl, args_for_tl = - avoid_duplicates tl in - match rank_for_arg_list h args_for_upper_tl with - | None -> - (fun l -> List.hd l::recomb_tl(List.tl l)), - h::args_for_tl - | Some i -> - (fun l -> List.nth l (i+List.length args_for_tl):: - recomb_tl l), - args_for_tl - in - let recombine, other_args' = - avoid_duplicates other_args in - let len1 = List.length other_args' in - (fun l -> cf2 (recombine l)::cf(nthtl(l,len1))), - other_args'@args_for_upper_tl - | _, [] -> (fun x -> a::cf x), args_for_upper_tl) - | _, [] -> - (match find_call_occs nb_arg nb_lam f a with - cf, (arg1::args) -> (fun l -> cf l::upper_tl), (arg1::args) - | _, [] -> (fun x -> a::upper_tl), [])) in - begin - match (find_aux largs) with - cf, [] -> (fun l -> mkApp(g, args)), [] - | cf, args -> - (fun l -> mkApp (g, Array.of_list (cf l))), args - end - | Rel(v) -> if v > nb_lam then error "find_call_occs : Rel" else ((fun l -> expr),[]) - | Var(_) when eq_constr expr f -> errorlabstrm "recdef" (str "Partial application of function " ++ Printer.pr_lconstr expr ++ str " in its body is not allowed while using Function") - | Var(id) -> (fun l -> expr), [] - | Meta(_) -> error "Found a metavariable. Can not treat such a term" - | Evar(_) -> error "Found an evar. Can not treat such a term" - | Sort(_) -> (fun l -> expr), [] - | Cast(b,_,_) -> find_call_occs nb_arg nb_lam f b - | Prod(na,t,b) -> - error "Found a product. Can not treat such a term" - | Lambda(na,t,b) -> +(* Travelling term. + Both definitions of [f_terminate] and [f_equation] use the same generic + travelling mechanism. +*) + +(* [check_not_nested forbidden e] checks that [e] does not contains any variable + of [forbidden] +*) +let check_not_nested forbidden e = + let rec check_not_nested e = + match kind_of_term e with + | Rel _ -> () + | Var x -> + if Id.List.mem x forbidden + then error ("check_not_nested : failure "^Id.to_string 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 + | Lambda(_,t,b) -> check_not_nested t;check_not_nested b + | LetIn(_,v,t,b) -> check_not_nested t;check_not_nested b;check_not_nested v + | App(f,l) -> check_not_nested f;Array.iter check_not_nested l + | Proj (p,c) -> check_not_nested c + | Const _ -> () + | Ind _ -> () + | Construct _ -> () + | 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" + in + try + check_not_nested e + with UserError(_,p) -> + errorlabstrm "_" (str "on expr : " ++ Printer.pr_lconstr e ++ str " " ++ p) + +(* ['a info] contains the local information for travelling *) +type 'a infos = + { nb_arg : int; (* function number of arguments *) + concl_tac : tactic; (* final tactic to finish proofs *) + rec_arg_id : Id.t; (*name of the declared recursive argument *) + is_mes : bool; (* type of recursion *) + ih : Id.t; (* induction hypothesis name *) + f_id : Id.t; (* function name *) + f_constr : constr; (* function term *) + f_terminate : constr; (* termination proof term *) + func : global_reference; (* functionnal reference *) + info : 'a; + is_main_branch : bool; (* on the main branch or on a matched expression *) + is_final : bool; (* final first order term or not *) + values_and_bounds : (Id.t*Id.t) list; + eqs : Id.t list; + forbidden_ids : Id.t list; + acc_inv : constr lazy_t; + acc_id : Id.t; + args_assoc : ((constr list)*constr) list; + } + + +type ('a,'b) journey_info_tac = + 'a -> (* the arguments of the constructor *) + 'b infos -> (* infos of the caller *) + ('b infos -> tactic) -> (* the continuation tactic of the caller *) + 'b infos -> (* argument of the tactic *) + tactic + +(* journey_info : specifies the actions to do on the different term constructors during the travelling of the term +*) +type journey_info = + { letiN : ((Name.t*constr*types*constr),constr) journey_info_tac; + lambdA : ((Name.t*types*constr),constr) journey_info_tac; + casE : ((constr infos -> tactic) -> constr infos -> tactic) -> + ((case_info * constr * constr * constr array),constr) journey_info_tac; + otherS : (unit,constr) journey_info_tac; + apP : (constr*(constr list),constr) journey_info_tac; + app_reC : (constr*(constr list),constr) journey_info_tac; + message : string + } + + + +let rec add_vars forbidden e = + match kind_of_term e with + | Var x -> x::forbidden + | _ -> fold_constr add_vars 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 ids = List.fold_left (fun acc (na,_) -> + let pre_id = + match na with + | Name x -> x + | Anonymous -> ano_id + in + pre_id::acc + ) [] rev_context in + let rev_ids = pf_get_new_ids (List.rev ids) g in + let new_b = substl (List.map mkVar rev_ids) b in + tclTHENLIST + [ + h_intros (List.rev rev_ids); + Proofview.V82.of_tactic (intro_using teq_id); + onLastHypId (fun heq -> + tclTHENLIST[ + thin to_intros; + h_intros to_intros; + (fun g' -> + let ty_teq = pf_type_of g' (mkVar heq) in + let teq_lhs,teq_rhs = + let _,args = try destApp 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_infos = { + infos with + info = new_b'; + eqs = heq::infos.eqs; + forbidden_ids = + if forbid_new_ids + then add_vars infos.forbidden_ids new_b' + else infos.forbidden_ids + } in + finalize_tac new_infos g' + ) + ] + ) + ] 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" + | LetIn(na,b,t,e) -> begin - match find_call_occs nb_arg (succ nb_lam) f b with - | _, [] -> (* Lambda are authorized as long as they do not contain - recursives calls *) - (fun l -> expr),[] - | _ -> error "Found a lambda which body contains a recursive call. Such terms are not allowed" + 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} end - | LetIn(na,v,t,b) -> + | Rel _ -> anomaly (Pp.str "Free var in goal conclusion !") + | Prod _ -> begin - match find_call_occs nb_arg nb_lam f v, find_call_occs nb_arg (succ nb_lam) f b with - | (_,[]),(_,[]) -> - ((fun l -> expr), []) - | (_,[]),(cf,(_::_ as l)) -> - ((fun l -> mkLetIn(na,v,t,cf l)),l) - | (cf,(_::_ as l)),(_,[]) -> - ((fun l -> mkLetIn(na,cf l,t,b)), l) - | _ -> error "Found a letin with recursive calls in both variable value and body. Such terms are not allowed." + try + check_not_nested (expr_info.f_id::expr_info.forbidden_ids) expr_info.info; + jinfo.otherS () expr_info continuation_tac expr_info + with e when Errors.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) end - | Const(_) -> (fun l -> expr), [] - | Ind(_) -> (fun l -> expr), [] - | Construct (_, _) -> (fun l -> expr), [] - | Case(i,t,a,r) -> - (match find_call_occs nb_arg nb_lam f a with - cf, (arg1::args) -> (fun l -> mkCase(i, t, (cf l), r)),(arg1::args) - | _ -> (fun l -> expr),[]) - | Fix(_) -> error "Found a local fixpoint. Can not treat such a term" - | CoFix(_) -> error "Found a local cofixpoint : CoFix";; - -let coq_constant s = - Coqlib.gen_constant_in_modules "RecursiveDefinition" - (Coqlib.init_modules @ Coqlib.arith_modules) s;; - -let coq_base_constant s = - Coqlib.gen_constant_in_modules "RecursiveDefinition" - (Coqlib.init_modules @ [["Coq";"Arith";"Le"];["Coq";"Arith";"Lt"]]) s;; - -let constant sl s = - constr_of_global - (locate (make_qualid(Names.make_dirpath - (List.map id_of_string (List.rev sl))) - (id_of_string s)));; + | 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 + with e when Errors.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) + end + | Case(ci,t,a,l) -> + begin + let continuation_tac_a = + jinfo.casE + (travel jinfo) (ci,t,a,l) + expr_info continuation_tac in + travel + jinfo continuation_tac_a + {expr_info with info = a; is_main_branch = false; + is_final = false} + 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 + else + begin + match kind_of_term f with + | App _ -> assert false (* f is coming from a decompose_app *) + | Const _ | Construct _ | Rel _ | Evar _ | Meta _ | Ind _ + | Sort _ | Prod _ | Var _ -> + let new_infos = {expr_info with info=(f,args)} in + 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) + end + | Cast(t,_,_) -> travel jinfo continuation_tac {expr_info with info=t} + | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ -> + let new_continuation_tac = + jinfo.otherS () expr_info continuation_tac in + new_continuation_tac expr_info +and travel_args jinfo is_final continuation_tac infos = + let (f_args',args) = infos.info in + match args with + | [] -> + continuation_tac {infos with info = f_args'; is_final = is_final} + | arg::args' -> + let new_continuation_tac new_infos = + let new_arg = new_infos.info in + travel_args jinfo is_final + continuation_tac + {new_infos with info = (mkApp(f_args',[|new_arg|]),args')} + in + travel jinfo new_continuation_tac + {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) + (travel_aux jinfo continuation_tac expr_info) -let find_reference sl s = - (locate (make_qualid(Names.make_dirpath - (List.map id_of_string (List.rev sl))) - (id_of_string s)));; +(* Termination proof *) -let le_lt_SS = function () -> (constant ["Recdef"] "le_lt_SS") -let le_lt_n_Sm = function () -> (coq_base_constant "le_lt_n_Sm") - -let le_trans = function () -> (coq_base_constant "le_trans") -let le_lt_trans = function () -> (coq_base_constant "le_lt_trans") -let lt_S_n = function () -> (coq_base_constant "lt_S_n") -let le_n = function () -> (coq_base_constant "le_n") -let refl_equal = function () -> (coq_base_constant "eq_refl") -let eq = function () -> (coq_base_constant "eq") -let ex = function () -> (coq_base_constant "ex") -let coq_sig_ref = function () -> (find_reference ["Coq";"Init";"Specif"] "sig") -let coq_sig = function () -> (coq_base_constant "sig") -let coq_O = function () -> (coq_base_constant "O") -let coq_S = function () -> (coq_base_constant "S") - -let gt_antirefl = function () -> (coq_constant "gt_irrefl") -let lt_n_O = function () -> (coq_base_constant "lt_n_O") -let lt_n_Sn = function () -> (coq_base_constant "lt_n_Sn") - -let f_equal = function () -> (coq_constant "f_equal") -let well_founded_induction = function () -> (coq_constant "well_founded_induction") -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 iter_ref = function () -> (try find_reference ["Recdef"] "iter" with Not_found -> error "module Recdef not loaded") -let max_ref = function () -> (find_reference ["Recdef"] "max") -let iter = function () -> (constr_of_global (delayed_force iter_ref)) -let max_constr = function () -> (constr_of_global (delayed_force max_ref)) +let rec prove_lt hyple g = + begin + try + let (varx,varz) = match decompose_app (pf_concl g) with + | _, x::z::_ when isVar x && isVar z -> x, z + | _ -> assert false + in + let h = + List.find (fun id -> + match decompose_app (pf_type_of g (mkVar id)) with + | _, t::_ -> eq_constr t varx + | _ -> false + ) hyple + in + let y = + List.hd (List.tl (snd (decompose_app (pf_type_of g (mkVar h))))) in + tclTHENLIST[ + Proofview.V82.of_tactic (apply (mkApp(le_lt_trans (),[|varx;y;varz;mkVar h|]))); + observe_tac (str "prove_lt") (prove_lt hyple) + ] + with Not_found -> + ( + ( + tclTHENLIST[ + Proofview.V82.of_tactic (apply (delayed_force lt_S_n)); + (observe_tac (str "assumption: " ++ Printer.pr_goal g) (Proofview.V82.of_tactic assumption)) + ]) + ) + end + g + +let rec destruct_bounds_aux infos (bound,hyple,rechyps) lbounds g = + match lbounds with + | [] -> + let ids = pf_ids_of_hyps g in + let s_max = mkApp(delayed_force coq_S, [|bound|]) in + let k = next_ident_away_in_goal k_id ids in + let ids = k::ids in + let h' = next_ident_away_in_goal (h'_id) ids in + let ids = h'::ids in + let def = next_ident_away_in_goal def_id ids in + tclTHENLIST[ + Proofview.V82.of_tactic (split (ImplicitBindings [s_max])); + Proofview.V82.of_tactic (intro_then + (fun id -> + Proofview.V82.tactic begin + observe_tac (str "destruct_bounds_aux") + (tclTHENS (Proofview.V82.of_tactic (simplest_case (mkVar id))) + [ + tclTHENLIST[Proofview.V82.of_tactic (intro_using h_id); + Proofview.V82.of_tactic (simplest_elim(mkApp(delayed_force lt_n_O,[|s_max|]))); + Proofview.V82.of_tactic default_full_auto]; + tclTHENLIST[ + observe_tac (str "clearing k ") (clear [id]); + h_intros [k;h';def]; + observe_tac (str "simple_iter") (simpl_iter Locusops.onConcl); + observe_tac (str "unfold functional") + (unfold_in_concl[(Locus.OnlyOccurrences [1], + evaluable_of_global_reference infos.func)]); + observe_tac (str "test" ) ( + tclTHENLIST[ + list_rewrite true + (List.fold_right + (fun e acc -> (mkVar e,true)::acc) + infos.eqs + (List.map (fun e -> (e,true)) rechyps) + ); + (* list_rewrite true *) + (* (List.map (fun e -> (mkVar e,true)) infos.eqs) *) + (* ; *) + + (observe_tac (str "finishing") + (tclORELSE + (Proofview.V82.of_tactic intros_reflexivity) + (observe_tac (str "calling prove_lt") (prove_lt hyple))))]) + ] + ] + )end)) + ] g + | (_,v_bound)::l -> + tclTHENLIST[ + Proofview.V82.of_tactic (simplest_elim (mkVar v_bound)); + clear [v_bound]; + tclDO 2 (Proofview.V82.of_tactic intro); + onNthHypId 1 + (fun p_hyp -> + (onNthHypId 2 + (fun p -> + tclTHENLIST[ + Proofview.V82.of_tactic (simplest_elim + (mkApp(delayed_force max_constr, [| bound; mkVar p|]))); + tclDO 3 (Proofview.V82.of_tactic intro); + onNLastHypsId 3 (fun lids -> + match lids with + [hle2;hle1;pmax] -> + destruct_bounds_aux infos + ((mkVar pmax), + hle1::hle2::hyple,(mkVar p_hyp)::rechyps) + l + | _ -> assert false) ; + ] + ) + ) + ) + ] g + +let destruct_bounds infos = + destruct_bounds_aux infos (delayed_force coq_O,[],[]) infos.values_and_bounds + +let terminate_app f_and_args expr_info continuation_tac infos = + if expr_info.is_final && expr_info.is_main_branch + then + tclTHENLIST[ + continuation_tac infos; + observe_tac (str "first split") + (Proofview.V82.of_tactic (split (ImplicitBindings [infos.info]))); + observe_tac (str "destruct_bounds (1)") (destruct_bounds infos) + ] + else continuation_tac infos + +let terminate_others _ expr_info continuation_tac infos = + if expr_info.is_final && expr_info.is_main_branch + then + tclTHENLIST[ + continuation_tac infos; + observe_tac (str "first split") + (Proofview.V82.of_tactic (split (ImplicitBindings [infos.info]))); + observe_tac (str "destruct_bounds") (destruct_bounds infos) + ] + else continuation_tac infos + +let terminate_letin (na,b,t,e) expr_info continuation_tac info = + 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; + true + with e when Errors.noncritical e -> false + in + if forbid + then + match na with + | Anonymous -> info.forbidden_ids + | Name id -> id::info.forbidden_ids + else info.forbidden_ids + in + continuation_tac {info with info = new_e; forbidden_ids = new_forbidden} + +let pf_type c tac gl = + let evars, ty = Typing.e_type_of (pf_env gl) (project gl) c in + tclTHEN (Refiner.tclEVARS evars) (tac ty) gl -let ltof_ref = function () -> (find_reference ["Coq";"Arith";"Wf_nat"] "ltof") -let coq_conj = function () -> find_reference ["Coq";"Init";"Logic"] "conj" - -(* These are specific to experiments in nat with lt as well_founded_relation, *) -(* but this should be made more general. *) -let nat = function () -> (coq_base_constant "nat") -let lt = function () -> (coq_base_constant "lt") - -(* This is simply an implementation of the case_eq tactic. this code - should be replaced with the tactic defined in Ltac in Init/Tactics.v *) -let mkCaseEq a : tactic = - (fun g -> - let type_of_a = pf_type_of g a in - tclTHENLIST - [h_generalize [mkApp(delayed_force refl_equal, [| type_of_a; a|])]; - (fun g2 -> - change_in_concl None - (pattern_occs [((false,[1]), a)] (pf_env g2) Evd.empty (pf_concl g2)) - g2); - simplest_case a] g);; +let pf_typel l tac = + let rec aux tys l = + match l with + | [] -> tac (List.rev tys) + | hd :: tl -> pf_type hd (fun ty -> aux (ty::tys) tl) + in aux [] l (* This is like the previous one except that it also rewrite on all hypotheses except the ones given in the first argument. All the @@ -344,390 +658,355 @@ let mkCaseEq a : tactic = introduced back later; the result is the pair of the tactic and the list of hypotheses that have been generalized and cleared. *) let mkDestructEq : - identifier list -> constr -> goal sigma -> tactic * identifier list = + Id.t list -> constr -> goal sigma -> tactic * Id.t list = fun not_on_hyp expr g -> let hyps = pf_hyps g in let to_revert = - Util.map_succeed - (fun (id,_,t) -> - if List.mem id not_on_hyp || not (Termops.occur_term expr t) - then failwith "is_expr_context"; - id) hyps in + Util.List.map_filter + (fun (id, _, t) -> + if Id.List.mem id not_on_hyp || not (Termops.occur_term expr t) + then None else Some id) hyps in let to_revert_constr = List.rev_map mkVar to_revert in let type_of_expr = pf_type_of g expr in - let new_hyps = mkApp(delayed_force refl_equal, [|type_of_expr; expr|]):: + let new_hyps = mkApp(Lazy.force refl_equal, [|type_of_expr; expr|]):: to_revert_constr in + pf_typel new_hyps (fun _ -> tclTHENLIST - [h_generalize new_hyps; + [Simple.generalize new_hyps; (fun g2 -> - change_in_concl None - (pattern_occs [((false,[1]), expr)] (pf_env g2) Evd.empty (pf_concl g2)) g2); - simplest_case expr], to_revert - -let rec mk_intros_and_continue thin_intros (extra_eqn:bool) - cont_function (eqs:constr list) nb_lam (expr:constr) g = - observe_tac "mk_intros_and_continue" ( - let finalize () = if extra_eqn then - let teq = pf_get_new_id teq_id g in - tclTHENLIST - [ h_intro teq; - thin thin_intros; - h_intros thin_intros; - - tclMAP - (fun eq -> tclTRY (Equality.general_rewrite_in true Termops.all_occurrences true (* deps proofs also: *) true teq eq false)) - (List.rev eqs); - (fun g1 -> - let ty_teq = pf_type_of g1 (mkVar teq) in - let teq_lhs,teq_rhs = - let _,args = - try destApp ty_teq - with e when Errors.noncritical e -> - Pp.msgnl (Printer.pr_goal g1 ++ fnl () ++ pr_id teq ++ str ":" ++ Printer.pr_lconstr ty_teq); assert false - in - args.(1),args.(2) - in - cont_function (mkVar teq::eqs) (Termops.replace_term teq_lhs teq_rhs expr) g1 - ) - ] - - else - tclTHENSEQ[ - thin thin_intros; - h_intros thin_intros; - cont_function eqs expr - ] - in - if nb_lam = 0 - then finalize () - else - match kind_of_term expr with - | Lambda (n, _, b) -> - let n1 = - match n with - Name x -> x - | Anonymous -> ano_id - in - let new_n = pf_get_new_id n1 g in - tclTHEN (h_intro new_n) - (mk_intros_and_continue thin_intros extra_eqn cont_function eqs - (pred nb_lam) (subst1 (mkVar new_n) b)) - | _ -> - assert false) g -(* finalize () *) -let const_of_ref = function - ConstRef kn -> kn - | _ -> anomaly "ConstRef expected" + Proofview.V82.of_tactic (change_in_concl None + (fun sigma -> + pattern_occs [Locus.AllOccurrencesBut [1], expr] (pf_env g2) sigma (pf_concl g2))) g2); + Proofview.V82.of_tactic (simplest_case expr)]), to_revert -let simpl_iter clause = - reduce - (Lazy - {rBeta=true;rIota=true;rZeta= true; rDelta=false; - rConst = [ EvalConstRef (const_of_ref (delayed_force iter_ref))]}) -(* (Simpl (Some ([],mkConst (const_of_ref (delayed_force iter_ref))))) *) - clause -(* The boolean value is_mes expresses that the termination is expressed - using a measure function instead of a well-founded relation. *) -let tclUSER tac is_mes l g = - let clear_tac = - match l with - | None -> h_clear true [] - | Some l -> tclMAP (fun id -> tclTRY (h_clear false [id])) (List.rev l) +let terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos g = + let b = + try + check_not_nested (expr_info.f_id::expr_info.forbidden_ids) a; + false + with e when Errors.noncritical e -> + true in - tclTHENSEQ - [ - clear_tac; - if is_mes - then tclTHEN - (unfold_in_concl [(Termops.all_occurrences, evaluable_of_global_reference - (delayed_force ltof_ref))]) - tac - else tac - ] + let a' = infos.info in + let new_info = + {infos with + info = mkCase(ci,t,a',l); + is_main_branch = expr_info.is_main_branch; + is_final = expr_info.is_final} in + 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 case " ++ int (Array.length l) ++ spc () ++ Printer.pr_lconstr a') + (try + (tclTHENS + destruct_tac + (List.map_i (fun i e -> observe_tac (str "do treat case") (treat_case b 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} ) + )) g + +let terminate_app_rec (f,args) expr_info continuation_tac _ = + List.iter (check_not_nested (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 new_infos = {expr_info with info = v} in + tclTHENLIST[ + continuation_tac new_infos; + if expr_info.is_final && expr_info.is_main_branch + then + tclTHENLIST[ + observe_tac (str "first split") + (Proofview.V82.of_tactic (split (ImplicitBindings [new_infos.info]))); + observe_tac (str "destruct_bounds (3)") + (destruct_bounds new_infos) + ] + else + tclIDTAC + ] + 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)))) + [ + tclTHENLIST[ + Proofview.V82.of_tactic (intro_using rec_res_id); + Proofview.V82.of_tactic intro; + onNthHypId 1 + (fun v_bound -> + (onNthHypId 2 + (fun v -> + let new_infos = { expr_info with + info = (mkVar v); + values_and_bounds = + (v,v_bound)::expr_info.values_and_bounds; + args_assoc=(args,mkVar v)::expr_info.args_assoc + } in + tclTHENLIST[ + continuation_tac new_infos; + if expr_info.is_final && expr_info.is_main_branch + then + tclTHENLIST[ + observe_tac (str "first split") + (Proofview.V82.of_tactic (split (ImplicitBindings [new_infos.info]))); + observe_tac (str "destruct_bounds (2)") + (destruct_bounds new_infos) + ] + else + tclIDTAC + ] + ) + ) + ) + ]; + observe_tac (str "proving decreasing") ( + tclTHENS (* proof of args < formal args *) + (Proofview.V82.of_tactic (apply (Lazy.force expr_info.acc_inv))) + [ + observe_tac (str "assumption") (Proofview.V82.of_tactic assumption); + tclTHENLIST + [ + tclTRY(list_rewrite true + (List.map + (fun e -> mkVar e,true) + expr_info.eqs + ) + ); + tclUSER expr_info.concl_tac true + (Some ( + expr_info.ih::expr_info.acc_id:: + (fun (x,y) -> y) + (List.split expr_info.values_and_bounds) + ) + ); + ] + ]) + ]) + end +let terminate_info = + { message = "prove_terminate with term "; + letiN = terminate_letin; + lambdA = (fun _ _ _ _ -> assert false); + casE = terminate_case; + otherS = terminate_others; + apP = terminate_app; + app_reC = terminate_app_rec; + } -let list_rewrite (rev:bool) (eqs: constr list) = - tclREPEAT - (List.fold_right - (fun eq i -> tclORELSE (rewriteLR eq) i) - (if rev then (List.rev eqs) else eqs) (tclFAIL 0 (mt())));; - -let base_leaf_terminate (func:global_reference) eqs expr = -(* let _ = msgnl (str "entering base_leaf") in *) - (fun g -> - let k',h = - match pf_get_new_ids [k_id;h_id] g with - [k';h] -> k',h - | _ -> assert false - in - tclTHENLIST - [observe_tac "first split" (split (ImplicitBindings [expr])); - observe_tac "second split" - (split (ImplicitBindings [delayed_force coq_O])); - observe_tac "intro k" (h_intro k'); - observe_tac "case on k" - (tclTHENS (simplest_case (mkVar k')) - [(tclTHEN (h_intro h) - (tclTHEN (simplest_elim (mkApp (delayed_force gt_antirefl, - [| delayed_force coq_O |]))) - default_auto)); tclIDTAC ]); - intros; - simpl_iter onConcl; - unfold_constr func; - list_rewrite true eqs; - default_auto] g);; - -(* La fonction est donnee en premier argument a la - fonctionnelle suivie d'autres Lambdas et de Case ... - Pour recuperer la fonction f a partir de la - fonctionnelle *) - -let get_f foncl = - match (kind_of_term (def_of_const foncl)) with - Lambda (Name f, _, _) -> f - |_ -> error "la fonctionnelle est mal definie";; - - -let rec compute_le_proofs = function - [] -> assumption - | a::tl -> - tclORELSE assumption - (tclTHENS - (fun g -> - let le_trans = delayed_force le_trans in - let t_le_trans = compute_renamed_type g le_trans in - let m_id = - let _,_,t = destProd t_le_trans in - let na,_,_ = destProd t in - Nameops.out_name na - in - apply_with_bindings - (le_trans, - ExplicitBindings[dummy_loc,NamedHyp m_id,a]) - g) - [compute_le_proofs tl; - tclORELSE (apply (delayed_force le_n)) assumption]) - -let make_lt_proof pmax le_proof = - tclTHENS - (fun g -> - let le_lt_trans = delayed_force le_lt_trans in - let t_le_lt_trans = compute_renamed_type g le_lt_trans in - let m_id = - let _,_,t = destProd t_le_lt_trans in - let na,_,_ = destProd t in - Nameops.out_name na - in - apply_with_bindings - (le_lt_trans, - ExplicitBindings[dummy_loc,NamedHyp m_id, pmax]) g) - [observe_tac "compute_le_proofs" (compute_le_proofs le_proof); - tclTHENLIST[observe_tac "lt_S_n" (apply (delayed_force lt_S_n)); default_full_auto]];; - -let rec list_cond_rewrite k def pmax cond_eqs le_proofs = - match cond_eqs with - [] -> tclIDTAC - | eq::eqs -> - (fun g -> - let t_eq = compute_renamed_type g (mkVar eq) in - let k_id,def_id = - 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 - in - tclTHENS - (general_rewrite_bindings false Termops.all_occurrences - (* dep proofs also: *) true true - (mkVar eq, - ExplicitBindings[dummy_loc, NamedHyp k_id, mkVar k; - dummy_loc, NamedHyp def_id, mkVar def]) false) - [list_cond_rewrite k def pmax eqs le_proofs; - observe_tac "make_lt_proof" (make_lt_proof pmax le_proofs)] g - ) +let prove_terminate = travel terminate_info -let rec introduce_all_equalities func eqs values specs bound le_proofs - cond_eqs = - match specs with - [] -> - fun g -> - let ids = pf_ids_of_hyps g in - let s_max = mkApp(delayed_force coq_S, [|bound|]) in - let k = next_ident_away_in_goal k_id ids in - let ids = k::ids in - let h' = next_ident_away_in_goal (h'_id) ids in - let ids = h'::ids in - let def = next_ident_away_in_goal def_id ids in - tclTHENLIST - [observe_tac "introduce_all_equalities_final split" (split (ImplicitBindings [s_max])); - observe_tac "introduce_all_equalities_final intro k" (h_intro k); - tclTHENS - (observe_tac "introduce_all_equalities_final case k" (simplest_case (mkVar k))) - [ - tclTHENLIST[h_intro h'; - simplest_elim(mkApp(delayed_force lt_n_O,[|s_max|])); - default_full_auto]; - tclIDTAC - ]; - observe_tac "clearing k " (clear [k]); - observe_tac "intros k h' def" (h_intros [k;h';def]); - observe_tac "simple_iter" (simpl_iter onConcl); - observe_tac "unfold functional" - (unfold_in_concl[((true,[1]),evaluable_of_global_reference func)]); - observe_tac "rewriting equations" - (list_rewrite true eqs); - observe_tac ("cond rewrite "^(string_of_id k)) (list_cond_rewrite k def bound cond_eqs le_proofs); - observe_tac "refl equal" (apply (delayed_force refl_equal))] g - | spec1::specs -> - fun g -> - let ids = Termops.ids_of_named_context (pf_hyps g) in - let p = next_ident_away_in_goal p_id ids in - let ids = p::ids in - let pmax = next_ident_away_in_goal pmax_id ids in - let ids = pmax::ids in - let hle1 = next_ident_away_in_goal hle_id ids in - let ids = hle1::ids in - let hle2 = next_ident_away_in_goal hle_id ids in - let ids = hle2::ids in - let heq = next_ident_away_in_goal heq_id ids in - tclTHENLIST - [simplest_elim (mkVar spec1); - list_rewrite true eqs; - h_intros [p; heq]; - simplest_elim (mkApp(delayed_force max_constr, [| bound; mkVar p|])); - h_intros [pmax; hle1; hle2]; - introduce_all_equalities func eqs values specs - (mkVar pmax) ((mkVar pmax)::le_proofs) - (heq::cond_eqs)] g;; - -let string_match s = - if String.length s < 3 then failwith "string_match"; - try - for i = 0 to 3 do - if String.get s i <> String.get "Acc_" i then failwith "string_match" - done; - with Invalid_argument _ -> failwith "string_match" - -let retrieve_acc_var g = - (* Julien: I don't like this version .... *) - let hyps = pf_ids_of_hyps g in - map_succeed - (fun id -> string_match (string_of_id id);id) - hyps - -let rec introduce_all_values concl_tac is_mes acc_inv func context_fn - eqs hrec args values specs = - (match args with - [] -> - tclTHENLIST - [observe_tac "split" (split(ImplicitBindings - [context_fn (List.map mkVar (List.rev values))])); - observe_tac "introduce_all_equalities" (introduce_all_equalities func eqs - (List.rev values) (List.rev specs) (delayed_force coq_O) [] [])] - | arg::args -> - (fun g -> - let ids = Termops.ids_of_named_context (pf_hyps g) in - let rec_res = next_ident_away_in_goal rec_res_id ids in - let ids = rec_res::ids in - let hspec = next_ident_away_in_goal hspec_id ids in - let tac = - observe_tac "introduce_all_values" ( - introduce_all_values concl_tac is_mes acc_inv func context_fn eqs - hrec args - (rec_res::values)(hspec::specs)) in - (tclTHENS - (observe_tac "elim h_rec" - (simplest_elim (mkApp(mkVar hrec, Array.of_list arg))) - ) - [tclTHENLIST [h_intros [rec_res; hspec]; - tac]; - (tclTHENS - (observe_tac "acc_inv" (apply (Lazy.force acc_inv))) - [(* tclTHEN (tclTRY(list_rewrite true eqs)) *) - (observe_tac "h_assumption" h_assumption) - ; - tclTHENLIST - [ - tclTRY(list_rewrite true eqs); - observe_tac "user proof" - (fun g -> - tclUSER - concl_tac - is_mes - (Some (hrec::hspec::(retrieve_acc_var g)@specs)) - g - ) - ] - ] - ) - ]) g) - ) +(* Equation proof *) +let equation_case next_step (ci,a,t,l) expr_info continuation_tac infos = + terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos -let rec_leaf_terminate nb_arg f_constr concl_tac is_mes acc_inv hrec (func:global_reference) eqs expr = - match find_call_occs nb_arg 0 f_constr expr with - | context_fn, args -> - observe_tac "introduce_all_values" - (introduce_all_values concl_tac is_mes acc_inv func context_fn eqs hrec args [] []) +let rec prove_le g = + let x,z = + let _,args = decompose_app (pf_concl g) in + (List.hd args,List.hd (List.tl args)) + in + tclFIRST[ + Proofview.V82.of_tactic assumption; + 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 (h,t) = List.find (fun (_,t) -> matching_fun t) (pf_hyps_types g) + in + let y = + let _,args = decompose_app t in + List.hd (List.tl args) + in + tclTHENLIST[ + Proofview.V82.of_tactic (apply(mkApp(le_trans (),[|x;y;z;mkVar h|]))); + observe_tac (str "prove_le (rec)") (prove_le) + ] + with Not_found -> tclFAIL 0 (mt()) + end; + ] + g -let proveterminate nb_arg rec_arg_id is_mes acc_inv (hrec:identifier) - (f_constr:constr) (func:global_reference) base_leaf rec_leaf = - let rec proveterminate (eqs:constr list) (expr:constr) = - try - (* let _ = msgnl (str "entering proveterminate") in *) - let v = - match (kind_of_term expr) with - Case (ci, t, a, l) -> - (match find_call_occs nb_arg 0 f_constr a with - _,[] -> - (fun g -> - let destruct_tac, rev_to_thin_intro = - mkDestructEq rec_arg_id a g in - tclTHENS destruct_tac - (list_map_i - (fun i -> mk_intros_and_continue - (List.rev rev_to_thin_intro) - true - proveterminate - eqs - ci.ci_cstr_ndecls.(i)) - 0 (Array.to_list l)) g) - | _, _::_ -> - (match find_call_occs nb_arg 0 f_constr expr with - _,[] -> observe_tac "base_leaf" (base_leaf func eqs expr) - | _, _:: _ -> - observe_tac "rec_leaf" - (rec_leaf is_mes acc_inv hrec func eqs expr))) - | _ -> - (match find_call_occs nb_arg 0 f_constr expr with - _,[] -> - (try observe_tac "base_leaf" (base_leaf func eqs expr) - with reraise -> - (msgerrnl (str "failure in base case");raise reraise )) - | _, _::_ -> - observe_tac "rec_leaf" - (rec_leaf is_mes acc_inv hrec func eqs expr)) in - v - with reraise -> +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 ) ( + (fun g -> + 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 + 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) ) + ) + [make_rewrite_list expr_info max l; + tclTHENLIST[ (* x < S max proof *) + Proofview.V82.of_tactic (apply (delayed_force le_lt_n_Sm)); + observe_tac (str "prove_le(2)") prove_le + ] + ] ) + +let make_rewrite expr_info l hp max = + tclTHENFIRST + (observe_tac (str "make_rewrite") (make_rewrite_list expr_info max l)) + (observe_tac (str "make_rewrite") (tclTHENS + (fun g -> + 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 + 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) + [observe_tac(str "make_rewrite finalize") ( + (* tclORELSE( h_reflexivity) *) + (tclTHENLIST[ + simpl_iter Locusops.onConcl; + observe_tac (str "unfold functional") + (unfold_in_concl[(Locus.OnlyOccurrences [1], + evaluable_of_global_reference expr_info.func)]); + + (list_rewrite true + (List.map (fun e -> mkVar e,true) expr_info.eqs)); + (observe_tac (str "h_reflexivity") (Proofview.V82.of_tactic intros_reflexivity))])) + ; + tclTHENLIST[ (* x < S (S max) proof *) + Proofview.V82.of_tactic (apply (delayed_force le_lt_SS)); + observe_tac (str "prove_le (3)") prove_le + ] + ]) + ) + +let rec compute_max rew_tac max l = + match l with + | [] -> rew_tac max + | (_,p,_)::l -> + tclTHENLIST[ + Proofview.V82.of_tactic (simplest_elim + (mkApp(delayed_force max_constr, [| max; mkVar p|]))); + tclDO 3 (Proofview.V82.of_tactic intro); + onNLastHypsId 3 (fun lids -> + match lids with + | [hle2;hle1;pmax] -> compute_max rew_tac (mkVar pmax) l + | _ -> assert false + )] + +let rec destruct_hex expr_info acc l = + match l with + | [] -> begin - msgerrnl(str "failure in proveterminate"); - raise reraise + match List.rev acc with + | [] -> tclIDTAC + | (_,p,hp)::tl -> + observe_tac (str "compute max ") (compute_max (make_rewrite expr_info tl hp) (mkVar p) tl) end - in - proveterminate + | (v,hex)::l -> + tclTHENLIST[ + Proofview.V82.of_tactic (simplest_case (mkVar hex)); + clear [hex]; + tclDO 2 (Proofview.V82.of_tactic intro); + onNthHypId 1 (fun hp -> + onNthHypId 2 (fun p -> + observe_tac + (str "destruct_hex after " ++ pr_id hp ++ spc () ++ pr_id p) + (destruct_hex expr_info ((v,p,hp)::acc) l) + ) + ) + ] + +let rec intros_values_eq expr_info acc = + tclORELSE( + tclTHENLIST[ + tclDO 2 (Proofview.V82.of_tactic intro); + onNthHypId 1 (fun hex -> + (onNthHypId 2 (fun v -> intros_values_eq expr_info ((v,hex)::acc))) + ) + ]) + (tclCOMPLETE ( + destruct_hex expr_info [] acc + )) + +let equation_others _ expr_info continuation_tac infos = + if expr_info.is_final && expr_info.is_main_branch + then + tclTHEN + (continuation_tac infos) + (intros_values_eq expr_info []) + else 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 intros_values_eq expr_info [] + else continuation_tac infos + +let equation_app_rec (f,args) expr_info continuation_tac info = + begin + try + let v = List.assoc_f (List.equal Constr.equal) 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) + with Not_found -> + if expr_info.is_final && expr_info.is_main_branch + then + tclTHENLIST + [ 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 []) + ] + else + tclTHENLIST[ + 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}) + ] + end -let hyp_terminates nb_args func = - let a_arrow_b = arg_type (constr_of_global func) in +let equation_info = + {message = "prove_equation with term "; + letiN = (fun _ -> assert false); + lambdA = (fun _ _ _ _ -> assert false); + casE = equation_case; + otherS = equation_others; + apP = equation_app; + app_reC = equation_app_rec +} + +let prove_eq = travel equation_info + +(* wrappers *) +(* [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 _,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, Array.of_list (lift 5 a_arrow_b:: mkRel 3:: constr_of_global func::mkRel 1:: - List.rev (list_map_i (fun i _ -> mkRel (6+i)) 0 rev_args) + List.rev (List.map_i (fun i _ -> mkRel (6+i)) 0 rev_args) ) ) in @@ -744,18 +1023,12 @@ let hyp_terminates nb_args func = delayed_force nat, (mkProd (Name k_id, delayed_force nat, mkArrow cond result))))|])in - let value = mkApp(delayed_force coq_sig, + let value = mkApp(constr_of_global (delayed_force coq_sig_ref), [|b; (mkLambda (Name v_id, b, nb_iter))|]) in compose_prod rev_args value - -let tclUSER_if_not_mes concl_tac is_mes names_to_suppress = - if is_mes - then tclCOMPLETE (h_simplest_apply (delayed_force well_founded_ltof)) - else tclUSER concl_tac is_mes names_to_suppress - let termination_proof_header is_mes input_type ids args_id relation rec_arg_num rec_arg_id tac wf_tac : tactic = begin @@ -763,14 +1036,14 @@ let termination_proof_header is_mes input_type ids args_id relation let nargs = List.length args_id in let pre_rec_args = List.rev_map - mkVar (fst (list_chop (rec_arg_num - 1) args_id)) + mkVar (fst (List.chop (rec_arg_num - 1) args_id)) in let relation = substl pre_rec_args relation in let input_type = substl pre_rec_args input_type in - let wf_thm = next_ident_away_in_goal (id_of_string ("wf_R")) ids in + let wf_thm = next_ident_away_in_goal (Id.of_string ("wf_R")) ids in let wf_rec_arg = next_ident_away_in_goal - (id_of_string ("Acc_"^(string_of_id rec_arg_id))) + (Id.of_string ("Acc_"^(Id.to_string rec_arg_id))) (wf_thm::ids) in let hrec = next_ident_away_in_goal hrec_id @@ -787,46 +1060,46 @@ let termination_proof_header is_mes input_type ids args_id relation (h_intros args_id) (tclTHENS (observe_tac - "first assert" - (assert_tac + (str "first assert") + (Proofview.V82.of_tactic (assert_before (Name wf_rec_arg) (mkApp (delayed_force acc_rel, [|input_type;relation;mkVar rec_arg_id|]) ) - ) + )) ) [ (* accesibility proof *) tclTHENS (observe_tac - "second assert" - (assert_tac + (str "second assert") + (Proofview.V82.of_tactic (assert_before (Name wf_thm) (mkApp (delayed_force well_founded,[|input_type;relation|])) - ) + )) ) [ (* interactive proof that the relation is well_founded *) - observe_tac "wf_tac" (wf_tac is_mes (Some args_id)); + observe_tac (str "wf_tac") (wf_tac is_mes (Some args_id)); (* this gives the accessibility argument *) observe_tac - "apply wf_thm" - (h_simplest_apply (mkApp(mkVar wf_thm,[|mkVar rec_arg_id|])) + (str "apply wf_thm") + (Proofview.V82.of_tactic (Simple.apply (mkApp(mkVar wf_thm,[|mkVar rec_arg_id|]))) ) ] ; (* rest of the proof *) - tclTHENSEQ - [observe_tac "generalize" + tclTHENLIST + [observe_tac (str "generalize") (onNLastHypsId (nargs+1) (tclMAP (fun id -> - tclTHEN (h_generalize [mkVar id]) (h_clear false [id])) + tclTHEN (Tactics.Simple.generalize [mkVar id]) (clear [id])) )) ; - observe_tac "h_fix" (h_fix (Some hrec) (nargs+1)); + observe_tac (str "fix") (fix (Some hrec) (nargs+1)); h_intros args_id; - h_intro wf_rec_arg; - observe_tac "tac" (tac wf_rec_arg hrec acc_inv) + Proofview.V82.of_tactic (Simple.intro wf_rec_arg); + observe_tac (str "tac") (tac wf_rec_arg hrec wf_rec_arg acc_inv) ] ] ) g @@ -838,10 +1111,8 @@ let rec instantiate_lambda t l = match l with | [] -> t | a::l -> - let (bound_name, _, body) = destLambda t in + let (_, _, body) = destLambda t in instantiate_lambda (subst1 a body) l -;; - let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_arg_num : tactic = begin @@ -852,7 +1123,7 @@ let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_a let f_id = match f_name with | Name f_id -> next_ident_away_in_goal f_id ids - | Anonymous -> anomaly "Anonymous function" + | Anonymous -> anomaly (Pp.str "Anonymous function") in let n_names_types,_ = decompose_lam_n nb_args body1 in let n_ids,ids = @@ -862,7 +1133,7 @@ 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 "anonymous argument" + | _ -> anomaly (Pp.str "anonymous argument") ) ([],(f_id::ids)) n_names_types @@ -877,20 +1148,28 @@ let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_a relation rec_arg_num rec_arg_id - (fun rec_arg_id hrec acc_inv g -> - (proveterminate - nb_args - [rec_arg_id] - is_mes - acc_inv - hrec - (mkVar f_id) - func - base_leaf_terminate - (rec_leaf_terminate nb_args (mkVar f_id) concl_tac) - [] - expr - ) + (fun rec_arg_id hrec acc_id acc_inv g -> + (prove_terminate (fun infos -> tclIDTAC) + { is_main_branch = true; (* we are on the main branche (i.e. still on a match ... with .... end *) + is_final = true; (* and on leaf (more or less) *) + f_terminate = delayed_force coq_O; + nb_arg = nb_args; + concl_tac = concl_tac; + rec_arg_id = rec_arg_id; + is_mes = is_mes; + ih = hrec; + f_id = f_id; + f_constr = mkVar f_id; + func = func; + info = expr; + acc_inv = acc_inv; + acc_id = acc_id; + values_and_bounds = []; + eqs = []; + forbidden_ids = []; + args_assoc = [] + } + ) g ) (tclUSER_if_not_mes concl_tac) @@ -900,7 +1179,7 @@ let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_a let get_current_subgoals_types () = let p = Proof_global.give_me_the_proof () in let { Evd.it=sgs ; sigma=sigma } = Proof.V82.subgoals p in - List.map (Goal.V82.abstract_type sigma) sgs + sigma, List.map (Goal.V82.abstract_type sigma) sgs let build_and_l l = let and_constr = Coqlib.build_coq_and () in @@ -913,7 +1192,8 @@ let build_and_l l = | App(_,_) -> let (f,_) = decompose_app t in eq_constr f (well_founded ()) - | _ -> false + | _ -> + false in let compare t1 t2 = let b1,b2= is_well_founded t1,is_well_founded t2 in @@ -928,7 +1208,7 @@ let build_and_l l = let c,tac,nb = f pl in mk_and p1 c, tclTHENS - (apply (constr_of_global conj_constr)) + (Proofview.V82.of_tactic (apply (constr_of_global conj_constr))) [tclIDTAC; tac ],nb+1 @@ -936,12 +1216,12 @@ let build_and_l l = let is_rec_res id = - let rec_res_name = string_of_id rec_res_id in - let id_name = string_of_id id in + let rec_res_name = Id.to_string rec_res_id in + let id_name = Id.to_string id in try - String.sub id_name 0 (String.length rec_res_name) = rec_res_name - with e when Errors.noncritical e -> false - + String.equal (String.sub id_name 0 (String.length rec_res_name)) rec_res_name + with Invalid_argument _ -> false + let clear_goals = let rec clear_goal t = match kind_of_term t with @@ -957,12 +1237,12 @@ let clear_goals = let build_new_goal_type () = - let sub_gls_types = get_current_subgoals_types () in + let sigma, sub_gls_types = get_current_subgoals_types () in (* Pp.msgnl (str "sub_gls_types1 := " ++ Util.prlist_with_sep (fun () -> Pp.fnl () ++ Pp.fnl ()) Printer.pr_lconstr sub_gls_types); *) let sub_gls_types = clear_goals sub_gls_types in - (* Pp.msgnl (str "sub_gls_types2 := " ++ Util.prlist_with_sep (fun () -> Pp.fnl () ++ Pp.fnl ()) Printer.pr_lconstr sub_gls_types); *) + (* Pp.msgnl (str "sub_gls_types2 := " ++ Pp.prlist_with_sep (fun () -> Pp.fnl () ++ Pp.fnl ()) Printer.pr_lconstr sub_gls_types); *) let res = build_and_l sub_gls_types in - res + sigma, res let is_opaque_constant c = let cb = Global.lookup_constant c in @@ -971,48 +1251,47 @@ let is_opaque_constant c = | Declarations.Undef _ -> true | Declarations.Def _ -> false -let open_new_goal (build_proof:tactic -> tactic -> unit) using_lemmas ref_ goal_name (gls_type,decompose_and_tac,nb_goal) = +let open_new_goal build_proof 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 name = match goal_name with | Some s -> s | None -> - try (add_suffix current_proof_name "_subproof") + try add_suffix current_proof_name "_subproof" with e when Errors.noncritical e -> - anomaly "open_new_goal with an unamed theorem" + anomaly (Pp.str "open_new_goal with an unamed theorem") in - let sign = initialize_named_context_for_proof () in let na = next_global_ident_away name [] in if Termops.occur_existential gls_type then - Util.error "\"abstract\" cannot handle existentials"; + Errors.error "\"abstract\" cannot handle existentials"; let hook _ _ = let opacity = - let na_ref = Libnames.Ident (dummy_loc,na) in - let na_global = Nametab.global na_ref in + let na_ref = Libnames.Ident (Loc.ghost,na) in + let na_global = Smartlocate.global_with_alias na_ref in match na_global with ConstRef c -> is_opaque_constant c - | _ -> anomaly "equation_lemma: not a constant" + | _ -> anomaly ~label:"equation_lemma" (Pp.str "not a constant") in - let lemma = mkConst (Lib.make_con na) in + let lemma = mkConst (Names.Constant.make1 (Lib.make_kn na)) in ref_ := Some lemma ; let lid = ref [] in let h_num = ref (-1) in - Flags.silently Vernacentries.interp (Vernacexpr.VernacAbort None); - build_proof + Proof_global.discard_all (); + build_proof Evd.empty ( fun gls -> let hid = next_ident_away_in_goal h_id (pf_ids_of_hyps gls) in - tclTHENSEQ + tclTHENLIST [ - h_generalize [lemma]; - h_intro hid; + Simple.generalize [lemma]; + Proofview.V82.of_tactic (Simple.intro hid); (fun g -> let ids = pf_ids_of_hyps g in tclTHEN - (Elim.h_decompose_and (mkVar hid)) + (Proofview.V82.of_tactic (Elim.h_decompose_and (mkVar hid))) (fun g -> let ids' = pf_ids_of_hyps g in - lid := List.rev (list_subtract ids' ids); - if !lid = [] then lid := [hid]; + lid := List.rev (List.subtract Id.equal ids' ids); + if List.is_empty !lid then lid := [hid]; tclIDTAC g ) g @@ -1021,40 +1300,39 @@ let open_new_goal (build_proof:tactic -> tactic -> unit) using_lemmas ref_ goal_ (fun g -> match kind_of_term (pf_concl g) with | App(f,_) when eq_constr f (well_founded ()) -> - Auto.h_auto None [] (Some []) g + Proofview.V82.of_tactic (Auto.h_auto None [] (Some [])) g | _ -> incr h_num; - (observe_tac "finishing using" + (observe_tac (str "finishing using") ( tclCOMPLETE( tclFIRST[ tclTHEN - (eapply_with_bindings (mkVar (List.nth !lid !h_num), NoBindings)) + (Proofview.V82.of_tactic (eapply_with_bindings (mkVar (List.nth !lid !h_num), NoBindings))) e_assumption; Eauto.eauto_with_bases (true,5) - [Evd.empty,delayed_force refl_equal] - [Auto.Hint_db.empty empty_transparent_state false] + [Evd.empty,Lazy.force refl_equal] + [Hints.Hint_db.empty empty_transparent_state false] ] ) ) ) g) ; - Lemmas.save_named opacity; + Lemmas.save_proof (Vernacexpr.Proved(opacity,None)); in - start_proof + Lemmas.start_proof na - (Decl_kinds.Global, Decl_kinds.Proof Decl_kinds.Lemma) - sign - gls_type - hook ; + (Decl_kinds.Global, false (* FIXME *), Decl_kinds.Proof Decl_kinds.Lemma) + sigma gls_type + (Lemmas.mk_hook hook); if Indfun_common.is_strict_tcc () then - by (tclIDTAC) + ignore (by (Proofview.V82.tactic (tclIDTAC))) else begin - by ( + ignore (by (Proofview.V82.tactic begin fun g -> tclTHEN (decompose_and_tac) @@ -1062,23 +1340,21 @@ let open_new_goal (build_proof:tactic -> tactic -> unit) using_lemmas ref_ goal_ (tclFIRST (List.map (fun c -> - tclTHENSEQ + Proofview.V82.of_tactic (Tacticals.New.tclTHENLIST [intros; - h_simplest_apply (interp_constr Evd.empty (Global.env()) c); - tclCOMPLETE Auto.default_auto - ] + Simple.apply (fst (interp_constr (Global.env()) Evd.empty c)) (*FIXME*); + Tacticals.New.tclCOMPLETE Auto.default_auto + ]) ) using_lemmas) ) tclIDTAC) - g) + g end)) end; try - by tclIDTAC; (* raises UserError _ if the proof is complete *) - if Flags.is_verbose () then (pp (Printer.pr_open_subgoals())) + ignore (by (Proofview.V82.tactic tclIDTAC)); (* raises UserError _ if the proof is complete *) with UserError _ -> defined () -;; let com_terminate @@ -1090,25 +1366,28 @@ let com_terminate relation rec_arg_num thm_name using_lemmas - nb_args + nb_args ctx hook = - let start_proof (tac_start:tactic) (tac_end:tactic) = + let start_proof ctx (tac_start:tactic) (tac_end:tactic) = let (evmap, env) = Lemmas.get_current_context() in - start_proof thm_name - (Global, Proof Lemma) (Environ.named_context_val env) - (hyp_terminates nb_args fonctional_ref) hook; + 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; - by (observe_tac "starting_tac" tac_start); - by (observe_tac "whole_start" (whole_start tac_end nb_args is_mes fonctional_ref - input_type relation rec_arg_num )) + ignore (by (Proofview.V82.tactic (observe_tac (str "starting_tac") tac_start))); + ignore (by (Proofview.V82.tactic (observe_tac (str "whole_start") (whole_start tac_end nb_args is_mes fonctional_ref + input_type relation rec_arg_num )))) in - start_proof tclIDTAC tclIDTAC; + start_proof ctx tclIDTAC tclIDTAC; try - let new_goal_type = build_new_goal_type () in - open_new_goal start_proof using_lemmas tcc_lemma_ref + let sigma, new_goal_type = build_new_goal_type () in + let sigma = + Evd.from_env ~ctx:(Evd.evar_universe_context sigma) Environ.empty_env + in + open_new_goal start_proof sigma + using_lemmas tcc_lemma_ref (Some tcc_lemma_name) (new_goal_type); - with Failure "empty list of subgoals!" -> (* a non recursive function declared with measure ! *) defined () @@ -1116,301 +1395,87 @@ let com_terminate -let ind_of_ref = function - | IndRef (ind,i) -> (ind,i) - | _ -> anomaly "IndRef expected" - -let (value_f:constr list -> global_reference -> constr) = - fun al fterm -> - let d0 = dummy_loc in - let rev_x_id_l = - ( - List.fold_left - (fun x_id_l _ -> - let x_id = next_ident_away_in_goal x_id x_id_l in - x_id::x_id_l - ) - [] - al - ) - in - let context = List.map - (fun (x, c) -> Name x, None, c) (List.combine rev_x_id_l (List.rev al)) - in - let env = Environ.push_rel_context context (Global.env ()) in - let glob_body = - GCases - (d0,RegularStyle,None, - [GApp(d0, GRef(d0,fterm), List.rev_map (fun x_id -> GVar(d0, x_id)) rev_x_id_l), - (Anonymous,None)], - [d0, [v_id], [PatCstr(d0,(ind_of_ref - (delayed_force coq_sig_ref),1), - [PatVar(d0, Name v_id); - PatVar(d0, Anonymous)], - Anonymous)], - GVar(d0,v_id)]) - in - let body = understand Evd.empty env glob_body in - it_mkLambda_or_LetIn body context - -let (declare_fun : identifier -> logical_kind -> constr -> global_reference) = - fun f_id kind value -> - let ce = {const_entry_body = value; - const_entry_secctx = None; - const_entry_type = None; - const_entry_opaque = false } in - ConstRef(declare_constant f_id (DefinitionEntry ce, kind));; - -let (declare_f : identifier -> logical_kind -> constr list -> global_reference -> global_reference) = - fun f_id kind input_type fterm_ref -> - declare_fun f_id kind (value_f input_type fterm_ref);; - -let rec n_x_id ids n = - if n = 0 then [] - else let x = next_ident_away_in_goal x_id ids in - x::n_x_id (x::ids) (n-1);; let start_equation (f:global_reference) (term_f:global_reference) - (cont_tactic:identifier list -> tactic) g = + (cont_tactic:Id.t list -> tactic) g = let ids = pf_ids_of_hyps g in let terminate_constr = constr_of_global term_f in - let nargs = nb_prod (type_of_const terminate_constr) in + let nargs = nb_prod (fst (type_of_const terminate_constr)) (*FIXME*) in let x = n_x_id ids nargs in tclTHENLIST [ h_intros x; - unfold_in_concl [(Termops.all_occurrences, evaluable_of_global_reference f)]; - observe_tac "simplest_case" - (simplest_case (mkApp (terminate_constr, - Array.of_list (List.map mkVar x)))); - observe_tac "prove_eq" (cont_tactic x)] g;; - -let base_leaf_eq func eqs f_id g = - let ids = pf_ids_of_hyps g in - let k = next_ident_away_in_goal k_id ids in - let p = next_ident_away_in_goal p_id (k::ids) in - let v = next_ident_away_in_goal v_id (p::k::ids) in - let heq = next_ident_away_in_goal heq_id (v::p::k::ids) in - let heq1 = next_ident_away_in_goal heq_id (heq::v::p::k::ids) in - let hex = next_ident_away_in_goal hex_id (heq1::heq::v::p::k::ids) in - tclTHENLIST [ - h_intros [v; hex]; - simplest_elim (mkVar hex); - h_intros [p;heq1]; - tclTRY - (rewriteRL - (mkApp(mkVar heq1, - [|mkApp (delayed_force coq_S, [|mkVar p|]); - mkApp(delayed_force lt_n_Sn, [|mkVar p|]); f_id|]))); - simpl_iter onConcl; - tclTRY (unfold_in_concl [((true,[1]), evaluable_of_global_reference func)]); - observe_tac "list_revrite" (list_rewrite true eqs); - apply (delayed_force refl_equal)] g;; - -let f_S t = mkApp(delayed_force coq_S, [|t|]);; + unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference f)]; + observe_tac (str "simplest_case") + (Proofview.V82.of_tactic (simplest_case (mkApp (terminate_constr, + Array.of_list (List.map mkVar x))))); + observe_tac (str "prove_eq") (cont_tactic x)] g;; - -let rec introduce_all_values_eq cont_tac functional termine - f p heq1 pmax bounds le_proofs eqs ids = - function - [] -> - let heq2 = next_ident_away_in_goal heq_id ids in - tclTHENLIST - [pose_proof (Name heq2) - (mkApp(mkVar heq1, [|f_S(f_S(mkVar pmax))|])); - simpl_iter (onHyp heq2); - unfold_in_hyp [((true,[1]), evaluable_of_global_reference - (global_of_constr functional))] - (heq2, Termops.InHyp); - tclTHENS - (fun gls -> - let t_eq = compute_renamed_type gls (mkVar heq2) in - let def_id = - let _,_,t = destProd t_eq in let def_na,_,_ = destProd t in - Nameops.out_name def_na - in - observe_tac "rewrite heq" (general_rewrite_bindings false Termops.all_occurrences - true (* dep proofs also: *) true (mkVar heq2, - ExplicitBindings[dummy_loc,NamedHyp def_id, - f]) false) gls) - [tclTHENLIST - [observe_tac "list_rewrite" (list_rewrite true eqs); - cont_tac pmax le_proofs]; - tclTHENLIST[apply (delayed_force le_lt_SS); - compute_le_proofs le_proofs]]] - | arg::args -> - let v' = next_ident_away_in_goal v_id ids in - let ids = v'::ids in - let hex' = next_ident_away_in_goal hex_id ids in - let ids = hex'::ids in - let p' = next_ident_away_in_goal p_id ids in - let ids = p'::ids in - let new_pmax = next_ident_away_in_goal pmax_id ids in - let ids = pmax::ids in - let hle1 = next_ident_away_in_goal hle_id ids in - let ids = hle1::ids in - let hle2 = next_ident_away_in_goal hle_id ids in - let ids = hle2::ids in - let heq = next_ident_away_in_goal heq_id ids in - let ids = heq::ids in - let heq2 = next_ident_away_in_goal heq_id ids in - let ids = heq2::ids in - tclTHENLIST - [mkCaseEq(mkApp(termine, Array.of_list arg)); - h_intros [v'; hex']; - simplest_elim(mkVar hex'); - h_intros [p']; - simplest_elim(mkApp(delayed_force max_constr, [|mkVar pmax; - mkVar p'|])); - h_intros [new_pmax;hle1;hle2]; - introduce_all_values_eq - (fun pmax' le_proofs'-> - tclTHENLIST - [cont_tac pmax' le_proofs'; - h_intros [heq;heq2]; - observe_tac ("rewriteRL " ^ (string_of_id heq2)) - (tclTRY (rewriteLR (mkVar heq2))); - tclTRY (tclTHENS - ( fun g -> - let t_eq = compute_renamed_type g (mkVar heq) in - let k_id,def_id = - 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 - in - let c_b = (mkVar heq, - ExplicitBindings - [dummy_loc, NamedHyp k_id, - f_S(mkVar pmax'); - dummy_loc, NamedHyp def_id, f]) - in - observe_tac "general_rewrite_bindings" ( (general_rewrite_bindings false Termops.all_occurrences true (* dep proofs also: *) true - c_b false)) - g - ) - [tclIDTAC; - tclTHENLIST - [apply (delayed_force le_lt_n_Sm); - compute_le_proofs le_proofs']])]) - functional termine f p heq1 new_pmax - (p'::bounds)((mkVar pmax)::le_proofs) eqs - (heq2::heq::hle2::hle1::new_pmax::p'::hex'::v'::ids) args] - - -let rec_leaf_eq termine f ids functional eqs expr fn args = - let p = next_ident_away_in_goal p_id ids in - let ids = p::ids in - let v = next_ident_away_in_goal v_id ids in - let ids = v::ids in - let hex = next_ident_away_in_goal hex_id ids in - let ids = hex::ids in - let heq1 = next_ident_away_in_goal heq_id ids in - let ids = heq1::ids in - let hle1 = next_ident_away_in_goal hle_id ids in - let ids = hle1::ids in - tclTHENLIST - [observe_tac "intros v hex" (h_intros [v;hex]); - simplest_elim (mkVar hex); - h_intros [p;heq1]; - h_generalize [mkApp(delayed_force le_n,[|mkVar p|])]; - h_intros [hle1]; - observe_tac "introduce_all_values_eq" (introduce_all_values_eq - (fun _ _ -> tclIDTAC) - functional termine f p heq1 p [] [] eqs ids args); - observe_tac "failing here" (apply (delayed_force refl_equal))] - -let rec prove_eq nb_arg (termine:constr) (f:constr)(functional:global_reference) - (eqs:constr list) (expr:constr) = -(* tclTRY *) - observe_tac "prove_eq" (match kind_of_term expr with - Case(ci,t,a,l) -> - (match find_call_occs nb_arg 0 f a with - _,[] -> - (fun g -> - let destruct_tac,rev_to_thin_intro = mkDestructEq [] a g in - tclTHENS - destruct_tac - (list_map_i - (fun i -> mk_intros_and_continue - (List.rev rev_to_thin_intro) true - (prove_eq nb_arg termine f functional) - eqs ci.ci_cstr_ndecls.(i)) - 0 (Array.to_list l)) g) - | _,_::_ -> - (match find_call_occs nb_arg 0 f expr with - _,[] -> observe_tac "base_leaf_eq(1)" (base_leaf_eq functional eqs f) - | fn,args -> - fun g -> - let ids = Termops.ids_of_named_context (pf_hyps g) in - observe_tac "rec_leaf_eq" (rec_leaf_eq termine f ids - (constr_of_global functional) - eqs expr fn args) g)) - | _ -> - (match find_call_occs nb_arg 0 f expr with - _,[] -> observe_tac "base_leaf_eq(2)" ( base_leaf_eq functional eqs f) - | fn,args -> - fun g -> - let ids = Termops.ids_of_named_context (pf_hyps g) in - observe_tac "rec_leaf_eq" (rec_leaf_eq - termine f ids (constr_of_global functional) - eqs expr fn args) g));; - -let (com_eqn : int -> identifier -> +let (com_eqn : int -> Id.t -> global_reference -> global_reference -> global_reference -> constr -> unit) = fun nb_arg eq_name functional_ref f_ref terminate_ref equation_lemma_type -> let opacity = match terminate_ref with | ConstRef c -> is_opaque_constant c - | _ -> anomaly "terminate_lemma: not a constant" + | _ -> anomaly ~label:"terminate_lemma" (Pp.str "not a constant") in let (evmap, env) = Lemmas.get_current_context() in - let f_constr = (constr_of_global f_ref) in + let evmap = + Evd.from_env ~ctx:(Evd.evar_universe_context evmap) Environ.empty_env + in + let f_constr = constr_of_global f_ref in let equation_lemma_type = subst1 f_constr equation_lemma_type in - (start_proof eq_name (Global, Proof Lemma) - (Environ.named_context_val env) equation_lemma_type (fun _ _ -> ()); - by - (start_equation f_ref terminate_ref + (Lemmas.start_proof eq_name (Global, false, Proof Lemma) + ~sign:(Environ.named_context_val env) + evmap + equation_lemma_type + (Lemmas.mk_hook (fun _ _ -> ())); + ignore (by + (Proofview.V82.tactic (start_equation f_ref terminate_ref (fun x -> - prove_eq nb_arg - (constr_of_global terminate_ref) - f_constr - functional_ref - [] - (instantiate_lambda - (def_of_const (constr_of_global functional_ref)) - (f_constr::List.map mkVar x) - ) + prove_eq (fun _ -> tclIDTAC) + {nb_arg=nb_arg; + f_terminate = constr_of_global terminate_ref; + f_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) + ); + is_main_branch = true; + is_final = true; + values_and_bounds = []; + eqs = []; + forbidden_ids = []; + acc_inv = lazy (assert false); + acc_id = Id.of_string "____"; + args_assoc = []; + f_id = Id.of_string "______"; + rec_arg_id = Id.of_string "______"; + is_mes = false; + ih = Id.of_string "______"; + } ) - ); -(* (try Vernacentries.interp (Vernacexpr.VernacShow Vernacexpr.ShowProof) with _ -> ()); *) + ))); + (* (try Vernacentries.interp (Vernacexpr.VernacShow Vernacexpr.ShowProof) with _ -> ()); *) (* Vernacentries.interp (Vernacexpr.VernacShow Vernacexpr.ShowScript); *) - Flags.silently (fun () -> Lemmas.save_named opacity) () ; + Flags.silently (fun () -> Lemmas.save_proof (Vernacexpr.Proved(opacity,None))) () ; (* Pp.msgnl (str "eqn finished"); *) - );; -let nf_zeta env = - Reductionops.clos_norm_flags (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA]) - env - Evd.empty - -let nf_betaiotazeta = (* Reductionops.local_strong Reductionops.whd_betaiotazeta *) - let clos_norm_flags flgs env sigma t = - Closure.norm_val (Closure.create_clos_infos flgs env) (Closure.inject (Reductionops.nf_evar sigma t)) in - clos_norm_flags Closure.betaiotazeta Environ.empty_env Evd.empty - let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num eq generate_induction_principle using_lemmas : unit = - let previous_label = Lib.current_command_label () in - let function_type = interp_constr Evd.empty (Global.env()) type_of_f in - let env = push_named (function_name,None,function_type) (Global.env()) in + let env = Global.env() in + let evd = ref (Evd.from_env env) in + let function_type = interp_type_evars env evd type_of_f in + let env = push_named (function_name,None,function_type) env in (* Pp.msgnl (str "function type := " ++ Printer.pr_lconstr function_type); *) - let equation_lemma_type = - nf_betaiotazeta - (interp_gen (OfType None) Evd.empty env ~impls:rec_impls eq) - in + 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 function_type = nf function_type in (* Pp.msgnl (str "lemma type := " ++ Printer.pr_lconstr equation_lemma_type ++ fnl ()); *) let res_vars,eq' = decompose_prod equation_lemma_type in let env_eq' = Environ.push_rel_context (List.map (fun (x,y) -> (x,None,y)) res_vars) env in @@ -1430,35 +1495,35 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num let equation_id = add_suffix function_name "_equation" in let functional_id = add_suffix function_name "_F" in let term_id = add_suffix function_name "_terminate" in - let functional_ref = declare_fun functional_id (IsDefinition Decl_kinds.Definition) res in + let functional_ref = declare_fun functional_id (IsDefinition Decl_kinds.Definition) ~ctx:(Evd.universe_context evm) res in let env_with_pre_rec_args = push_rel_context(List.map (function (x,t) -> (x,None,t)) pre_rec_args) env in let relation = - interp_constr - Evd.empty + fst (*FIXME*)(interp_constr env_with_pre_rec_args - r + Evd.empty + r) in let tcc_lemma_name = add_suffix function_name "_tcc" in let tcc_lemma_constr = ref None in (* let _ = Pp.msgnl (str "relation := " ++ Printer.pr_lconstr_env env_with_pre_rec_args relation) in *) - let hook _ _ = + 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 _ = Table.extraction_inline true [Ident (dummy_loc,term_id)] in -(* message "start second proof"; *) - let stop = ref false in - begin - try com_eqn (List.length res_vars) equation_id functional_ref f_ref term_ref (subst_var function_name equation_lemma_type) + let _ = Table.extraction_inline true [Ident (Loc.ghost,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); + false with e when Errors.noncritical e -> begin - if Tacinterp.get_debug () <> Tactic_debug.DebugOff - then pperrnl (str "Cannot create equation Lemma " ++ Errors.print e) - else anomaly "Cannot create equation Lemma" + if do_observe () + then msg_debug (str "Cannot create equation Lemma " ++ Errors.print e) + else anomaly (Pp.str "Cannot create equation Lemma") ; - stop := true; + true end - end; - if not !stop + in + if not stop then let eq_ref = Nametab.locate (qualid_of_ident equation_id ) in let f_ref = destConst (constr_of_global f_ref) @@ -1471,9 +1536,9 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num spc () ++ str"is defined" )++ fnl () ++ h 1 (Ppconstr.pr_id equation_id ++ spc () ++ str"is defined" ) - ) + ) in - try + States.with_state_protection_on_exception (fun () -> com_terminate tcc_lemma_name tcc_lemma_constr @@ -1483,11 +1548,5 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num term_id using_lemmas (List.length res_vars) - hook - with reraise -> - begin - (try ignore (Backtrack.backto previous_label) - with e when Errors.noncritical e -> ()); - (* anomaly "Cannot create termination Lemma" *) - raise reraise - end + evm (Lemmas.mk_hook hook)) + () diff --git a/plugins/funind/recdef.mli b/plugins/funind/recdef.mli new file mode 100644 index 00000000..f60eedbe --- /dev/null +++ b/plugins/funind/recdef.mli @@ -0,0 +1,20 @@ + + +(* val evaluable_of_global_reference : Libnames.global_reference -> Names.evaluable_global_reference *) +val tclUSER_if_not_mes : + Proof_type.tactic -> + bool -> + Names.Id.t list option -> + Proof_type.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 + + -- cgit v1.2.3