For example, I would like a tactic that would iterate over all the resolve hints in a given HintDb and for each resolve hint h, it would do a pose h. . Is this possible? If so, how?
In Coq, there is not (unless you do fancy things with shelve and backtracking), but it is pretty straightforward in OCaml. For example, in the Fiat project, we have such tactics. For Coq 8.7:
In hint_db_extra_tactics.ml:
module WITH_DB =
struct
open Tacticals.New
open Names
open Ltac_plugin
(* [tac] : string representing identifier *)
(* [args] : tactic arguments *)
(* [ltac_lcall] : Build a tactic expression calling a variable let-bound to a tactic == [F] args *)
let ltac_lcall tac args =
Tacexpr.TacArg(Loc.tag ## Tacexpr.TacCall(Loc.tag ## (Misctypes.ArgVar(Loc.tag ## Names.Id.of_string tac),args)))
(* [ltac_letin] : Build a let tactic expression. let x := e1 in e2 *)
let ltac_letin (x, e1) e2 =
Tacexpr.TacLetIn(false,[(Loc.tag ## Names.Id.of_string x),e1],e2)
(* [ltac_apply] : Run a tactic with arguments... *)
let ltac_apply (f: Tacinterp.Value.t) (arg:Tacinterp.Value.t) =
let open Geninterp in
let ist = Tacinterp.default_ist () in
let id = Id.of_string "X" in
let idf = Id.of_string "F" in
let ist = { ist with Tacinterp.lfun = Id.Map.add idf f (Id.Map.add id arg ist.lfun) } in
let arg = Tacexpr.Reference (Misctypes.ArgVar (Loc.tag id)) in
Tacinterp.eval_tactic_ist ist
(ltac_lcall "F" [arg])
(* Lift a constructor to an ltac value. *)
let to_ltac_val c = Tacinterp.Value.of_constr c
let with_hint_db dbs tacK =
let open Proofview.Notations in
(* [dbs] : list of hint databases *)
(* [tacK] : tactic to run on a hint *)
Proofview.Goal.nf_enter begin
fun gl ->
let syms = ref [] in
let _ =
List.iter (fun l ->
(* Fetch the searchtable from the database*)
let db = Hints.searchtable_map l in
(* iterate over the hint database, pulling the hint *)
(* list out for each. *)
Hints.Hint_db.iter (fun _ _ hintlist ->
syms := hintlist::!syms) db) dbs in
(* Now iterate over the list of list of hints, *)
List.fold_left
(fun tac hints ->
List.fold_left
(fun tac (hint : Hints.full_hint) ->
let hint1 = hint.Hints.code in
Hints.run_hint hint1
(fun hint2 ->
(* match the type of the hint to pull out the lemma *)
match hint2 with
Hints.Give_exact ((lem, _, _) , _)
| Hints.Res_pf ((lem, _, _) , _)
| Hints.ERes_pf ((lem, _, _) , _) ->
let this_tac = ltac_apply tacK (Tacinterp.Value.of_constr lem) in
tclORELSE this_tac tac
| _ -> tac))
tac hints)
(tclFAIL 0 (Pp.str "No applicable tactic!")) !syms
end
let add_resolve_to_db lem db =
let open Proofview.Notations in
Proofview.Goal.nf_enter begin
fun gl ->
let _ = Hints.add_hints true db (Hints.HintsResolveEntry [({ Vernacexpr.hint_priority = Some 1 ; Vernacexpr.hint_pattern = None },false,true,Hints.PathAny,lem)]) in
tclIDTAC
end
end
In hint_db_extra_plugin.ml4:
open Hint_db_extra_tactics
open Stdarg
open Ltac_plugin
open Tacarg
DECLARE PLUGIN "hint_db_extra_plugin"
TACTIC EXTEND foreach_db
| [ "foreach" "[" ne_preident_list(l) "]" "run" tactic(k) ] ->
[ WITH_DB.with_hint_db l k ]
END
TACTIC EXTEND addto_db
| [ "add" constr(name) "to" ne_preident_list(l) ] ->
[ WITH_DB.add_resolve_to_db (Hints.IsConstr (name, Univ.ContextSet.empty)) l]
END;;
In hint_db_extra_plugin.mllib:
Hint_db_extra_tactics
Hint_db_extra_plugin
In HintDbExtra.v:
Declare ML Module "hint_db_extra_plugin".
Using this to solve the example posed in the problem statement, we can add:
In _CoqProject:
-R . Example
-I .
HintDbExtra.v
PoseDb.v
hint_db_extra_plugin.ml4
hint_db_extra_plugin.mllib
hint_db_extra_tactics.ml
In PoseDb.v:
Require Import HintDbExtra.
Ltac unique_pose v :=
lazymatch goal with
| [ H := v |- _ ] => fail
| _ => pose v
end.
Goal True.
repeat foreach [ core ] run unique_pose.
If you want to run a tactic on each hint in the hint database (rather than running a tactic on each hint in succession, until you find one that succeeds), you can change the tclORELSE in with_hint_db to some sort of sequencing operator (e.g., tclTHEN).
Related
I am trying to test simple conjecture with QuickChick:
Conjecture lists_eq : forall (l : list string), l = l.
QuickChick lists_eq.
but I get this error:
Unable to satisfy the following constraints:
?arg_2 : "Checkable (forall l : list string, l = l)"
I know I need to make my property Instance of class Checkable, but how should I do it?
I made decidability on two lists (successfully)
Instance EqLists_Dec (x y : list string) : Dec (x = y).
I made Arbitrary for list (successfully)
Instance gen_list_string : Gen (list string)
But I couldn't make Property checkable, I know that bool type is Checkable in QC.
Here is the code, plese advice. Maybe I am doing it all in a wrong way.
From QuickChick Require Import QuickChick.
Require Import List ZArith. Import ListNotations.
Import QcNotation.
Set Warnings "-extraction-opaque-accessed,-extraction".
Require Import String. Local Open Scope string.
Definition genListString : G (list string) :=
elems_ ["Two" ; "Three"]
[
[ "One" ; "Nstasss" ; "SomeStr" ; "Yellow" ];
[ "111" ; "2222" ; "33333SomeStr" ; "44444Yellow" ]
].
(* Sample genListString. *)
Instance gen_list_string : Gen (list string) :=
{
arbitrary := genListString
}.
Notation "P '?'" :=
(match (#dec P _) with
| left _ => true
| right _ => false
end)
(at level 100).
Instance EqLists_Dec (x y : list string) : Dec (x = y).
Proof. dec_eq. Defined.
(* Problem in this function, couldn't make it work*)
Instance checkableDec `{P : Prop} `{Dec P} : Checkable P :=
{
checker p := if P? then ret ok else ret Failure
}.
Conjecture lists_eq : forall (l : list string), l = l.
QuickChick lists_eq.
(*
Unable to satisfy the following constraints:
?arg_2 : "Checkable (forall l : list string, l = l)"
*)
checkableDec already exists in QuickChick. You are actually missing a Shrink instance:
Instance Shrink_string : Shrink string :=
{| shrink x := [] |}.
To debug this you can Set Typeclasses Debug and then look at where the trace says no match for .... You have to be careful of false positives because there is backtracking, but with persistence and experience you'll get the hang of it.
I find a pattern inside my goal through a tactic.
Why does this fail:
Tactic Notation "my_context_match" uconstr(g) :=
match goal with
| |- context[g] => idtac
end.
my_context_match _.
While this succeeds?
match goal with
| |- context[_] => idtac
end.
Is there any way to write a my_context_match, such that I can pass incomplete patterns (with _ on them) and see if anything inside my goal matches the patter?
Support for uconstr is very patchy. I've just reported #9321. Note that even this fails:
Goal True.
let v := uconstr:(True) in
lazymatch constr:(v) with
| v => idtac
end. (* Error: No matching clauses for match. *)
As suggested by #eponier in a comment, you can use open_constr instead of uconstr. However, this will leave unresolved evars. Here is a tactic that will work, and will not leave unresolved evars:
Tactic Notation "my_context_match" uconstr(g) :=
(* [match] does not support [uconstr], cf COQBUG(https://github.com/coq/coq/issues/9321),
so we use [open_constr] *)
let g := open_constr:(g) in
(* turning [g] into an [open_constr] creates new evars, so we must
eventually unify them with the goal *)
let G := match goal with |- ?G => G end in
(* We now search for [g] in the goal, and then replace the matching
subterm with the [open_constr] [g], so that we can unify the
result with the goal [G] to resolve the new evars we created *)
match G with
| context cG[g]
=> let G' := context cG[g] in
unify G G'
end.
Goal True /\ True.
my_context_match _.
my_context_match (_ /\ _).
Fail my_context_match (_ \/ _).
my_context_match True.
exact (conj I I).
Qed.
I was trying to define a function using Program Fixpoint, which uses another (anonymous) recursive function in its body. I tried using Admit Obligationsfor the moment, to see if something else made sense but I get an error.
This is a simple example that shows the same error (maybe there is a simpler one...).
Require Import List.
Import ListNotations.
Require Import Program.
Section Test.
Inductive FType : Type :=
| Base : RType -> FType
| Cons : RType -> FType -> FType
with RType : Type :=
| Empty : RType
| Nested : nat -> FType -> RType
| NestedList : nat -> list FType -> RType.
Variable ftype_size : FType -> nat.
Program Fixpoint failing (ft : FType) {measure (ftype_size ft)} : FType :=
match ft with
| Base _ => ft
| Cons hd tl =>
match hd with
| NestedList l rs =>
let fix loop (rs : list FType) (i : nat) : list FType :=
match rs with
| [] => []
| r' :: rs' => (failing r') :: (loop rs' (i + 1))
end
in
Base (NestedList l (loop rs 0))
| _ => ft
end
end.
Admit Obligations.
End Test.
So, when running this it says Recursive call to loop has not enough arguments.. I was wondering why is this happening? Is it somehow related to this issue?
Also, if I define an indexed map and repeat this, I don't get any error.
Section Map.
Variables (T1 T2 : Type) (f : nat -> T1 -> T2).
Definition indexed_map (s : list T1) :=
let fix imap s index : list T2 :=
match s with
| [] => []
| hd :: tl => (f index hd) :: imap tl (index + 1)
end
in
imap s 0.
End Map.
Arguments indexed_map [T1 T2].
Program Fixpoint failing (ft : FType) {measure (ftype_size ft)} : FType :=
match ft with
| Base _ => ft
| Cons hd tl =>
match hd with
| NestedList l rs => Base (NestedList l (indexed_map (fun i r' => (failing r')) rs))
| _ => ft
end
end.
Admit Obligations.
I can probably define it in a different way but I was still wondering why is this happening.
Reading the error message further, notice that loop occurs twice in the printed function. The second occurence is the one you wrote, but the first (the problematic one) is an argument to an axiom generated by Admit Obligations.
Recursive call to loop has not enough arguments.
Recursive definition is:
"fun (rs0 : list FType) (i : nat) =>
let program_branch_0 := fun _ : [] = rs0 => [] in
let program_branch_1 :=
fun (r' : FType) (rs' : list FType) (Heq_rs : r' :: rs' = rs0) =>
failing r'
(failing_obligation_1 ft failing hd tl Heq_ft l rs Heq_hd loop
rs0 i r' rs' Heq_rs) :: loop rs' (i + 1) in
match rs0 as rs' return (rs' = rs0 -> list FType) with
| [] => program_branch_0
| r' :: rs' => program_branch_1 r' rs'
end eq_refl".
To avoid that, you can step through the corresponding obligation manually and put your own axiom that doesn't depend on loop.
Parameter TODO : forall {A : Prop}, A.
Program Fixpoint failing ... (* Your definition *)
Next Obligation.
apply TODO.
Qed.
(* Now the rest can still be Admitted. *)
Admit Obligations.
Is there a way to use recursion with Coq's typeclasses? Like for e.g., in defining show for lists, if you want to call the show function for lists recursively, then you will have to use a fixpoint like so:
Require Import Strings.String.
Require Import Strings.Ascii.
Local Open Scope string_scope.
Class Show (A : Type) : Type :=
{
show : A -> string
}.
Section showNormal.
Instance showList {A : Type} `{Show A} : Show (list A) :=
{
show :=
fix lshow l :=
match l with
| nil => "[]"
| x :: xs => show x ++ " : " ++ lshow xs
end
}.
End showNormal.
Which is all well and good, but what if I want to define some helper function that I'll use for defining Show instances? Like I want to create a more DAZZLING show function called magicShow that prints stars around something...
Definition magicShow {A : Type} `{Show A} (a : A) : string :=
"** " ++ show a ++ " **".
Instance showMagicList {A : Type} `{Show A} : Show (list A) :=
{
show :=
fix lshow l :=
match l with
| nil => "[]"
| x :: xs => show x ++ " : " ++ magicShow xs
end
}.
However, in this case Coq can't find a show instance for the list xs to pass to magicShow:
Error:
Unable to satisfy the following constraints:
In environment:
A : Type
H : Show A
lshow : list A -> string
l : list A
x : A
xs : list A
?H : "Show (list A)"
Is there any way to do this in general? I.e., can you define a method for a typeclass using functions that rely upon the typeclass instance that you're defining?
No, there's no way to do this. This works in Haskell because arbitrary recursive bindings are allowed, and the language doesn't care about the order of bindings. Coq is more restrictive on both fronts. This makes sense if you think about what the desugaring looks like: the recursive call to show would refer to the currently-being-defined instance by name, but that binding isn't in scope yet. And you can't make the instance itself a fixpoint because you're recursing on the structure of a type, not on a value of an algebraic data type.
Your inline fixpoint works for show, but the problem gets thornier if your method implementations refer to each other, such as
newtype MyInteger = MyInteger Integer
instance Num MyInteger where
MyInteger m + MyInteger n = MyInteger $ m + n
negate (MyInteger m) = MyInteger $ negate m
m - n = m + negate n
-- other methods
Here, the calls to (+) and negate in the definition of (-) needs to refer to the definitions of (+) and negate above, but this also doesn't work in Coq. The only solution is to define all your methods separately, manually referencing each other, and then define the instance simply by setting each method to the one you defined above. For example,
Inductive MyInteger := Mk_MyInteger : Integer -> MyInteger.
Definition add__MyInteger (m n : MyInteger) : MyInteger :=
let 'Mk_MyInteger m' := m in
let 'Mk_MyInteger n' := n in
Mk_MyInteger (add m' n').
Definition negate__MyInteger (m : MyInteger) : MyInteger :=
let 'Mk_MyInteger m' := m in
Mk_MyInteger (negate m').
Definition sub__MyInteger (m n : MyInteger) : MyInteger :=
add__MyInteger m (negate__MyInteger n).
Instance Num__MyInteger : Num MyInteger := {|
add := add__MyInteger;
negate := negate__MyInteger;
sub := sub__MyInteger;
(* other methods *)
|}.
If you must do this, it can be simulated by explicitly using the constructor of the underlying Record (since "Typeclasses are Records", to quote from Software Foundations [1]), which can be instantiated using the function(s) being defined as a fixpoint. I'll post three examples and explain where this can be useful.
The example you posted could be solved like this (all code tested for Coq 8.10.1):
Require Import Strings.String.
Local Open Scope list_scope.
Local Open Scope string_scope.
Class Show (A : Type) : Type :=
{
show : A -> string
}.
Definition magicShow {A : Type} `{Show A} (a : A) : string :=
"** " ++ show a ++ " **".
Print Show.
(* Record Show (A : Type) : Type := Build_Show { show : A -> string }
*)
Check Build_Show.
(* Build_Show : forall A : Type, (A -> string) -> Show A *)
Check #magicShow.
(* #magicShow : forall A : Type, Show A -> A -> string *)
Instance showMagicList {A : Type} `{Show A} : Show (list A) :=
{
show :=
fix lshow l :=
match l with
| nil => "[]"
| x :: xs => show x ++ " : " ++ #magicShow _ (#Build_Show _ lshow) xs
end
}.
If you are trying to define several typeclass methods like this, it's tricky to instantiate the record constructor, but it can be done by treating the functions as if they were defined by mutual recursion (although there doesn't necessarily have to be any actual mutual recursion). Here's a contrived example where Show now has two methods. Notice that the typeclass instance is added to the context with an anonymous let-in binding. Evidently, this is enough to satisfy Coq's typeclass resolution mechanism.
Require Import Strings.String.
Local Open Scope list_scope.
Local Open Scope string_scope.
Class Show (A : Type) : Type :=
{
show1 : A -> string
; show2 : A -> string
}.
Definition magicShow1 {A : Type} `{Show A} (a : A) : string :=
"** " ++ show1 a ++ " **".
Definition magicShow2 {A : Type} `{Show A} (a : A) : string :=
"** " ++ show2 a ++ " **".
Fixpoint show1__list {A : Type} `{Show A} (l : list A) : string :=
let _ := (#Build_Show _ show1__list show2__list) in
match l with
| nil => "[]"
| x :: xs => show1 x ++ " : " ++ magicShow1 xs
end
with show2__list {A : Type} `{Show A} (l : list A) : string :=
let _ := (#Build_Show _ show1__list show2__list) in
match l with
| nil => "[]"
| x :: xs => show1 x ++ " : " ++ magicShow2 xs
end.
Instance showMagicList {A : Type} `{Show A} : Show (list A) :=
{
show1 := show1__list
; show2 := show2__list
}.
So why would you want to do this? A good example is when you are defining decidable equality on (rose) trees. In the middle of the definition, we have to recursively appeal to decidable equality of list (tree A). We would like to use the standard library helper function Coq.Classes.EquivDec.list_eqdec [2], which shows how to pass decidable equality on a type A to list A. Since list_eqdec requires a typeclass instance (the very one we are in the middle of defining), we have to use the same trick above:
Require Import Coq.Classes.EquivDec.
Require Import Coq.Program.Utils.
Set Implicit Arguments.
Generalizable Variables A.
Inductive tree (A : Type) : Type :=
| leaf : A -> tree A
| node : list (tree A) -> tree A.
Program Instance tree_eqdec `(eqa : EqDec A eq) : EqDec (tree A) eq :=
{ equiv_dec := fix tequiv t1 t2 :=
let _ := list_eqdec tequiv in
match t1, t2 with
| leaf a1, leaf a2 =>
if a1 == a2 then in_left else in_right
| node ts1, node ts2 =>
if ts1 == ts2 then in_left else in_right
| _, _ => in_right
end
}.
Solve Obligations with unfold not, equiv, complement in * ;
program_simpl ; intuition (discriminate || eauto).
Next Obligation.
destruct t1;
destruct t2;
( program_simpl || unfold complement, not, equiv in *; eauto ).
Qed.
Solve Obligations with split; (intros; try unfold complement, equiv ; program_simpl).
(*
No more obligations remaining
tree_eqdec is defined
*)
Commentary: There is no constructor for creating a record of type EqDec (since it only has one class method), so to convince Coq that list (tree A) has decidable equality, the invocation is simply list_eqdec tequiv. For the uninitiated, Program here is simply allowing for holes in the definition of the instance to be filled in later as Obligations, which is more convenient than writing the appropriate proofs inline.
If I have the following:
H : some complicated expression = some other complicated expression
and I want to grab
u := some other complicated expression
without hardcoding it into my proof (i.e., using pose)
Is there a clean way to do this in LTac?
I am sure there are other ltac ways to do it, in my case I prefer to use SSReflect's contextual pattern language to do it. (You'll need to install the plugin or use Coq >= 8.7 which includes SSReflect):
(* ce_i = complicated expression i *)
Lemma example T (ce_1 ce_2 : T) (H : ce_1 = ce_2) : False.
set u := (X in _ = X) in H.
resulting goal:
T : Type
ce_1, ce_2 : T
u := ce_2 : T
H : ce_1 = u
============================
False
Usually you can refine the pattern more and more until you get a pretty stable match.
Note that this happens to be the first example of the section 8.3 "Contextual patterns" in the SSReflect manual.
Here is another version, which uses Ltac and its ability to pattern-match on types of terms:
Tactic Notation "assign" "rhs" "of" ident(H) "to" ident(u) "in" ident(H') :=
match type of H with _ = ?rhs => set (u := rhs) in H' end.
Tactic Notation "assign" "rhs" "of" ident(H) "to" ident(u) "in" "*" :=
match type of H with _ = ?rhs => set (u := rhs) in * end.
We can create more variants of the above (see e.g. here). Here is how to use it:
Lemma example {T} (ce1 ce2 ce3 : T) (H1 : ce1 = ce2) (H2 : ce2 = ce3) : ce1 = ce3.
Proof.
assign rhs of H1 to u in *.
Proof state:
u := ce2 : T
H1 : ce1 = u
H2 : u = ce3
============================
ce1 = ce3
One more time:
Undo.
assign rhs of H1 to u in H1.
Proof state:
u := ce2 : T
H1 : ce1 = u
H2 : ce2 = ce3
============================
ce1 = ce3