diff options
Diffstat (limited to 'tactics')
| -rw-r--r-- | tactics/class_tactics.ml | 11 | ||||
| -rw-r--r-- | tactics/equality.ml | 13 | ||||
| -rw-r--r-- | tactics/tacticals.ml | 13 | ||||
| -rw-r--r-- | tactics/tacticals.mli | 1 | ||||
| -rw-r--r-- | tactics/tactics.ml | 29 |
5 files changed, 53 insertions, 14 deletions
diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index 0abfd342d2..a85afcbf09 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -498,7 +498,16 @@ let catchable = function | Refiner.FailError _ -> true | e -> Logic.catchable_exception e -let pr_depth l = prlist_with_sep (fun () -> str ".") int (List.rev l) +(* alternate separators in debug search path output *) +let debug_seps = [| "." ; "-" |] +let next_sep seps = + let num_seps = Array.length seps in + let sep_index = ref 0 in + fun () -> + let sep = seps.(!sep_index) in + sep_index := (!sep_index + 1) mod num_seps; + str sep +let pr_depth l = prlist_with_sep (next_sep debug_seps) int (List.rev l) let is_Prop env sigma concl = let ty = Retyping.get_type_of env sigma concl in diff --git a/tactics/equality.ml b/tactics/equality.ml index a0d2da863d..d44dcf10df 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -725,7 +725,7 @@ let find_positions env sigma t1 t2 = let hd1,args1 = whd_all_stack env sigma t1 in let hd2,args2 = whd_all_stack env sigma t2 in match (kind_of_term hd1, kind_of_term hd2) with - | Construct (sp1,_), Construct (sp2,_) + | Construct ((ind1,i1 as sp1),u1), Construct (sp2,_) when Int.equal (List.length args1) (constructor_nallargs_env env sp1) -> let sorts' = @@ -734,11 +734,14 @@ let find_positions env sigma t1 t2 = (* both sides are fully applied constructors, so either we descend, or we can discriminate here. *) if eq_constructor sp1 sp2 then - let nrealargs = constructor_nrealargs_env env sp1 in - let rargs1 = List.lastn nrealargs args1 in - let rargs2 = List.lastn nrealargs args2 in + let nparams = inductive_nparams_env env ind1 in + let params1,rargs1 = List.chop nparams args1 in + let _,rargs2 = List.chop nparams args2 in + let (mib,mip) = lookup_mind_specif env ind1 in + let ctxt = (get_constructor ((ind1,u1),mib,mip,params1) i1).cs_args in + let adjust i = Vars.adjust_rel_to_rel_context ctxt (i+1) - 1 in List.flatten - (List.map2_i (fun i -> findrec sorts' ((sp1,i)::posn)) + (List.map2_i (fun i -> findrec sorts' ((sp1,adjust i)::posn)) 0 rargs1 rargs2) else if Sorts.List.mem InType sorts' then (* see build_discriminator *) diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index 93c04e373c..c5562b326c 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -368,6 +368,16 @@ module New = struct catch_failerror e <*> t2 end end + + let tclORELSE0L t1 t2 = + tclINDEPENDENTL begin + tclORELSE + t1 + begin fun e -> + catch_failerror e <*> t2 + end + end + let tclORELSE t1 t2 = tclORELSE0 (tclPROGRESS t1) t2 @@ -419,6 +429,9 @@ module New = struct let tclTRY t = tclORELSE0 t (tclUNIT ()) + + let tclTRYb t = + tclORELSE0L (t <*> tclUNIT true) (tclUNIT false) let tclIFTHENELSE t1 t2 t3 = tclINDEPENDENT begin diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli index 18cf03c51d..7aacc52f33 100644 --- a/tactics/tacticals.mli +++ b/tactics/tacticals.mli @@ -209,6 +209,7 @@ module New : sig val tclMAP : ('a -> unit tactic) -> 'a list -> unit tactic val tclTRY : unit tactic -> unit tactic + val tclTRYb : unit tactic -> bool list tactic val tclFIRST : unit tactic list -> unit tactic val tclIFTHENELSE : unit tactic -> unit tactic -> unit tactic -> unit tactic val tclIFTHENSVELSE : unit tactic -> unit tactic array -> unit tactic -> unit tactic diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 6205bd1092..84d09d8330 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -1815,24 +1815,37 @@ let find_matching_clause unifier clause = with NotExtensibleClause -> failwith "Cannot apply" in find clause +exception UnableToApply + let progress_with_clause flags innerclause clause = let ordered_metas = List.rev (clenv_independent clause) in - if List.is_empty ordered_metas then error "Statement without assumptions."; + if List.is_empty ordered_metas then raise UnableToApply; let f mv = try Some (find_matching_clause (clenv_fchain ~with_univs:false mv ~flags clause) innerclause) with Failure _ -> None in try List.find_map f ordered_metas - with Not_found -> error "Unable to unify." + with Not_found -> raise UnableToApply + +let explain_unable_to_apply_lemma loc env sigma thm innerclause = + user_err ~loc (hov 0 + (Pp.str "Unable to apply lemma of type" ++ brk(1,1) ++ + Pp.quote (Printer.pr_lconstr_env env sigma thm) ++ spc() ++ + str "on hypothesis of type" ++ brk(1,1) ++ + Pp.quote (Printer.pr_lconstr_env innerclause.env innerclause.evd (clenv_type innerclause)) ++ + str ".")) -let apply_in_once_main flags innerclause env sigma (d,lbind) = +let apply_in_once_main flags innerclause env sigma (loc,d,lbind) = let thm = nf_betaiota sigma (Retyping.get_type_of env sigma d) in let rec aux clause = try progress_with_clause flags innerclause clause with e when CErrors.noncritical e -> - let e = CErrors.push e in + let e' = CErrors.push e in try aux (clenv_push_prod clause) - with NotExtensibleClause -> iraise e + with NotExtensibleClause -> + match e with + | UnableToApply -> explain_unable_to_apply_lemma loc env sigma thm innerclause + | _ -> iraise e' in aux (make_clenv_binding env sigma (d,thm) lbind) @@ -1852,7 +1865,7 @@ let apply_in_once sidecond_first with_delta with_destruct with_evars naming let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in try - let clause = apply_in_once_main flags innerclause env sigma (c,lbind) in + let clause = apply_in_once_main flags innerclause env sigma (loc,c,lbind) in clenv_refine_in ~sidecond_first with_evars targetid id sigma clause (fun id -> Tacticals.New.tclTHENLIST [ @@ -2467,7 +2480,7 @@ and intro_pattern_action loc with_evars b style pat thin destopt tac id = intro_decomp_eq loc l' thin tac id | IntroRewrite l2r -> rewrite_hyp_then style with_evars thin l2r id (fun thin -> tac thin None []) - | IntroApplyOn (f,(loc,pat)) -> + | IntroApplyOn ((loc',f),(loc,pat)) -> let naming,tac_ipat = prepare_intros_loc loc with_evars (IntroIdentifier id) destopt pat in let doclear = @@ -2479,7 +2492,7 @@ and intro_pattern_action loc with_evars b style pat thin destopt tac id = let Sigma (c, sigma, p) = f.delayed env sigma in Sigma ((c, NoBindings), sigma, p) } in - apply_in_delayed_once false true true with_evars naming id (None,(loc,f)) + apply_in_delayed_once false true true with_evars naming id (None,(loc',f)) (fun id -> Tacticals.New.tclTHENLIST [doclear; tac_ipat id; tac thin None []]) and prepare_intros_loc loc with_evars dft destopt = function |