54 lines
1.7 KiB
Text
54 lines
1.7 KiB
Text
/-
|
||
Copyright (c) 2016 Microsoft Corporation. All rights reserved.
|
||
Released under Apache 2.0 license as described in the file LICENSE.
|
||
Authors: Leonardo de Moura
|
||
-/
|
||
prelude
|
||
import init.meta.tactic init.function
|
||
|
||
namespace tactic
|
||
open nat tactic environment expr list
|
||
|
||
private meta def at_end₂ (e₁ e₂ : expr) : ℕ → tactic (list (option expr))
|
||
| 2 := return [some e₁, some e₂]
|
||
| (n+3) := at_end₂ (n+2) >>= (λ xs, return (none :: xs))
|
||
| _ := fail "at_end expected arity > 1"
|
||
|
||
private meta def mk_intro_name : name → list name → name
|
||
| n₁ (n₂ :: ns) := n₂
|
||
| n [] := if n = `a then `h else n
|
||
|
||
-- Auxiliary function for introducing the new equalities produced by the
|
||
-- injection tactic
|
||
private meta def injection_intro : expr → list name → tactic unit
|
||
| (pi n bi b d) ns := do
|
||
hname ← return $ mk_intro_name n ns,
|
||
h ← intro hname,
|
||
injection_intro d (tail ns)
|
||
|
||
| e ns := skip
|
||
|
||
meta def injection_with (h : expr) (ns : list name) : tactic unit :=
|
||
do
|
||
ht ← infer_type h,
|
||
(lhs, rhs) ← match_eq ht,
|
||
env ← get_env,
|
||
n_f ← return (const_name (get_app_fn lhs)),
|
||
n_inj ← return (n_f <.> "inj_arrow"),
|
||
if n_f = const_name (get_app_fn rhs) ∧ env~>contains n_inj
|
||
then do
|
||
c_inj ← mk_const n_inj,
|
||
arity ← get_arity c_inj,
|
||
tgt ← target,
|
||
args ← at_end₂ h tgt (arity - 1),
|
||
pr ← mk_mapp n_inj args,
|
||
pr_type ← infer_type pr,
|
||
pr_type ← whnf pr_type,
|
||
apply pr,
|
||
injection_intro (binding_domain pr_type) ns
|
||
else fail "injection tactic failed, argument must be an equality proof where lhs and rhs are of the form (c ...), where c is a constructor"
|
||
|
||
meta def injection (h : expr) : tactic unit :=
|
||
injection_with h []
|
||
|
||
end tactic
|