diff options
Diffstat (limited to 'tactics')
| -rw-r--r-- | tactics/btermdn.ml | 2 | ||||
| -rw-r--r-- | tactics/btermdn.mli | 1 | ||||
| -rw-r--r-- | tactics/class_tactics.ml | 13 | ||||
| -rw-r--r-- | tactics/dn.ml | 20 | ||||
| -rw-r--r-- | tactics/dn.mli | 2 | ||||
| -rw-r--r-- | tactics/equality.ml | 8 | ||||
| -rw-r--r-- | tactics/hints.ml | 134 | ||||
| -rw-r--r-- | tactics/hints.mli | 11 | ||||
| -rw-r--r-- | tactics/inv.ml | 14 |
9 files changed, 90 insertions, 115 deletions
diff --git a/tactics/btermdn.ml b/tactics/btermdn.ml index bacb5a7b8f..f721e9956b 100644 --- a/tactics/btermdn.ml +++ b/tactics/btermdn.ml @@ -186,7 +186,5 @@ struct (fun dn t -> Dn.lookup dn (bounded_constr_val_discr_st env sigma st) (t,!dnet_depth)) - let app f dn = Dn.app f dn - end diff --git a/tactics/btermdn.mli b/tactics/btermdn.mli index ab201a1872..01d68a8045 100644 --- a/tactics/btermdn.mli +++ b/tactics/btermdn.mli @@ -38,7 +38,6 @@ sig val rmv : t -> pattern -> Z.t -> t val lookup : Environ.env -> Evd.evar_map -> TransparentState.t option -> t -> EConstr.constr -> Z.t list - val app : (Z.t -> unit) -> t -> unit end val dnet_depth : int ref diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index 96cbbf0ba8..b4d7e7d7f0 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -158,7 +158,7 @@ let unify_resolve ~with_evars flags h diff = match diff with | None -> Hints.hint_res_pf ~with_evars ~with_classes:false ~flags h | Some (diff, ty) -> - let () = assert (not h.hint_poly) in + let () = assert (Option.is_empty h.hint_uctx) in Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in @@ -203,11 +203,10 @@ let unify_resolve_refine flags h diff = let with_prods nprods h f = if get_typeclasses_limit_intros () then Proofview.Goal.enter begin fun gl -> - let { hint_term = c; hint_poly = poly } = h in - if poly || Int.equal nprods 0 then f None + if Option.has_some h.hint_uctx || Int.equal nprods 0 then f None else let sigma = Tacmach.New.project gl in - let ty = Retyping.get_type_of (Proofview.Goal.env gl) sigma c in + let ty = Retyping.get_type_of (Proofview.Goal.env gl) sigma h.hint_term in let diff = nb_prod sigma ty - nprods in if (>=) diff 0 then f (Some (diff, ty)) else Tacticals.New.tclZEROMSG (str"Not enough premisses") @@ -489,12 +488,12 @@ let make_resolve_hyp env sigma st only_classes pri decl = let hints = build_subclasses ~check:false env sigma id empty_hint_info in (List.map_append (fun (path,info,c) -> - let h = IsConstr (EConstr.of_constr c,Univ.ContextSet.empty) [@ocaml.warning "-3"] in - make_resolves env sigma ~name:(PathHints path) info ~check:true ~poly:false h) + let h = IsConstr (EConstr.of_constr c, None) [@ocaml.warning "-3"] in + make_resolves env sigma ~name:(PathHints path) info ~check:true h) hints) else [] in - (hints @ make_resolves env sigma pri ~name ~check:false ~poly:false (IsGlobRef id)) + (hints @ make_resolves env sigma pri ~name ~check:false (IsGlobRef id)) else [] let make_hints g (modes,st) only_classes sign = diff --git a/tactics/dn.ml b/tactics/dn.ml index 07eb49442a..c587f91e54 100644 --- a/tactics/dn.ml +++ b/tactics/dn.ml @@ -62,10 +62,10 @@ prefix ordering, [dna] is the function returning the main node of a pattern *) pathrec [] let tm_of tm lbl = - try [Trie.next tm lbl, true] with Not_found -> [] + try [Trie.next tm lbl] with Not_found -> [] let rec skip_arg n tm = - if Int.equal n 0 then [tm, true] + if Int.equal n 0 then [tm] else let labels = Trie.labels tm in let map lbl = match lbl with @@ -73,23 +73,19 @@ prefix ordering, [dna] is the function returning the main node of a pattern *) | Some (_, m) -> skip_arg (pred n + m) (Trie.next tm lbl) in - List.flatten (List.map map labels) + List.map_append map labels let lookup tm dna t = let rec lookrec t tm = match dna t with | Nothing -> tm_of tm None | Label(lbl,v) -> - tm_of tm None@ - (List.fold_left - (fun l c -> - List.flatten(List.map (fun (tm, b) -> - if b then lookrec c tm - else [tm,b]) l)) - (tm_of tm (Some(lbl,List.length v))) v) + let fold accu c = List.map_append (fun tm -> lookrec c tm) accu in + tm_of tm None @ + (List.fold_left fold (tm_of tm (Some (lbl, List.length v))) v) | Everything -> skip_arg 1 tm in - List.flatten (List.map (fun (tm,b) -> ZSet.elements (Trie.get tm)) (lookrec t tm)) + List.map_append (fun tm -> ZSet.elements (Trie.get tm)) (lookrec t tm) let pattern dna pat = path_of dna pat @@ -99,7 +95,5 @@ prefix ordering, [dna] is the function returning the main node of a pattern *) let rmv tm p inf = Trie.remove p (ZSet.singleton inf) tm - let app f tm = Trie.iter (fun _ p -> ZSet.iter f p) tm - end diff --git a/tactics/dn.mli b/tactics/dn.mli index 287aa2b257..85f9ef6dfb 100644 --- a/tactics/dn.mli +++ b/tactics/dn.mli @@ -38,6 +38,4 @@ sig val lookup : t -> 'term lookup_fun -> 'term -> Z.t list - val app : (Z.t -> unit) -> t -> unit - end diff --git a/tactics/equality.ml b/tactics/equality.ml index 8478c1957a..60e2db4dce 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -659,8 +659,12 @@ let replace_using_leibniz clause c1 c2 l2r unsafe try_prove_eq_opt = | None -> tclFAIL 0 (str"Terms do not have convertible types") | Some evd -> - let e = lib_ref "core.eq.type" in - let sym = lib_ref "core.eq.sym" in + let e,sym = + try lib_ref "core.eq.type", lib_ref "core.eq.sym" + with UserError _ -> + try lib_ref "core.identity.type", lib_ref "core.identity.sym" + with UserError _ -> + user_err (strbrk "Need a registration for either core.eq.type and core.eq.sym or core.identity.type and core.identity.sym.") in Tacticals.New.pf_constr_of_global sym >>= fun sym -> Tacticals.New.pf_constr_of_global e >>= fun e -> let eq = applist (e, [t1;c1;c2]) in diff --git a/tactics/hints.ml b/tactics/hints.ml index 355cea8fa8..fe3efef7c5 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -129,22 +129,20 @@ type hints_path = GlobRef.t hints_path_gen type hint_term = | IsGlobRef of GlobRef.t - | IsConstr of constr * Univ.ContextSet.t + | IsConstr of constr * Univ.ContextSet.t option (* None if monomorphic *) type 'a with_uid = { obj : 'a; uid : KerName.t; } -type raw_hint = constr * types * Univ.ContextSet.t * bool (* poly *) +type raw_hint = constr * types * Univ.ContextSet.t option type hint = { hint_term : constr; hint_type : types; - hint_uctx : Univ.ContextSet.t; + hint_uctx : Univ.ContextSet.t option; (* None if monomorphic *) hint_clnv : clausenv; - hint_poly : bool; - (** Is the hint polymorpic and hence should be refreshed at each application *) } type 'a with_metadata = @@ -334,15 +332,19 @@ let strip_params env sigma c = | _ -> c) | _ -> c +let merge_context_set_opt sigma ctx = match ctx with +| None -> sigma +| Some ctx -> Evd.merge_context_set Evd.univ_flexible sigma ctx + let instantiate_hint env sigma p = - let mk_clenv (c, cty, ctx, poly) = - let sigma = Evd.merge_context_set univ_flexible sigma ctx in + let mk_clenv (c, cty, ctx) = + let sigma = merge_context_set_opt sigma ctx in let cl = mk_clenv_from_env env sigma None (c,cty) in let cl = {cl with templval = { cl.templval with rebus = strip_params env sigma cl.templval.rebus }; env = empty_env} in - { hint_term = c; hint_type = cty; hint_uctx = ctx; hint_clnv = cl; hint_poly = poly } + { hint_term = c; hint_type = cty; hint_uctx = ctx; hint_clnv = cl; } in let code = match p.code.obj with | Res_pf c -> Res_pf (mk_clenv c) @@ -816,7 +818,7 @@ let secvars_of_constr env sigma c = let secvars_of_global env gr = secvars_of_idset (vars_of_global env gr) -let make_exact_entry env sigma info ~poly ?(name=PathAny) (c, cty, ctx) = +let make_exact_entry env sigma info ?(name=PathAny) (c, cty, ctx) = let secvars = secvars_of_constr env sigma c in let cty = strip_outer_cast sigma cty in match EConstr.kind sigma cty with @@ -835,13 +837,13 @@ let make_exact_entry env sigma info ~poly ?(name=PathAny) (c, cty, ctx) = (Some hd, { pri; pat = Some pat; name; db = None; secvars; - code = with_uid (Give_exact (c, cty, ctx, poly)); }) + code = with_uid (Give_exact (c, cty, ctx)); }) -let make_apply_entry env sigma hnf info ~poly ?(name=PathAny) (c, cty, ctx) = +let make_apply_entry env sigma hnf info ?(name=PathAny) (c, cty, ctx) = let cty = if hnf then hnf_constr env sigma cty else cty in match EConstr.kind sigma cty with | Prod _ -> - let sigma' = Evd.merge_context_set univ_flexible sigma ctx in + let sigma' = merge_context_set_opt sigma ctx in let ce = mk_clenv_from_env env sigma' None (c,cty) in let c' = clenv_type (* ~reduce:false *) ce in let hd = @@ -861,49 +863,27 @@ let make_apply_entry env sigma hnf info ~poly ?(name=PathAny) (c, cty, ctx) = { pri; pat = Some pat; name; db = None; secvars; - code = with_uid (Res_pf(c,cty,ctx,poly)); }) + code = with_uid (Res_pf(c,cty,ctx)); }) else (Some hd, { pri; pat = Some pat; name; db = None; secvars; - code = with_uid (ERes_pf(c,cty,ctx,poly)); }) + code = with_uid (ERes_pf(c,cty,ctx)); }) | _ -> failwith "make_apply_entry" (* flags is (e,h,v) with e=true if eapply and h=true if hnf and v=true if verbose c is a constr cty is the type of constr *) -let pr_hint_term env sigma ctx = function - | IsGlobRef gr -> pr_global gr - | IsConstr (c, ctx) -> - let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx in - pr_econstr_env env sigma c - -let warn_polymorphic_hint = - CWarnings.create ~name:"polymorphic-hint" ~category:"automation" - (fun hint -> strbrk"Using polymorphic hint " ++ hint ++ - str" monomorphically" ++ - strbrk" use Polymorphic Hint to use it polymorphically.") - -let fresh_global_or_constr env sigma poly cr = - let isgr, (c, ctx) = - match cr with - | IsGlobRef gr -> - let (c, ctx) = UnivGen.fresh_global_instance env gr in - true, (EConstr.of_constr c, ctx) - | IsConstr (c, ctx) -> false, (c, ctx) - in - if poly then (c, ctx) - else if Univ.ContextSet.is_empty ctx then (c, ctx) - else begin - if isgr then - warn_polymorphic_hint (pr_hint_term env sigma ctx cr); - DeclareUctx.declare_universe_context ~poly:false ctx; - (c, Univ.ContextSet.empty) - end - -let make_resolves env sigma (eapply, hnf) info ~check ~poly ?name cr = - let c, ctx = fresh_global_or_constr env sigma poly cr in +let fresh_global_or_constr env sigma cr = match cr with +| IsGlobRef gr -> + let (c, ctx) = UnivGen.fresh_global_instance env gr in + let ctx = if Environ.is_polymorphic env gr then Some ctx else None in + (EConstr.of_constr c, ctx) +| IsConstr (c, ctx) -> (c, ctx) + +let make_resolves env sigma (eapply, hnf) info ~check ?name cr = + let c, ctx = fresh_global_or_constr env sigma cr in let cty = Retyping.get_type_of env sigma c in let try_apply f = try @@ -914,8 +894,8 @@ let make_resolves env sigma (eapply, hnf) info ~check ~poly ?name cr = with Failure _ -> None in let ents = List.map_filter try_apply - [make_exact_entry env sigma info ~poly ?name; - make_apply_entry env sigma hnf info ~poly ?name] + [make_exact_entry env sigma info ?name; + make_apply_entry env sigma hnf info ?name] in if check && List.is_empty ents then user_err ~hdr:"Hint" @@ -929,9 +909,9 @@ let make_resolve_hyp env sigma decl = let hname = NamedDecl.get_id decl in let c = mkVar hname in try - [make_apply_entry env sigma true empty_hint_info ~poly:false + [make_apply_entry env sigma true empty_hint_info ~name:(PathHints [GlobRef.VarRef hname]) - (c, NamedDecl.get_type decl, Univ.ContextSet.empty)] + (c, NamedDecl.get_type decl, None)] with | Failure _ -> [] | e when noncritical e -> anomaly (Pp.str "make_resolve_hyp.") @@ -977,9 +957,9 @@ let make_mode ref m = str" arguments while the mode declares " ++ int (Array.length m')) else m' -let make_trivial env sigma poly ?(name=PathAny) r = - let c,ctx = fresh_global_or_constr env sigma poly r in - let sigma = Evd.merge_context_set univ_flexible sigma ctx in +let make_trivial env sigma ?(name=PathAny) r = + let c,ctx = fresh_global_or_constr env sigma r in + let sigma = merge_context_set_opt sigma ctx in let t = hnf_constr env sigma (Retyping.get_type_of env sigma c) in let hd = head_constr sigma t in let ce = mk_clenv_from_env env sigma None (c,t) in @@ -989,7 +969,7 @@ let make_trivial env sigma poly ?(name=PathAny) r = name = name; db = None; secvars = secvars_of_constr env sigma c; - code= with_uid (Res_pf_THEN_trivial_fail(c,t,ctx,poly)) }) + code= with_uid (Res_pf_THEN_trivial_fail(c,t,ctx)) }) @@ -1102,10 +1082,10 @@ let subst_autohint (subst, obj) = with Bound -> gr') in let subst_mps subst c = EConstr.of_constr (subst_mps subst (EConstr.Unsafe.to_constr c)) in - let subst_aux ((c, t, ctx, poly) as h) = + let subst_aux ((c, t, ctx) as h) = let c' = subst_mps subst c in let t' = subst_mps subst t in - if c==c' && t'==t then h else (c', t', ctx, poly) + if c==c' && t'==t then h else (c', t', ctx) in let subst_hint (k,data as hint) = let k' = Option.Smart.map subst_key k in @@ -1214,13 +1194,13 @@ let add_resolves env sigma clist ~local ~superglobal dbnames = List.iter (fun dbname -> let r = - List.flatten (List.map (fun (pri, poly, hnf, path, gr) -> + List.flatten (List.map (fun (pri, hnf, path, gr) -> make_resolves env sigma (true, hnf) - pri ~check:true ~poly ~name:path gr) clist) + pri ~check:true ~name:path gr) clist) in let check (_, hint) = match hint.code.obj with - | ERes_pf (c, cty, ctx, _) -> - let sigma' = Evd.merge_context_set univ_flexible sigma ctx in + | ERes_pf (c, cty, ctx) -> + let sigma' = merge_context_set_opt sigma ctx in let ce = mk_clenv_from_env env sigma' None (c,cty) in let miss = clenv_missing ce in let nmiss = List.length miss in @@ -1288,7 +1268,7 @@ let add_externs info tacast ~local ~superglobal dbnames = let add_trivials env sigma l ~local ~superglobal dbnames = List.iter (fun dbname -> - let l = List.map (fun (name, poly, c) -> make_trivial env sigma poly ~name c) l in + let l = List.map (fun (name, c) -> make_trivial env sigma ~name c) l in let hint = make_hint ~local dbname (AddHints { superglobal; hints = l }) in Lib.add_anonymous_leaf (inAutoHint hint)) dbnames @@ -1298,8 +1278,8 @@ type hnf = bool type nonrec hint_info = hint_info type hints_entry = - | HintsResolveEntry of (hint_info * bool * hnf * hints_path_atom * hint_term) list - | HintsImmediateEntry of (hints_path_atom * bool * hint_term) list + | HintsResolveEntry of (hint_info * hnf * hints_path_atom * hint_term) list + | HintsImmediateEntry of (hints_path_atom * hint_term) list | HintsCutEntry of hints_path | HintsUnfoldEntry of evaluable_global_reference list | HintsTransparencyEntry of evaluable_global_reference hints_transparency_target * bool @@ -1372,24 +1352,21 @@ let expand_constructor_hints env sigma lems = match EConstr.kind sigma lem with | Ind (ind,u) -> List.init (nconstructors env ind) - (fun i -> - let ctx = Univ.ContextSet.diff (Evd.universe_context_set evd) - (Evd.universe_context_set sigma) in - not (Univ.ContextSet.is_empty ctx), - IsConstr (mkConstructU ((ind,i+1),u),ctx)) + (fun i -> IsGlobRef (GlobRef.ConstructRef ((ind,i+1)))) | _ -> let (c, ctx) = prepare_hint false env sigma (evd,lem) in - [not (Univ.ContextSet.is_empty ctx), IsConstr (c, ctx)]) lems + let ctx = if Univ.ContextSet.is_empty ctx then None else Some ctx in + [IsConstr (c, ctx)]) lems (* builds a hint database from a constr signature *) (* typically used with (lid, ltyp) = pf_hyps_types <some goal> *) let constructor_hints env sigma eapply lems = let lems = expand_constructor_hints env sigma lems in - List.map_append (fun (poly, lem) -> - make_resolves env sigma (eapply, true) empty_hint_info ~check:true ~poly lem) lems + List.map_append (fun lem -> + make_resolves env sigma (eapply, true) empty_hint_info ~check:true lem) lems -let make_resolves env sigma info ~check ~poly ?name hint = - make_resolves env sigma (true, false) info ~check ~poly ?name hint +let make_resolves env sigma info ~check ?name hint = + make_resolves env sigma (true, false) info ~check ?name hint let make_local_hint_db env sigma ts eapply lems = let map c = c env sigma in @@ -1650,7 +1627,8 @@ let connect_hint_clenv h gl = let sigma = Tacmach.New.project gl in let evd = Evd.evars_reset_evd ~with_conv_pbs:true ~with_univs:false sigma clenv.evd in (* Still, we need to update the universes *) - if h.hint_poly then + match h.hint_uctx with + | Some ctx -> (* Refresh the instance of the hint *) let (subst, ctx) = UnivGen.fresh_universe_context_set_instance ctx in let emap c = Vars.subst_univs_level_constr subst c in @@ -1662,21 +1640,19 @@ let connect_hint_clenv h gl = evd = Evd.map_metas emap evd; env = Proofview.Goal.env gl; } - else - let evd = Evd.merge_context_set Evd.univ_flexible evd ctx in + | None -> { clenv with evd = evd ; env = Proofview.Goal.env gl } let fresh_hint env sigma h = let { hint_term = c; hint_uctx = ctx } = h in - if h.hint_poly then + match h.hint_uctx with + | None -> sigma, c + | Some ctx -> (* Refresh the instance of the hint *) let (subst, ctx) = UnivGen.fresh_universe_context_set_instance ctx in let c = Vars.subst_univs_level_constr subst c in let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx in sigma, c - else - let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx in - sigma, c let hint_res_pf ?with_evars ?with_classes ?flags h = Proofview.Goal.enter begin fun gl -> diff --git a/tactics/hints.mli b/tactics/hints.mli index e061bd7648..dd22cff10b 100644 --- a/tactics/hints.mli +++ b/tactics/hints.mli @@ -42,9 +42,8 @@ type 'a hint_ast = type hint = private { hint_term : constr; hint_type : types; - hint_uctx : Univ.ContextSet.t; + hint_uctx : Univ.ContextSet.t option; hint_clnv : clausenv; - hint_poly : bool; } type 'a hints_path_atom_gen = @@ -170,11 +169,11 @@ type hnf = bool type hint_term = | IsGlobRef of GlobRef.t - | IsConstr of constr * Univ.ContextSet.t [@ocaml.deprecated "Declare a hint constant instead"] + | IsConstr of constr * Univ.ContextSet.t option [@ocaml.deprecated "Declare a hint constant instead"] type hints_entry = - | HintsResolveEntry of (hint_info * bool * hnf * hints_path_atom * hint_term) list - | HintsImmediateEntry of (hints_path_atom * bool * hint_term) list + | HintsResolveEntry of (hint_info * hnf * hints_path_atom * hint_term) list + | HintsImmediateEntry of (hints_path_atom * hint_term) list | HintsCutEntry of hints_path | HintsUnfoldEntry of evaluable_global_reference list | HintsTransparencyEntry of evaluable_global_reference hints_transparency_target * bool @@ -211,7 +210,7 @@ val prepare_hint : bool (* Check no remaining evars *) -> has missing arguments. *) val make_resolves : - env -> evar_map -> hint_info -> check:bool -> poly:bool -> ?name:hints_path_atom -> + env -> evar_map -> hint_info -> check:bool -> ?name:hints_path_atom -> hint_term -> hint_entry list (** [make_resolve_hyp hname htyp]. diff --git a/tactics/inv.ml b/tactics/inv.ml index 41899132a6..498a4cfc26 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -116,7 +116,11 @@ let make_inv_predicate env evd indf realargs id status concl = (* Now, we can recurse down this list, for each ai,(mkRel k) whether to push <Ai>(mkRel k)=ai (when Ai is closed). In any case, we carry along the rest of pairs *) - let eqdata = Coqlib.build_coq_eq_data () in + let eqdata = + try Coqlib.build_coq_eq_data () + with UserError _ -> + try Coqlib.build_coq_identity_data () + with UserError _ -> user_err (str "No registered equality.") in let rec build_concl eqns args n = function | [] -> it_mkProd concl eqns, Array.rev_of_list args | ai :: restlist -> @@ -351,8 +355,12 @@ let remember_first_eq id x = if !x == Logic.MoveLast then x := Logic.MoveAfter i let dest_nf_eq env sigma t = match EConstr.kind sigma t with | App (r, [| t; x; y |]) -> let open Reductionops in - let eq = Coqlib.lib_ref "core.eq.type" in - if isRefX sigma eq r then + let is_global_exists gr c = + Coqlib.has_ref gr && isRefX sigma (Coqlib.lib_ref gr) c + in + let is_eq = is_global_exists "core.eq.type" r in + let is_identity = is_global_exists "core.identity.type" r in + if is_eq || is_identity then (t, whd_all env sigma x, whd_all env sigma y) else user_err Pp.(str "Not an equality.") | _ -> |
