diff --git a/.gitignore b/.gitignore
index a8d712e50..c9d2ab4b9 100644
--- a/.gitignore
+++ b/.gitignore
@@ -46,4 +46,5 @@ META
*.cache
apps/coercion/src/coq_elpi_coercion_hook.ml
-.filestoinstall
\ No newline at end of file
+.filestoinstall
+apps/tc/src/coq_elpi_tc_hook.ml
diff --git a/Makefile b/Makefile
index 8adfefa18..8c91fd0ab 100644
--- a/Makefile
+++ b/Makefile
@@ -21,7 +21,7 @@ export ELPIDIR
DEPS=$(ELPIDIR)/elpi.cmxa $(ELPIDIR)/elpi.cma
-APPS=$(addprefix apps/, derive eltac NES locker coercion)
+APPS=$(addprefix apps/, derive eltac NES locker coercion tc)
ifeq "$(COQ_ELPI_ALREADY_INSTALLED)" ""
DOCDEP=build
diff --git a/_CoqProject b/_CoqProject
index 1e0d91b72..f6956fa6a 100644
--- a/_CoqProject
+++ b/_CoqProject
@@ -8,23 +8,42 @@
-Q tests elpi.tests
-Q elpi elpi
+# Derive
-R apps/derive/theories elpi.apps
-R apps/derive/tests elpi.apps.derive.tests
-R apps/derive/examples elpi.apps.derive.examples
+
+# NES
-R apps/NES/theories elpi.apps
-R apps/NES/tests elpi.apps.NES.tests
-R apps/NES/examples elpi.apps.NES.examples
+
+# Eltac
-R apps/eltac/theories elpi.apps.eltac
-R apps/eltac/tests elpi.apps.eltac.tests
-R apps/eltac/examples elpi.apps.eltac.examples
--R apps/coercion/theories elpi.apps.coercion
+# Coercion
+-R apps/coercion/theories elpi.apps.coercion
+-R apps/coercion/tests elpi.apps.tc.coercion
+-I apps/coercion/src
+
+# Type classes
+-R apps/tc/theories elpi.apps
+-R apps/tc/tests elpi.apps.tc.tests
+-R apps/tc/elpi elpi.apps.tc
+-I apps/tc/src
+
+# Coq-elpi
theories/elpi.v
theories/wip/memoization.v
-I src
+
src/META.coq-elpi
+src/coq_elpi_graph.mli
+src/coq_elpi_graph.ml
src/coq_elpi_vernacular_syntax.mlg
src/coq_elpi_vernacular.ml
src/coq_elpi_vernacular.mli
diff --git a/_CoqProject.test b/_CoqProject.test
index ccbfd241e..4093a2ebc 100644
--- a/_CoqProject.test
+++ b/_CoqProject.test
@@ -53,3 +53,4 @@ tests/test_link_order_import1.v
tests/test_link_order_import2.v
tests/test_link_order_import3.v
tests/test_query_extra_dep.v
+tests/test_toposort.v
diff --git a/apps/tc/Makefile b/apps/tc/Makefile
new file mode 100644
index 000000000..9b84ee407
--- /dev/null
+++ b/apps/tc/Makefile
@@ -0,0 +1,40 @@
+# detection of coq
+ifeq "$(COQBIN)" ""
+COQBIN := $(shell which coqc >/dev/null 2>&1 && dirname `which coqc`)
+endif
+ifeq "$(COQBIN)" ""
+$(error Coq not found, make sure it is installed in your PATH or set COQBIN)
+else
+$(info Using coq found in $(COQBIN), from COQBIN or PATH)
+endif
+export COQBIN := $(COQBIN)/
+
+all: build test
+
+build: Makefile.coq
+ @$(MAKE) --no-print-directory -f Makefile.coq
+
+test: Makefile.test.coq
+ @$(MAKE) --no-print-directory -f Makefile.test.coq
+
+theories/%.vo: force
+ @$(MAKE) --no-print-directory -f Makefile.coq $@
+tests/%.vo: force build Makefile.test.coq
+ @$(MAKE) --no-print-directory -f Makefile.test.coq $@
+examples/%.vo: force build Makefile.test.coq
+ @$(MAKE) --no-print-directory -f Makefile.test.coq $@
+
+Makefile.coq Makefile.coq.conf: _CoqProject
+ @$(COQBIN)/coq_makefile -f _CoqProject -o Makefile.coq
+ @$(MAKE) --no-print-directory -f Makefile.coq .merlin
+Makefile.test.coq Makefile.test.coq.conf: _CoqProject.test
+ @$(COQBIN)/coq_makefile -f _CoqProject.test -o Makefile.test.coq
+
+clean: Makefile.coq Makefile.test.coq
+ @$(MAKE) -f Makefile.coq $@
+ @$(MAKE) -f Makefile.test.coq $@
+
+.PHONY: force all build test
+
+install:
+ @$(MAKE) -f Makefile.coq $@
diff --git a/apps/tc/Makefile.coq.local b/apps/tc/Makefile.coq.local
new file mode 100644
index 000000000..f120308b2
--- /dev/null
+++ b/apps/tc/Makefile.coq.local
@@ -0,0 +1,3 @@
+CAMLPKGS+= -package coq-elpi.elpi
+OCAMLPATH:=../../src/:$(OCAMLPATH)
+export OCAMLPATH
\ No newline at end of file
diff --git a/apps/tc/README.md b/apps/tc/README.md
new file mode 100644
index 000000000..bf03a8a5c
--- /dev/null
+++ b/apps/tc/README.md
@@ -0,0 +1,524 @@
+# Type class solver
+
+This folder contains an alternative implementation of a type class solver for
+coq written in elpi. This solver is composed by two main parts, the **compiler**
+and the **solver**. The former takes coq classes and instances and "translates"
+them into the elpi representation, whereas the latter is the elpi tactic aiming
+to make instance search on coq goals.
+
+- [The compiler](#the-compiler)
+ - [Class compilation](#class-compilation)
+ - [Deterministic search](#deterministic-search)
+ - [Instance compilation](#instance-compilation)
+ - [Instance priorities](#instance-priorities)
+ - [Technical details](#technical-details)
+ - [Instance locality](#instance-locality)
+- [Goal resolution](#goal-resolution)
+- [Commands](#commands)
+- [Flags](#flags)
+- [WIP](#wip)
+
+
+## The compiler
+
+In our implementation by compiler we mean the set of rules abstracting coq
+terms, *1.* classes and *2* instances, in the elpi world. In the next two
+paragraphs, we briefly explain these two phases of the compilation, where,
+intuitively, a type class can be seen as a prolog predicate and the instances of
+a type class $C$ as rule (clause or fact) of the elpi predicate for $C$.
+
+For instance, if
+
+```coq
+Class Eqb (T: Type) := {
+ eqb : T -> T -> bool;
+ eq_leibniz : forall (A B: T), eqb A B = true -> A = B
+}.
+```
+
+is the type class representing the leibniz equality between two objects of type
+$T$, and
+
+```coq
+Program Instance eqBool : Eqb bool := {
+ eqb A B := if A then B else negb B
+}.
+Next Obligation. now intros [] []. Qed.
+```
+
+is an implementation of `Eqb` for the type `bool`, their corresponding elpi
+representation will be:
+
+```prolog
+ pred tc-Eqb i:term, o:term.
+ tc-Eqb {{bool}} {{eqBool}}.
+```
+
+### Class compilation
+
+The compilation of a type class creates dynamically (thanks to the
+`coq.elpi.add-predicate` API) a new predicate called `tc-Path.tc-ClassName` with
+$N + 1$ terms where:
+
+- `Path` is the is the logical path in which the type class `ClassName` is
+ located
+- $N$ is the number of parameter of the `ClassName`. In particular, if a type
+ class $C$ as the parameters $P_1,\dots, P_n$ then the corresponding predicate
+ will have $N$ parameters of type `term` ($1$ per parameter) and a last
+ parameter in output mode containing the result of the instance search.
+ By default, all the first $P_1,\dots,P_n$ parameters are in output mode.
+
+The set of rules allowing to add new type-class predicates in elpi are grouped
+in [create_tc_predicate.elpi](elpi/create_tc_predicate.elpi).
+
+### Deterministic search
+
+Sometimes, it could be interesting to disable the backtracking search for some
+type classes, for performances issues or design choices. In coq the flag
+*Typeclasses Unique Instances* (see
+[here](https://coq.inria.fr/refman/addendum/type-classes.html#coq:flag.Typeclasses-Unique-Instances))
+allows to block any kind of a backtrack on instance search: in this case type
+classes are supposed to be canonical.
+
+In the example below, we want the `NoBacktrack` type class not to backtrack if
+a solution is found.
+
+```coq
+Class NoBacktrack (n: nat).
+Elpi TC.Set_deterministic NoBacktrack.
+(* Ideally
+ #[backtrack(off)] Class NoBacktrack (n : nat).
+ *)
+Class A (n: nat).
+
+Instance a0 : A 0. Qed.
+Instance nb0 : NoBacktrack 0. Qed.
+Instance nb1 : NoBacktrack 1. Qed.
+Instance a3 n : NoBacktrack n -> A n -> A 3. Qed.
+
+Goal A 3. Fail apply _. Abort.
+```
+
+The goal `A 3` fails since the only instance matching it is `a3`, but we are not
+able to satisfy both its premises. In particular, the instance `nb1` is applied
+first, which fixes the parameter `n` of `a3` to `1`. Then the algorithm tries to
+find a solution for `A 1` (the second premise), but no implementation of `A` can
+solve it. In the classic approach, the type class solver would backtrack on the
+premise `NoBacktrack n` and try to apply `nb0` (this would find a solution), but
+since the type class `NoBacktrack` is deterministic, then `nb0` is discarded.
+
+In this implementation, the elpi rule for the instance `a3` is:
+
+```elpi
+ tc-A {{3}} {{a3 lp:A lp:B lp:C}} :-
+ do-once (tc-NoBacktrack A B),
+ tc-A A C.
+```
+
+The predicate `do-once i:prop` has
+
+```prolog
+do-once P :- P, !.
+```
+
+as implementation. The cut (`!`) operator is in charge to avoid backtracking on
+the query `tc-NoBacktrack A B`
+
+### Instance compilation
+
+Instances are compiled in elpi from their type. In particular, since the
+$\forall$-quantification and the left hand side of implications of coq are both
+represented with the `prod` type in elpi, we can say that the type of an
+instance $I$ is essentially a tower of
+
+
+prod N_1 T_1 (x_1\
+ prod N_2 T_2 (x_2\
+ ...
+ prod N_n T_n (x_n\
+ app [global GR, A_1, A_2, ... A_M])))
+
+
+where $\forall i \in [1, N],\ T_i$ is the type of the quantified variable $x_i$.
+Each $x_1$ represents a premise $P$ of the current instance and, if its type
+$T_i$ is a type class, then $P$ is recursively compiled and added to the final
+clause as a premise. The last `prod` contains `app [global GR, A_1, ..., A_M]`
+where `GR` is the gref of the type class implemented by $I$ and each $A_j$ is an
+argument applied to `GR` which sees every $x_i$. Note that during the
+compilation of the instance the binders $x_i$ are recursively replaced by fresh
+`pi` elpi variables.
+
+For example, the instance `eqBool` showed before, has type
+
+`Eqb bool`, it has no quantified variable and it is directly compiled in the
+clause `tc-Eqb {{bool}} {{eqBool}}`.
+
+On the other hand, if we take the instance below,
+
+```coq
+Instance eqProd (A B: Type) : Eqb A -> Eqb B -> Eqb (A * B) := { ... }
+```
+
+we see that its type is
+
+```
+prod `A` (sort (typ eqProd.u0»)) c0 \
+ prod `B` (sort (typ eqProd.u1»)) c1 \
+ prod `H0` (app [global (indt «Eqb»), c0]) c2 \
+ prod `H1` (app [global (indt «Eqb»), c1]) c3 \
+ app [global (indt «Eqb»), app [global (indt «prod»), c0, c1]]
+```
+
+there are in fact four variables that produce the elpi clause:
+
+```
+pi x0 x1 x2 x3\
+ tc-Eqb {{prod lp:A lp:B}} Sol :-
+ tc-Eqb A S1, tc-Eqb B S2,
+ Sol = {{eqProd lp:A lp:B lp:S1 lp:S2}}.
+```
+
+the four variable $c_0,...,c_3$ are quantified with `pi`, the two premises
+`H0` and `H1` are compiled as premises of the current goal (we need to find a
+proof that there exists an implementation of the class `Eqb` for the types
+of $c_0$ and $c_1$). Then the application of `«Eqb»` is used to create the head of
+the clause with its arguments and `eqProd`, the gref of the current instance,
+is used as the solution of the current goal applied to all of the quantified
+variables.
+
+The set of rules allowing to compile instances in elpi are grouped in
+[compiler.elpi](elpi/compiler.elpi).
+****
+### Instance priorities
+
+To reproduce coq behavior, instances need to respect a notion of priority:
+sometime multiple instances can be applied on a goal, but, for sake of
+performances, the order in which they are tried is essential.
+
+In the previous example, the goal `Eqb ?V` where `?V` is a meta-variable, it
+is important to first use the rules `eqBool` and then `eqProd`, the latter
+causing an infinite loop.
+
+In elpi, we have the possibility to create rules with names and, then, new rules
+can be added with respect to a particular grafting (see
+[here](https://github.com/FissoreD/coq-elpi/blob/a11558758de0a1283bd9224b618cc75e40f118fb/coq-builtin.elpi#L1679)).
+
+Our strategy of instance insertion in the elpi database reposes on a predicate
+`pred hook o:string` having, by default, $1.001$ implementations each of them
+having a name going from `"0"` to `"1000"` (bounds included). Roughly what we
+have is the following:
+
+```prolog
+:name "0" hook "0".
+:name "1" hook "1".
+...
+:name "999" hook "999".
+:name "1000" hook "1000".
+```
+
+In this way an instance can be added at the wanting position to respect its
+priority. In particular, the priority of an instance can be defined in two
+different ways by the user by coq and we retrieve this piece of
+information via the `Event` listener from `coq` (see
+[here](https://github.com/coq/coq/blob/f022d5d194cb42c2321ea91cecbcce703a9bcad3/vernac/classes.mli#L81)).
+This event contains either a class or an instance and in the latter case we can
+get its priority (see
+[here](https://github.com/FissoreD/coq-elpi/blob/a11558758de0a1283bd9224b618cc75e40f118fb/apps/tc/src/coq_elpi_tc_register.ml#L57)).
+
+#### Technical details
+
+1. If the instance has no user defined priority, the attribute containing the
+ priority of the instance is set to `None`. In this case, the priority is
+ computed as the number of premises the instance has. For example, `eqBool`
+ has priority $2$, since it has two hypothesis triggering recursive instance
+ search.
+2. If $P$ is the priority of both the instance $I_1$ and the instance $I_2$ of
+ a class $C$, then the instance that should be tried before is the one which
+ has been defined later (this is coq default behavior). To respect this order,
+ the grafting we use is `after P` for both instances, in this way, elpi will
+ put the second-defined instance before the first one.
+3. The number of hook in elpi is bounded to $1.000$, it is however possible to
+ extend it via the command `Elpi TC.AddHook G OldName NewName` where `G` is
+ either after or before and `NewName` is the new hook that will be grafted
+ after\before the hook called `OldName`. For instance, `Elpi TC.AddHook after
+ 1000 1002` creates a hook named `1002` after `1000` and `Elpi TC.AddHook before
+ 1002 1001` insert the hook `1001` before `1002`. Note that `OldName` should
+ be an existing name, otherwise, a blocking error will be thrown at the next
+ invocation of an elpi code.
+4. The event listener for instance/class creation can be extended with new
+ elpi programs via the command `Elpi Register TC Compiler PROG`, where `PROG`
+ is the name of the new elpi program called by the `Event` listener of coq.
+ Note that in the case of the creation of a
+ - Type class $C$, `PROG` is called with `[str C]` as argument where `C` is the
+ name of the class
+ - Instance $I$, `PROG` is called with `[str I, str C, str Loc, int Prio]`
+ where `I` is the name of the instance, `C` the name of the class it
+ implements, `Loc` is its `Locality` (one among `Local`, `Global`, `Export`)
+ and `Prio` is its priority.
+
+ The default elpi program for instance and class insertion is called
+ `auto_compiler` (see [here](https://github.com/FissoreD/coq-elpi/blob/a11558758de0a1283bd9224b618cc75e40f118fb/apps/tc/theories/tc.v#L61))
+5. A registered event listener for instance/class can be deactivated, activated
+ respectively with
+ 1. `Elpi TC Activate Observer PROG.`
+ 2. `Elpi TC Deactivate Observer PROG.`
+
+ by default, once registered, the elpi program `PROG` is activated
+
+### Instance locality
+
+The instances in the elpi database respect the locality given by the user. This
+is possible thanks to the attributes from
+[here](https://github.com/FissoreD/coq-elpi/blob/ac036a71f359bc1c1ee3893949d3371df10b0aef/coq-builtin.elpi#L355).
+When an instance is created the `Event` listener transfer the locality of the
+instance to the elpi program in charge to make the insertion (see
+[here](https://github.com/FissoreD/coq-elpi/blob/ac036a71f359bc1c1ee3893949d3371df10b0aef/apps/tc/elpi/compiler.elpi#L154)
+and
+[here](https://github.com/FissoreD/coq-elpi/blob/ac036a71f359bc1c1ee3893949d3371df10b0aef/apps/tc/src/coq_elpi_tc_register.ml#L37)).
+
+As a small remark, we should consider that instances depending on section
+variables should be *recompiled* on section end in order to abstract them.
+In the example below
+
+```coq
+Section Foo.
+ Variable (A B: Type) (HA : Eqb A) (HB : Eqb B).
+ Global Instance eqProd' : Eqb (A * B) := {...}.
+
+ Elpi TC.Print_instances eqb.
+ (* Here the elpi database has the instances HA, HB and eqProd' *)
+ (*
+ And the rules for eqProd' is
+ tc-Eqb {{prod A B}} {{eqProd'}}.
+
+ Remark: Here A and B are not elpi variables, but the coq variables from the
+ context
+ *)
+End Foo.
+
+Elpi TC.Print_instances eqb.
+(*
+ Here HA and HB are removed since local to Foo and
+ eqProd' has been recompiled abstracting and A, B, HA and HB. They are now
+ arguments of this instance
+*)
+(*
+ The new rules for eqProd' is now
+ tc-Eqb {{prod lp:A lp:B}} {{eqProd' lp:A lp:B lp:HA lp:HB}} :-
+ tc-Eqb A HA, tc-Eqb B HB.
+
+ Remark: Here A and B are elpi variables and HA, PB are the proof that we can
+ prove {{Eqb lp:A}} and {{Eqb lp:B}}
+*)
+```
+
+Concretely, in a section, we consider all instances as **local** in elpi. On
+section end, the `Event` listener for instance creation triggers a new call to
+the elpi program for instance compilation. This trigger contains the same event
+as the one for the instance creation, but now elpi is capable to compile the
+instance abstracting the section variable. Finally, if we are not in a section,
+instance locality will depend on the "real" locality of that instance:
+
+1. If the instance is *local*, then we accumulate the attribute *@local! =>*
+2. If the instance is *global*, then we accumulate the attribute *@global! =>*
+3. If the instance is in *export* mode, then we pass no attribute, since by default,
+ elpi rules have this particular locality
+
+
+## Goal resolution
+
+The resolution of type class goals is done via the `TC_solver` tactic (see
+[here](https://github.com/FissoreD/coq-elpi/blob/d674089e5f5773d5d922f185e2ff058e595fa8b8/apps/tc/theories/tc.v#L29)
+and [here](elpi/solver.elpi)). This tactic take the goal and start by
+introducing the quantified variables if any, then it compiles the hypotheses
+whose type is a type class and finally start by solving the goal by looking for
+the instances in the elpi database. Note that the tactic, per se, is not
+complicated since the search of instances is based on a DFS backtracking on
+failure which is the builtin search mode of query resolution in elpi.
+
+The elpi tactic can be called by the classic `elpi TC_solver` on the current
+goal, however, this can be done implicitly done using the classic tactics of coq
+doing type class resolution. In particular, we want to make our solver and coq
+one coexist. The user may whish the elpi solver to solve `Only` goals concerning
+particular type classes (for example, those defined in its library) and leave
+coq to solve the other otherwise. To do so we can call the command `Elpi
+Override TC TC_solver Only Eqb` which activates the resolution of goal of goal
+concerning `Eqb` which the solver `TC_solver`. Note that multiple solvers can be
+created and activated to solve different tasks. To do so, we take advantage of
+the `Typeclasses.set_solve_all_instances` function from coq (see
+[here](https://github.com/coq/coq/blob/f022d5d194cb42c2321ea91cecbcce703a9bcad3/pretyping/typeclasses.mli#L141))
+which allows to set a solver to be called on type class goals. We have taken the
+file [`classes.ml`] from
+[here](https://github.com/coq/coq/blob/f022d5d194cb42c2321ea91cecbcce703a9bcad3/vernac/classes.ml#L1)
+and slightly modified the function
+[`resolve_all_evars`](https://github.com/FissoreD/coq-elpi/blob/17d1f20d3d4f37abfeee7edcf31f3757fd515ff3/apps/tc/src/coq_elpi_class_tactics_hacked.ml#L1165).
+Now that function, before solving a goal verifies if the current goal contains
+only type classes overriden by the user and if so, it uses the elpi solver for
+its resolution, otherwise, it calls the default coq solver. Note that the choice
+of using elpi or coq solver is done
+[here](src/coq_elpi_class_tactics_takeover.ml). Moreover, we provide different
+commands to
+
+1. Override all type class goals and solve them by the solver of elpi, that
+ command is `Elpi Override TC TC_solver All`.
+2. Override only some type classes, that command is `Elpi Override TC TC_solver
+ Only ClassQualid+` where `ClassQualid+` is a non empty list of type class
+ names. A valid call to this command is, for example, `Elpi Override TC
+ TC_solver Only Eqb Decidable`.
+3. Override no type class, *i.e.* solve all goals with coq solver with the
+ command `Elpi Override TC TC_solver None`.
+4. Blacklist some type classes from elpi solver, `Elpi Override TC -
+ ClassQualid+`. For instance `Elpi Override TC TC_solver Only Eqb Decidable.
+ Elpi Override TC - Decidable` in equivalent to `Elpi Override TC TC_solver
+ Only Eqb`.
+5. Add type classes to be solved by the solver of elpi `Elpi Override TC +
+ ClassQualid+`. For instance, `Elpi Override TC TC_solver Only Eqb. Elpi
+ Override TC + Decidable` is equivalent to `Elpi Override TC TC_solver Only
+ Eqb Decidable`.
+
+All of these commands are meant to dynamically change the resolution of type
+classes goal in `.v` files.
+
+## Commands
+
+A small recap of the available elpi commands:
+
+
+
+ TC.Print_instances (click to expand)
+
+
+ This commands prints the list of instances inside the elpi database grouped by
+ type class and in order of priority. Note that custom rules will not appear
+ in this list. This command can also be called with the name of a type class
+ to print only the implementation of that type class in elpi. An example of the
+ result for the command `Elpi print_instance Eqb.`
+
+ ```
+ Instances list for const «Eqb» is:
+ const «eqBool»
+ const «eqProd»
+ ```
+
+
+
+
+
+ TC.Set_deterministic (click to expand)
+
+
+ Take the name of a type class in parameter and sets the search mode of that
+ class to deterministic (see [here](#deterministic-search))
+
+
+
+
+
+ TC.Get_class_info ClassName (click to expand)
+
+
+ Prints the name of the predicate associated to the class `ClassName`
+ and its search mode (`deterministic|classic`). This command is useful
+ especially when you want to add a new custom rule for a goal resolution and
+ want to know the name of the predicate of the targeted class.
+
+ Example:
+
+ ```coq
+ Elpi TC.Get_class_info Eqb.
+
+ (* Output:
+ The predicate of indt «Eqb» is tc-Eqb and search mode is classic *)
+ ```
+
+
+
+
+
+ TC.AddHook G OldName NewName (click to expand)
+
+
+ See [](#technical-details)
+
+
+
+**Note:** in a new library you may wish to automatically compile into your elpi
+database the existing classes and instances on which you library depends. To
+do so, the $4$ following commands may be useful:
+
+- `TC.AddAllClasses`: look for all the defined classes and creates their predicate
+- `TC.AddClasses ClassName+`: compile the predicate for the classes in argument
+- `TC.AddAllInstances`: look for all the defined instances and compile them
+- `TC.AddInstances InstName+`: compiles al the instances passed in argument
+
+**Note:** it is important to create the predicate of type classes (if not already done)
+before the insertion of instances otherwise this would throw an exception.
+
+## Flags
+
+Here the list of the flags available (all of them are `off` by default):
+
+
+
+ TC IgnoreEtaReduction (click to expand)
+
+
+ Solves the goal ignoring eta-reduction, in that case it will no longer possible
+ to unify `fun x => F x` with `F`
+
+
+
+
+ TC ResolutionTime (click to expand)
+
+
+ Print the time taken to solve a goal by looking into the set of rules in the
+ database of elpi
+
+
+
+
+ TC NameShortPath (click to expand)
+
+
+ Experimental and discouraged, it can be used to compile the predicate of type
+ classes without putting the `tc-Path.` prefix before `tc-ClassName` (see
+ [here](#class-compilation)). For example, the type class `Decidable` from
+ `Coq.Classes` is compiled into the predicate
+ `tc-Coq.Classes.DecidableClass.tc-Decidable`. For small tests, if you want a
+ predicate called simply `tc-Decidable` you can either use the namespace of
+ elpi (see
+ [here](https://github.com/LPCIC/elpi/blob/master/ELPI.md#namespaces)) or
+ activate the option `NameShortPat` which creates the predicate with the
+ short name `tc-Decidable`
+
+
+
+
+ TC TimeRefine (click to expand)
+
+
+ Prints the time taken by coq to refine the elpi solution in to the coq term
+
+
+
+
+ Experimental: TC CompilerWithPatternFragment (click to expand)
+
+
+ Compile instances using the pattern fragment unification of elpi: the coq
+ term applications (`app [HD | TL]`) are replaced with the elpi application
+ `(HDe TLe)` where `HDe` is the elpi representation of `HD` (similarly for `TLe`)
+
+
+
+## WIP
+
+1. Mode management:
+ - Classes with a single user defined should be taken into account to use the
+ elpi modes
+ - Classes with multiple modes ??
+2. Clarify pattern fragment unification
+3. Topological sort of premises in modes are activated
+4. Option to disable auto compiler (maybe)
+
diff --git a/apps/tc/_CoqProject b/apps/tc/_CoqProject
new file mode 100644
index 000000000..50e07f4cf
--- /dev/null
+++ b/apps/tc/_CoqProject
@@ -0,0 +1,22 @@
+# Hack to see Coq-Elpi even if it is not installed yet
+-Q ../../theories elpi
+-I ../../src
+-docroot elpi.apps
+
+-R theories elpi.apps
+-R elpi elpi.apps.tc
+-R tests elpi.apps.tc.tests
+
+src/coq_elpi_tc_register.ml
+src/coq_elpi_tc_hook.mlg
+src/coq_elpi_class_tactics_takeover.ml
+src/coq_elpi_class_tactics_hacked.ml
+src/elpi_tc_plugin.mlpack
+
+-I src/
+src/META.coq-elpi-tc
+
+theories/db.v
+theories/add_commands.v
+theories/tc.v
+theories/wip.v
diff --git a/apps/tc/_CoqProject.test b/apps/tc/_CoqProject.test
new file mode 100644
index 000000000..2eb1886e8
--- /dev/null
+++ b/apps/tc/_CoqProject.test
@@ -0,0 +1,52 @@
+-arg -w -arg -Not-added
+
+# Hack to see Coq-Elpi even if it is not installed yet
+-Q ../../theories elpi
+-I ../../src
+
+-Q elpi elpi.apps.tc
+-R theories elpi.apps
+-R tests elpi.apps.tc.tests
+-I src
+
+
+# Register (de-)activation
+tests/register/f1.v
+tests/register/f2.v
+tests/register/f3.v
+
+tests/hook_test.v
+
+tests/auto_compile.v
+
+# Import order of instances
+tests/importOrder/sameOrderCommand.v
+tests/importOrder/f1.v
+tests/importOrder/f2a.v
+tests/importOrder/f2b.v
+tests/importOrder/f3a.v
+tests/importOrder/f3b.v
+tests/importOrder/f3c.v
+tests/importOrder/f3d.v
+tests/importOrder/f3e.v
+tests/importOrder/f3f.v
+tests/importOrder/f3g.v
+
+tests/nobacktrack.v
+tests/patternFragment.v
+tests/contextDeepHierarchy.v
+# tests/test_commands_API.v
+tests/section_in_out.v
+tests/eqSimplDef.v
+
+tests/injTest.v
+# Test with light version of base.v of stdpp
+tests/stdppInj.v
+tests/stdppInjClassic.v
+tests/test.v
+
+tests/indt_to_inst.v
+
+tests/bigTest.v
+
+examples/tutorial.v
\ No newline at end of file
diff --git a/apps/tc/elpi/WIP/modes.elpi b/apps/tc/elpi/WIP/modes.elpi
new file mode 100644
index 000000000..220e971af
--- /dev/null
+++ b/apps/tc/elpi/WIP/modes.elpi
@@ -0,0 +1,44 @@
+/* license: GNU Lesser General Public License Version 2.1 or later */
+/* ------------------------------------------------------------------------- */
+
+% pred make-modes-cl i:gref, i:list term, i:term, i:list (list hint-mode), i:list (list term), o:prop.
+% make-modes-cl T V (prod _ _ X) HintModes L (pi x\ C x):-
+% std.map HintModes (x\r\ [r|_] = x) FST,
+% std.map HintModes (x\r\ [_|r] = x) LAST,
+% pi x\ sigma NewL\
+% std.map2 L FST (l\m\r\ if (m = mode-input) (r = [x | l]) (r = l)) NewL,
+% make-modes-cl T [x | V] (X x) LAST NewL (C x).
+% make-modes-cl T V _ _ L Clause :-
+% Ty = {coq.mk-app (global T) {std.rev V}},
+% Clause = (pi s\ tc T Ty s :- std.forall L (x\ std.exists x var), !, coq.error "Invalid mode for" Ty).
+
+% takes the type of a class and build a list
+% of hint mode where the last element is mandatory
+pred make-last-hint-mode-input i:term, o:list hint-mode.
+make-last-hint-mode-input (prod _ _ (x\ (prod _ _ _) as T)) [mode-output | L] :-
+ pi x\ make-last-hint-mode-input (T x) L.
+make-last-hint-mode-input (prod _ _ _) [mode-input].
+make-last-hint-mode-input (sort _) [].
+
+% build a list of the seme langht as the the passed one
+% where all the elements are []
+pred build-empty-list i:list B, o:list (list A).
+build-empty-list [] [].
+build-empty-list [_ | TL] [[] | L] :-
+ build-empty-list TL L.
+
+% add the hint modes of a Class to the database.
+% note that if the Class has not specified hint mode
+% then we assume the hint mode to be - - - ... !
+pred add-modes i:gref.
+:if "add-modes"
+add-modes GR :-
+ % the hint mode is added only if not exists
+ if (not (class GR _ _)) (
+ coq.env.typeof GR Ty,
+ coq.hints.modes GR "typeclass_instances" ModesProv,
+ if (ModesProv = []) (Modes = [{make-last-hint-mode-input Ty}]) (Modes = ModesProv),
+ % make-modes-cl GR [] Ty Modes {build-empty-list Modes} Cl,
+ % add-tc-db _ (after "firstHook") Cl,
+ ) true.
+add-modes _.
\ No newline at end of file
diff --git a/apps/tc/elpi/alias.elpi b/apps/tc/elpi/alias.elpi
new file mode 100644
index 000000000..7f8844038
--- /dev/null
+++ b/apps/tc/elpi/alias.elpi
@@ -0,0 +1,19 @@
+/* license: GNU Lesser General Public License Version 2.1 or later */
+/* ------------------------------------------------------------------------- */
+
+pred alias i:term, o:term.
+
+pred replace-with-alias.aux i:list term, o:list term, o:bool.
+replace-with-alias.aux [] [] ff.
+replace-with-alias.aux [X | Xs] [Y | Ys] B :-
+ replace-with-alias X Y B',
+ replace-with-alias.aux Xs Ys B'',
+ or B' B'' B.
+
+% [replace-with-alias T T1 Changed] T1 is T where aliases are replaced
+pred replace-with-alias i:term, o:term, o:bool.
+replace-with-alias A Sol tt :- alias A Sol',
+ replace-with-alias Sol' Sol _.
+replace-with-alias (app ToReplace) (app Sol) A :-
+ replace-with-alias.aux ToReplace Sol A.
+replace-with-alias A A ff.
\ No newline at end of file
diff --git a/apps/tc/elpi/base.elpi b/apps/tc/elpi/base.elpi
new file mode 100644
index 000000000..531193a9a
--- /dev/null
+++ b/apps/tc/elpi/base.elpi
@@ -0,0 +1,62 @@
+/* license: GNU Lesser General Public License Version 2.1 or later */
+/* ------------------------------------------------------------------------- */
+
+% [count L X R] counts the occurrences of X in L
+pred count i:list A, i:A, o:int.
+count [] _ 0.
+count [A | TL] A R :- count TL A X, R is (X + 1).
+count [_ | TL] A R :- count TL A R.
+
+pred expected-found i:A, i:A.
+expected-found Expected Found :-
+ Expected = Found;
+ halt "Assertion error"
+ "\nExpected :" Expected
+ "\nFound :" Found.
+
+pred last-no-error i:list A, o:A.
+last-no-error A B :-
+ (std.last [] _ :- !, fail) => std.last A B.
+
+% [find L F R] returns the first R in L such that (F R) is valid
+pred find i:list A, i:(A -> prop), o:A.
+find [] _ _ :- std.fatal-error "find element not found".
+find [R | _] F R :- F R.
+find [_ | L] F R :- find L F R.
+
+pred find-opt i:list A, i:(A -> prop), o:(option A).
+find-opt [] _ none.
+find-opt [R | _] F (some R) :- F R.
+find-opt [_ | L] F R :- find-opt L F R.
+
+pred list-init i:int, i:(int -> A -> prop), o:list A.
+list-init N _ _ :- N < 0, std.fatal-error "list-init negative length".
+list-init 0 _ [] :- !.
+list-init N F [A | TL] :-
+ F N A, N1 is N - 1, list-init N1 F TL.
+
+pred args->str-list i:list argument, o: list string.
+args->str-list L Res :-
+ std.map L (x\r\ str r = x) Res.
+
+pred or i:bool, i:bool, o:bool.
+or ff ff ff :- !.
+or _ _ tt.
+
+pred neg i:bool, o:bool.
+neg tt ff.
+neg ff tt.
+
+pred fail->bool i:prop, o:bool.
+fail->bool P ff :- P, !.
+fail->bool _ tt.
+
+pred sep.
+sep :- coq.say "---------------------------------".
+
+pred do i:list prop.
+do [].
+do [P|PS] :- P, do PS.
+
+pred do-once i:prop.
+do-once A :- A, !.
\ No newline at end of file
diff --git a/apps/tc/elpi/compiler.elpi b/apps/tc/elpi/compiler.elpi
new file mode 100644
index 000000000..6c9b2c5bb
--- /dev/null
+++ b/apps/tc/elpi/compiler.elpi
@@ -0,0 +1,237 @@
+/* license: GNU Lesser General Public License Version 2.1 or later */
+/* ------------------------------------------------------------------------- */
+
+% returns the classes on which the current gref depends
+pred get-class-dependencies i:gref, o:list gref.
+get-class-dependencies GR Res :-
+ coq.env.dependencies GR _ DepSet,
+ coq.gref.set.elements DepSet DepList,
+ std.filter DepList coq.TC.class? Res.
+
+pred unify-fo i:list name, i:list term, i:list (term -> term), o:term, i:list term, o:term.
+unify-fo [Name | Names] [Ty | Tys] [Fun | Funs] (fun Name Ty Fun) [X|Xs] R :-
+ var R, !,
+ unify-fo Names Tys Funs (Fun X) Xs R.
+unify-fo _ _ _ F L R :- var R, !, coq.mk-app F L R.
+unify-fo _ _ _ F L (app R) :-
+ std.appendR H L R,
+ if (H = [X]) (F = X) (F = app H).
+unify-fo _ _ _ F [] F.
+
+pred remove-ho-unification i:prop, i:bool, i:int, i:term, i:term, i:list prop, i:list term, i:list name, i:list term, i:list (term -> term), i:list term, i:list prop, o:prop.
+:name "remove-ho-unification:start"
+remove-ho-unification IsHead IsPositive 0 Ty AppInst Premises [] _ _ _ _ Fixes Clause :- !,
+ copy Ty Ty1,
+ copy AppInst AppInst1,
+ if (IsPositive = tt)
+ (make-tc IsHead Ty1 AppInst1 {std.append Fixes Premises} Clause)
+ (make-tc IsHead Ty1 AppInst1 Premises Clause1, std.append Fixes [Clause1] L, Clause = do L).
+remove-ho-unification IsHead IsPositive 0 Ty AppInst Premises [(app [X | Y] as G) | TL] Names Types Funs [Gen | GensTL] Fixes P2 :- !,
+ std.length Y Arity,
+ std.split-at Arity Types SubTypes TypesTL,
+ std.split-at Arity Names SubNames NamesTL,
+ std.split-at Arity Funs SubFuns FunsTL,
+ P1 = (unify-fo SubNames SubTypes SubFuns X Y Gen),
+ copy G Gen =>
+ remove-ho-unification IsHead IsPositive 0 Ty AppInst Premises TL NamesTL TypesTL FunsTL GensTL [P1 | Fixes] P2.
+
+remove-ho-unification IsHead tt N Ty AppInst Premises LT NameL TypeL FunL GenL Fixes (pi ty f name gen\ Clause ty f name gen) :-
+ N > 0,
+ N1 is N - 1,
+ pi name ty f gen\ remove-ho-unification IsHead tt N1 Ty AppInst Premises LT
+ [name | NameL] [ty | TypeL] [f | FunL]
+ [gen | GenL] Fixes (Clause ty f name gen).
+
+remove-ho-unification IsHead ff N Ty AppInst Premises LT NameL TypeL FunL GenL Fixes (sigma ty f name gen\ Clause ty f name gen) :-
+ N > 0,
+ N1 is N - 1,
+ pi name ty f gen\ remove-ho-unification IsHead ff N1 Ty AppInst Premises LT
+ [name | NameL] [ty | TypeL] [f | FunL]
+ [gen | GenL] Fixes (Clause ty f name gen).
+
+pred pattern-fragment? i:term.
+pattern-fragment? (app [HD|TL]) :-
+ not (HD = global _), distinct_names [HD | TL].
+
+pred get-pattern-fragment i:term, o:list term.
+get-pattern-fragment T1 TL :- !,
+ (pi L G GL\ fold-map (app L as G) GL G [G | GL] :- distinct_names L) =>
+ % (pi G GL\ fold-map (app _ as G) GL G GL) =>
+ (pi G GL\ fold-map (prod _ _ _ as G) GL G GL) =>
+ fold-map T1 [] _ TL.
+
+/*
+compile-aux [Ty Inst Premises PiAccRev UnivL IsPositive Clause No-Premises]
+Ty : the type of the instance
+Inst : the instance term on the form (global InstGref)
+Premises : list of constraints/premises of an instances found from its type
+PiAccRev : the list of pi variables accumulated from the (prod _ _ Bo) of the
+ type of Inst. The will be used on the solution of the clause
+ coq.mk-app Inst {std.rev PiAccRev} Sol
+UnivL : the list of universes of types inside Ty that are replaced with
+ a fresh variable to simplify unification
+IsPositive : bring the information about the positivity of the current sub-term
+ e.g. if T = A -> (B -> C) -> D, then:
+ D is positive in T, (B -> C) is negative, A is positive in T
+ C is positivie in (B -> C), B is negative in (B -> C)
+ IsPositive is used to know how to accumulate sigma Xi\ and pi x\ in the
+ current clause
+IsHead : a prop [true|false] to know if we are compiling the head of the
+ instance or one hypothesis of its premises
+Clause : the solution to be returned
+No-Premises : a boolean saying if the returned clause as no premises that is an
+ instance with no hypothesis
+*/
+pred compile-aux i:term, i:term, i:list prop, i:list term, i:list univ, i:bool, i:prop, o:prop, o:bool.
+:name "compiler-aux:start"
+compile-aux Ty I [] [] [X | XS] IsPositive IsHead (pi x\ C x) IsLeaf :- !,
+ pi x\ copy (sort (typ X)) (sort (typ x)) => copy Ty (Ty1 x),
+ compile-aux (Ty1 x) I [] [] XS IsPositive IsHead (C x) IsLeaf.
+compile-aux (prod N T F) I RevPremises ListVar [] IsPositive IsHead Clause ff :- !,
+ (if (IsPositive = tt) (Clause = pi x\ C x) (Clause = (pi x\ decl x N T => C x))),
+ pi p\ sigma NewPremise TC L\
+ if (get-TC-of-inst-type T TC, coq.TC.class? TC /*, not (occurs p (F p))*/)
+ (compile-aux T p [] [] [] {neg IsPositive} false NewPremise _,
+ if (class TC _ deterministic)
+ (L = [do-once NewPremise | RevPremises])
+ (L = [NewPremise | RevPremises])) (L = RevPremises),
+ compile-aux (F p) I L [p | ListVar] [] IsPositive IsHead (C p) _.
+compile-aux Ty I RevPremises ListVar [] _ IsHead Clause tt :-
+ not (is-option-active {oTC-use-pattern-fragment-compiler}), !,
+ std.rev RevPremises RevRHS,
+ coq.mk-app I {std.rev ListVar} AppInst,
+ make-tc IsHead Ty AppInst RevRHS Clause.
+compile-aux Ty I RevPremises ListVar [] IsPositive IsHead Clause tt :- !,
+ std.rev RevPremises Premises,
+ coq.mk-app I {std.rev ListVar} AppInst,
+ std.append {get-pattern-fragment Ty} {get-pattern-fragment AppInst} Term-to-be-fixed,
+ std.fold Term-to-be-fixed 0 (e\acc\r\ sigma L X\ e = app X, std.length X L, r is acc + L - 1) Len,
+ remove-ho-unification IsHead IsPositive Len Ty AppInst Premises Term-to-be-fixed [] [] [] [] [] Clause.
+
+% build a list of Clauses of type tc to be temporarly added to the
+% database, used in theorems having assumptions.
+pred compile-ctx i:goal-ctx, o:list prop.
+compile-ctx [] [].
+compile-ctx [X | Xs] [Clause | ResTl] :-
+ (decl Var _ Ty = X; def Var _ Ty _ = X),
+ is-instance-term Ty,
+ compile-ty Ty Var _ _ Clause,
+ compile-ctx Xs ResTl.
+compile-ctx [_ | Tl] L :- compile-ctx Tl L.
+
+pred compile-ty i:term, i:term, o:bool, o:gref, o:prop.
+compile-ty Ty Inst IsLeaf TC-of-Inst Clause:-
+ if (get-TC-of-inst-type Ty TC-of-Inst)(
+ @redflags! coq.redflags.beta => coq.reduction.lazy.norm Ty Ty1,
+ coq.univ.variable.set.elements {coq.univ.variable.of-term Ty1} L,
+ std.map L (x\r\ coq.univ.variable r x) L1,
+ compile-aux Ty1 Inst [] [] L1 tt true Clause IsLeaf)
+ % (coq.warning "" "" "Adding polymorphic Instance" Inst).
+ true.
+
+pred compile i:gref, o:bool, o:gref, o:prop.
+compile InstGR IsLeaf TC-of-Inst Clause:-
+ coq.env.typeof InstGR Ty,
+ compile-ty Ty (global InstGR) IsLeaf TC-of-Inst Clause.
+
+% if an instance depends on multiple TC then a warning is raised.
+pred warn-multiple-deps i:gref, i:list gref.
+warn-multiple-deps Inst Dep :-
+ if (fail, {std.length Dep} > 1) (
+ coq.warning "add-inst-with-multiple-deps" "TC-warning"
+ "Adding" Inst "which dependes on mulitple class dependencies:" Dep)
+ true.
+
+pred has-context-deps i:gref.
+has-context-deps GR :-
+ coq.env.section SectionVars,
+ coq.env.dependencies GR _ Deps,
+ std.exists SectionVars (x\ coq.gref.set.mem (const x) Deps).
+
+pred is-local.
+is-local :- std.mem {attributes} (attribute "local" _).
+
+pred get-locality i:string, o:list prop.
+get-locality "Local" [@local!].
+get-locality _ [@local!] :- coq.env.current-section-path [_ | _].
+get-locality "Global" [@global!].
+get-locality "Export" [].
+
+pred add-inst i:gref, i:gref, i:string, i:int.
+add-inst Inst TC Locality Prio :-
+ coq.env.current-section-path SectionPath,
+ compile Inst _ TC Clause,
+ % TODO: a clause is flexible if an instance is polimorphic (pglobal)
+ not (var Clause),
+ if (Prio = -1) (get-inst-prio Inst Prio1) (Prio1 = Prio),
+ Graft is after (int_to_string Prio1),
+ get-full-path Inst ClauseName,
+ get-locality Locality LocalityProp,
+ LocalityProp => (add-tc-db ClauseName Graft Clause, add-tc-db _ Graft (instance SectionPath Inst TC)).
+add-inst Inst _ _ _ :-
+ coq.warning "Not-added" "TC_solver" "Warning : Cannot compile " Inst "since it is pglobal".
+
+% [add-inst->db IgnoreClassDepL ForceAdd Inst] add the Inst to
+% the database except those depending on at least one
+% inside IgnoreClassDepL
+pred add-inst->db i:list gref, i:bool, i:gref.
+:name "add-inst->db:start"
+add-inst->db IgnoreClassDepL ForceAdd Inst :-
+ coq.env.current-section-path SectionPath,
+ get-class-dependencies Inst Dep,
+ warn-multiple-deps Inst Dep,
+ if ((ForceAdd = tt; not (instance _ Inst _)),
+ not (std.exists Dep (std.mem IgnoreClassDepL)), not (banned Inst))
+ (
+ compile Inst _IsLeaf TC-of-Inst Clause,
+ % TODO: a clause is flexible if an instance is polimorphic (pglobal)
+ not (var Clause),
+ Graft is after (int_to_string {get-inst-prio Inst}),
+ get-full-path Inst ClauseName,
+ if (is-local) (Visibility = [@local!])
+ (if (has-context-deps Inst)
+ (@local! => add-tc-db _ Graft (instance SectionPath Inst TC-of-Inst))
+ (@global! => add-tc-db _ Graft (instance [] Inst TC-of-Inst)), Visibility = [@global!]),
+ Visibility => add-tc-db ClauseName Graft Clause
+ )
+ true; @global! => add-tc-db _ _ (banned Inst),
+ coq.warning "Not-added" "TC_solver" "Warning : Cannot compile " Inst "since it is pglobal".
+
+% add all the instances of a TC
+pred add-inst-of-tc i:list gref, i:list gref, i:gref.
+add-inst-of-tc IgnoreDepClassGR IgnoreInstsGR GR:-
+ get-inst-by-tc-name GR InstL,
+ std.filter InstL (x\ not (std.mem IgnoreInstsGR x)) InstLF,
+ std.forall InstLF (add-inst->db IgnoreDepClassGR ff).
+
+pred add-tc-or-inst-gr i:list string, i:list string, i:list gref.
+add-tc-or-inst-gr IgnoreDepClass IgnoreInsts Names :-
+ std.map IgnoreDepClass coq.locate IgnoreDepClassGR,
+ std.map IgnoreInsts coq.locate IgnoreInstsGR,
+ std.forall Names (GR\
+ if2 (coq.TC.class? GR)(add-inst-of-tc IgnoreDepClassGR IgnoreInstsGR GR)
+ (is-instance-gr GR)(add-inst->db IgnoreDepClassGR ff GR)
+ (coq.warning "not-inst-nor-tc" "TC-warning" GR "is neither a TC nor a instance")
+ ).
+
+% [add-tc-or-inst IgnoreDepClass ClassName] look
+% for all the instances of ClassName and call the pred
+% add-inst->db
+pred add-tc-or-inst i:list string, i:list string, i:list string.
+add-tc-or-inst IgnoreDepClass IgnoreInsts Names :-
+ std.map Names coq.locate L,
+ add-tc-or-inst-gr IgnoreDepClass IgnoreInsts L.
+
+% takes a Path and a GR and returns if
+% the GR is located in Path
+pred is-in-path i:string, i:gref.
+is-in-path Path GR :-
+ std.mem {coq.gref->path GR} Path.
+
+% Look for the instances of ClassName
+% that are located in Path.
+pred add-path i:string, i:string.
+add-path ClassName Path :-
+ coq.locate ClassName GR,
+ std.filter {get-inst-by-tc-name GR} (is-in-path Path) InstInPath,
+ std.forall InstInPath (add-inst->db [] ff).
\ No newline at end of file
diff --git a/apps/tc/elpi/create_tc_predicate.elpi b/apps/tc/elpi/create_tc_predicate.elpi
new file mode 100644
index 000000000..28ee4ea93
--- /dev/null
+++ b/apps/tc/elpi/create_tc_predicate.elpi
@@ -0,0 +1,49 @@
+/* license: GNU Lesser General Public License Version 2.1 or later */
+/* ------------------------------------------------------------------------- */
+
+pred bool->mode-term i:bool, o:pair argument_mode string.
+% TODO: here every mode is declared to O;term.
+% If you want to make it work as intended,
+% replace the output of tt with "i:term"
+:name "bool->mode-term"
+bool->mode-term tt (pr in "term").
+bool->mode-term ff (pr out "term").
+
+pred modes->string i:list bool, o:list (pair argument_mode string).
+modes->string L S :-
+ std.map L bool->mode-term S.
+
+pred make-tc-modes i:int, o:list (pair argument_mode string).
+make-tc-modes NB_args ModesStr :-
+ list-init NB_args (x\r\ r = ff) ModesBool,
+ modes->string ModesBool ModesStr.
+
+pred build-modes i:gref, o:list (pair argument_mode string).
+build-modes ClassGr Modes :-
+ is-option-active {oTC-addModes},
+ coq.hints.modes ClassGr "typeclass_instances" ModesProv,
+ not (ModesProv = []),
+ coq.hints.modes ClassGr "typeclass_instances" ModesProv,
+ std.assert! (ModesProv = [HintModes]) "At the moment we only allow TC with one Hint Mode",
+ std.map {std.append HintModes [mode-output]} (x\r\ if (x = mode-output) (r = ff) (r = tt)) ModesBool,
+ modes->string ModesBool Modes.
+build-modes ClassGr Modes :-
+ coq.env.typeof ClassGr ClassTy,
+ coq.count-prods ClassTy N',
+ N is N' + 1, % Plus one for the solution
+ make-tc-modes N Modes.
+
+pred add-class-gr i:search-mode, i:gref.
+add-class-gr SearchMode ClassGr :-
+ std.assert! (coq.TC.class? ClassGr) "Only gref of type classes can be added as new predicates",
+ if (class ClassGr _ _) true
+ (build-modes ClassGr Modes,
+ gref->pred-name ClassGr PredName,
+ coq.elpi.add-predicate "tc.db" _ PredName Modes,
+ add-tc-db _ _ (tc-mode ClassGr Modes),
+ @global! => coq.elpi.accumulate _ "tc.db" (clause _ _ (class ClassGr PredName SearchMode :- !))).
+
+pred add-class-str i:search-mode, i:string.
+add-class-str SearchMode TC_Name :-
+ coq.locate TC_Name TC_Gr,
+ add-class-gr SearchMode TC_Gr.
\ No newline at end of file
diff --git a/apps/tc/elpi/parser_addInstances.elpi b/apps/tc/elpi/parser_addInstances.elpi
new file mode 100644
index 000000000..386dbc766
--- /dev/null
+++ b/apps/tc/elpi/parser_addInstances.elpi
@@ -0,0 +1,34 @@
+/* license: GNU Lesser General Public License Version 2.1 or later */
+/* ------------------------------------------------------------------------- */
+
+kind enum type.
+type path string -> string -> enum.
+type addInstPrio int -> string -> enum.
+type tcOrInst list string -> enum.
+type ignoreInstances, ignoreClasses string -> list string -> enum.
+
+pred parse i:list argument, o:enum.
+parse [str ClassName, str "path", str Path] (path ClassName Path).
+parse [str ClassName, str "ignoreInstances" | InstNames] (ignoreInstances ClassName Res) :-
+ args->str-list InstNames Res.
+parse [str ClassName, str "ignoreClasses" | ClassNames] (ignoreClasses ClassName Res) :-
+ args->str-list ClassNames Res.
+parse ClassNames (tcOrInst Res) :- args->str-list ClassNames Res.
+parse [int N, str Instance] (addInstPrio N Instance).
+
+pred run-command i:enum.
+:if "debug"
+run-command A :- coq.say A, fail.
+run-command (ignoreClasses ClassName IgnoreClasses) :-
+ add-tc-or-inst IgnoreClasses [] [ClassName].
+run-command (tcOrInst InstNames) :-
+ add-tc-or-inst [] [] InstNames.
+run-command (path ClassName Path):-
+ add-path ClassName Path.
+run-command (ignoreInstances ClassName InstNames):-
+ add-tc-or-inst [] InstNames [ClassName].
+run-command (addInstPrio Prio InstanceName) :-
+ coq.locate InstanceName InstGr,
+ compile InstGr _ _ C,
+ S is int_to_string Prio,
+ add-tc-db _ (before S) C.
\ No newline at end of file
diff --git a/apps/tc/elpi/rewrite_forward.elpi b/apps/tc/elpi/rewrite_forward.elpi
new file mode 100644
index 000000000..b602a9a13
--- /dev/null
+++ b/apps/tc/elpi/rewrite_forward.elpi
@@ -0,0 +1,76 @@
+/* license: GNU Lesser General Public License Version 2.1 or later */
+/* ------------------------------------------------------------------------- */
+
+pred forward i:term, o:term, o:list (pair (list term) term).
+
+% Auxiliary function for rewrite-forward
+pred rewrite-forward->list i:term, i:name, i:prop, o:list prop.
+rewrite-forward->list P N (forward _ Lemma RewL) L :-
+ coq.mk-app Lemma [P] LemmaApp,
+ % coq.typecheck LemmaApp T ok,
+ % coq.say T,
+ std.map RewL (x\r\ sigma ProjL Ty Pr\
+ pr ProjL Ty = x,
+ make-proj-app ProjL LemmaApp Pr,
+ r = decl Pr N Ty) L.
+
+% Takes a decl from the context and returns the list of its atomic
+% representations by looking in the forward clauses
+pred rewrite-forward i:prop, o:list prop.
+rewrite-forward (decl P N Ty) L :-
+ std.findall (forward Ty _ _) FwdL,
+ std.map FwdL (rewrite-forward->list P N) RewFdw,
+ std.flatten RewFdw L.
+rewrite-forward _ [].
+
+% Takes a list of projections ([proj1|proj2]*) and a term T
+% and returns the coq's term (projX (projY (... (projZ T))))
+% Note that app [Proj, _, _, Rest] has two holes for the types
+% of the left and right side of Rest
+pred make-proj-app i:list term, i:term, o:term.
+make-proj-app [Proj | Projs] T (app [Proj, L, R, Rest]) :-
+ make-proj-app Projs T Rest,
+ % TODO: here we do a naive typecheck to get the types L and R of Rest,
+ % it can be done in a faster way
+ coq.typecheck Rest {{and lp:L lp:R}} ok.
+make-proj-app [] T T.
+
+% Takes a conjunction C of terms and []. It returns a list of pair:
+% The paths to the conjunct c in C and the path to reach it in C
+pred rec-split-and i:term, i:(list term), o:list (pair (list term) term).
+rec-split-and {{lp:A /\ lp:B}} DL L :-
+ LEFT = [{{proj1}} | DL],
+ RIGHT = [{{proj2}} | DL],
+ rec-split-and A LEFT AL,
+ rec-split-and B RIGHT BL,
+ std.append AL BL L.
+rec-split-and A P [pr P A].
+
+% It takes a rewriting-lemma and abstract it into elpi in a forward
+% clause of type forward. The base case wants a ∀(x : T).f x, since
+% we want to keep trace of the type T of x.
+pred compile-rewrite i:term, i:term, i:list term, o:prop.
+compile-rewrite (prod _ Ty ((x\ app _) as Bo)) Lemma L (pi x\ forward Ty LemmaApp (TL x)) :-
+ pi x\
+ coq.mk-app Lemma {std.rev L} LemmaApp,
+ rec-split-and (Bo x) [] (TL x).
+compile-rewrite (prod _ _ Bo) Lemma L (pi x\ C x) :-
+ pi x\ compile-rewrite (Bo x) Lemma [x | L] (C x).
+
+% Takes a string (the name of a rewriting-lemma),
+% compiles and adds it as a forward clause in tc.db
+pred add-lemma->forward i:string.
+add-lemma->forward Lemma :-
+ coq.locate Lemma Gr,
+ coq.env.typeof Gr Type,
+ compile-rewrite Type (global Gr) [] Cl,
+ coq.elpi.accumulate _ "tc.db" (clause Lemma _ Cl).
+
+% TODO: @FissoreD @gares should make a set in output?
+pred rewrite-dep i:list prop, o:list prop.
+rewrite-dep [] [].
+rewrite-dep [A | B] L :-
+ rewrite-forward A NewA, not (NewA = []),
+ std.append NewA B ToTreat,
+ rewrite-dep ToTreat L.
+rewrite-dep [A | TL] [A | L] :- rewrite-dep TL L.
\ No newline at end of file
diff --git a/apps/tc/elpi/solver.elpi b/apps/tc/elpi/solver.elpi
new file mode 100644
index 000000000..8aeb3c19e
--- /dev/null
+++ b/apps/tc/elpi/solver.elpi
@@ -0,0 +1,82 @@
+/* license: GNU Lesser General Public License Version 2.1 or later */
+/* ------------------------------------------------------------------------- */
+
+msolve L N :- !,
+ coq.ltac.all (coq.ltac.open solve) {std.rev L} N.
+
+pred build-context-clauses i:list prop, o:list prop.
+% Add the section's definition to the given context
+% and atomize context hypothesis if needed
+:name "build-context-clauses"
+build-context-clauses Ctx Clauses :-
+ std.map {coq.env.section}
+ (x\r\ sigma F\ coq.env.typeof (const x) F,
+ r = (decl (global (const x)) _ F)) SectionCtx,
+ std.append Ctx SectionCtx CtxAndSection,
+ compile-ctx CtxAndSection Clauses.
+
+pred tc-recursive-search i:term, o:term.
+tc-recursive-search Ty Sol :-
+ std.time (coq.safe-dest-app Ty (global TC) TL',
+ std.append TL' [Sol] TL,
+ coq.elpi.predicate {gref->pred-name TC} TL Q, Q) Time,
+ if (is-option-active {oTC-resolution-time}) (coq.say "Instance search" Time) true.
+
+:if "solve-print-goal"
+solve (goal Ctx _ Ty _ _) _ :-
+ coq.say "Ctx" Ctx "Ty" Ty, fail.
+
+% solve (goal C _ (prod N Ty F) S _ as _G) _L GL :- !,
+% @pi-decl N Ty x\
+% declare-evar [decl x N Ty|C] (Raw x) (F x) (Sol x),
+% solve (goal [decl x N Ty|C] (Raw x) (F x) (Sol x) []) _L GL,
+% if (Sol x = app [HD, x]) (S = HD) (S = fun N Ty Sol).
+% solve (goal C _ (prod N Ty F) XX _ as G) _L GL :- !,
+% % intros_if_needed Prod C []
+% (@pi-decl N Ty x\
+% declare-evar [decl x N Ty|C] (Raw x) (F x) (Sol x),
+% solve (goal [decl x N Ty|C] (Raw x) (F x) (Sol x) []) _L _,
+% coq.safe-dest-app (Sol x) Hd (Args x)),
+% if (pi x\ last-no-error (Args x) x, std.drop-last 1 (Args x) NewArgs)
+% (coq.mk-app Hd NewArgs Out, refine Out G GL) (
+% % coq.say "Not eta" (Sol x) x (fun N Ty Sol),
+% XX = (fun N Ty Sol)).
+% solve (goal C _ (prod N _ _ as P) _ A as G) _L GL :- !,
+% declare-evar C T P S',
+% G' = (goal C T P S' A),
+% refine (fun N _ _) G' GL1,
+% coq.ltac.all (coq.ltac.open solve) GL1 _,
+% refine S' G GL.
+solve (goal C _ (prod N Ty F) _ _ as G) GL :- !,
+ (@pi-decl N Ty x\
+ declare-evar [decl x N Ty|C] (Raw x) (F x) (Sol x),
+ solve (goal [decl x N Ty|C] (Raw x) (F x) (Sol x) []) _),
+ if (pi x\
+ % also check the head does not contain x
+ coq.safe-dest-app (Sol x) Hd (Args x),
+ last-no-error (Args x) x,
+ std.drop-last 1 (Args x) NewArgs)
+ (coq.mk-app Hd NewArgs Out, refine Out G GL1) (refine (fun N _ _) G GL1),
+ coq.ltac.all (coq.ltac.open solve) GL1 GL.
+% solve (goal _ _ (prod N _ _) _ _ as G) GL :- !,
+% refine (fun N _ _) G GL1,
+% coq.ltac.all (coq.ltac.open solve) GL1 GL.
+solve (goal Ctx _ Ty Sol _ as G) GL :-
+ var Sol,
+ build-context-clauses Ctx Clauses,
+ % @redflags! coq.redflags.beta => coq.reduction.lazy.norm Ty Ty1,
+ Clauses => if (tc-recursive-search Ty Proof)
+ (
+ % @no-tc! => coq.elaborate-skeleton X _ X' ok,
+ % coq.say "Solution " X "end" X' "caio",
+ % std.assert! (ground_term X') "solution not complete",
+ % (pi F\ (copy (fun _ _ x\ (app [F, x])) F :- !)) => copy X X',
+ if (is-option-active {oTC-ignore-eta-reduction})
+ (Proof' = Proof) (coq.reduction.eta-contract Proof Proof'),
+ std.time (refine Proof' G GL) Refine-Time,
+ if (is-option-active {oTC-time-refine}) (coq.say "Refine Time" Refine-Time) true;
+ coq.error "illtyped solution:" {coq.term->string Proof}
+ )
+ (GL = [seal G]).
+
+main _.
\ No newline at end of file
diff --git a/apps/tc/elpi/tc_aux.elpi b/apps/tc/elpi/tc_aux.elpi
new file mode 100644
index 000000000..3cb72af47
--- /dev/null
+++ b/apps/tc/elpi/tc_aux.elpi
@@ -0,0 +1,112 @@
+/* license: GNU Lesser General Public License Version 2.1 or later */
+/* ------------------------------------------------------------------------- */
+
+% Contains the list of classes that
+% cannot be compiled
+
+% returns the TC from the type of an instance
+pred get-TC-of-inst-type i:term, o:gref.
+get-TC-of-inst-type (prod _ _ A) GR:-
+ pi x\ get-TC-of-inst-type (A x) GR.
+get-TC-of-inst-type (app [global TC | _]) TC.
+get-TC-of-inst-type (global TC) TC.
+
+pred drop-last i:list A, i:list A, o:list A.
+drop-last [X | XS] [Y | YS] L :-
+ same_term X Y, !, drop-last XS YS L.
+drop-last L [] L' :- std.rev L L'.
+
+pred instances-of-current-section o:list gref.
+:name "MySectionEndHook"
+instances-of-current-section InstsFiltered :-
+ coq.env.current-section-path SectionPath,
+ std.findall (instance SectionPath _ _) Insts,
+ coq.env.section SectionVars,
+ std.map-filter Insts (x\r\ sigma X\ instance _ r _ = x, const X = r, not(std.mem SectionVars X)) InstsFiltered.
+
+pred is-instance-gr i:gref.
+is-instance-gr GR :-
+ coq.env.typeof GR Ty,
+ is-instance-term Ty.
+
+pred is-instance-term i:term.
+is-instance-term T :-
+ get-TC-of-inst-type T TC,
+ coq.TC.class? TC.
+
+% adds a clause to the tc.db DB at the passed grafting
+pred add-tc-db o:id, o:grafting, i:prop.
+add-tc-db ClauseName Graft PR :-
+ coq.elpi.accumulate _ "tc.db"
+ (clause ClauseName Graft PR); coq.error "cannot add " PR " to tc.db".
+
+% takes a tc-instance and return the gref of the inst
+pred inst->gref i:tc-instance, o:gref.
+inst->gref (tc-instance Res _) Res.
+
+% returns all the instances of the passed ClassName
+pred get-inst-by-tc-name i:gref, o:list gref.
+get-inst-by-tc-name TC GRL:-
+ coq.TC.db-for TC Inst,
+ std.map Inst inst->gref GRL',
+ std.rev GRL' GRL.
+
+pred app-has-class i:term.
+app-has-class T :-
+ get-TC-of-inst-type T Hd,
+ coq.TC.class? Hd.
+
+% input (∀ a, b, c ... => app [A, B, ..., Last])
+% returns Last
+pred get-last i:term, o:term.
+get-last (prod _ _ Bo) R :-
+ pi x\ get-last (Bo x) R.
+get-last (app L) R :-
+ std.last L R.
+
+% TC preds are on the form tc-[PATH_TO_TC].tc-[TC-Name]
+pred gref->pred-name i:gref, o:string.
+gref->pred-name Gr S :-
+ if (is-option-active {oTC-clauseNameShortName})
+ (Path = "")
+ (coq.gref->path Gr [Hd | Tl],
+ std.fold Tl Hd (x\acc\r\ r is acc ^ "." ^ x) Path',
+ Path is Path' ^ ".tc-"),
+ S is "tc-" ^ Path ^ {coq.gref->id Gr}.
+
+pred no-backtrack i:list prop, o:list prop.
+no-backtrack [] [].
+no-backtrack [do X | XS] [std.do! [(std.do! X') | XS']] :- !,
+ no-backtrack X X', no-backtrack XS XS'.
+no-backtrack [X | XS] [std.do! [X | XS']] :- !, no-backtrack XS XS'.
+
+pred make-tc i:prop, i:term, i:term, i:list prop, o:prop.
+make-tc _IsHead Ty Inst Hyp Clause :-
+ coq.safe-dest-app Ty (global TC) TL,
+ gref->pred-name TC TC_Str,
+ std.append TL [Inst] Args,
+ coq.elpi.predicate TC_Str Args Q,
+ if2 (Hyp = []) (Clause = Q)
+ (Hyp = [Hd]) (Clause = (Q :- Hd))
+ (Clause = (Q :- Hyp)).
+
+% returns the priority of an instance from the gref of an instance
+pred get-inst-prio i:gref, o:int.
+get-inst-prio InstGr Prio :-
+ coq.env.typeof InstGr InstTy,
+ get-TC-of-inst-type InstTy TC,
+ find-opt {coq.TC.db-for TC}
+ (x\ tc-instance InstGr (tc-priority-given Prio) = x ;
+ tc-instance InstGr (tc-priority-computed Prio) = x)
+ (some _), !.
+get-inst-prio _ 0.
+
+% TODO: @FissoreD improve this method complexity
+pred get-full-path i:gref, o:string.
+% :if "get-full-path"
+get-full-path Gr Res' :-
+ coq.gref->string Gr Path,
+ coq.env.current-section-path SectionPath,
+ std.fold SectionPath "" (e\acc\r\ r is acc ^ "." ^ e) Res,
+ Res' is Res ^ Path.
+% get-full-path _ _.
\ No newline at end of file
diff --git a/apps/tc/examples/tutorial.v b/apps/tc/examples/tutorial.v
new file mode 100644
index 000000000..2379c2a46
--- /dev/null
+++ b/apps/tc/examples/tutorial.v
@@ -0,0 +1,96 @@
+Require Import Bool.
+From elpi.apps Require Import tc.
+
+Class Eqb (T: Type) := {
+ eqb : T -> T -> bool;
+ eqb_leibniz A B: eqb A B = true <-> A = B
+}.
+
+#[refine] Instance eqBool : Eqb bool := {
+ eqb x y := if x then y else negb y
+}.
+Proof. intros [] []; intuition. Qed.
+
+#[refine] Instance eqProd (A B : Type) : Eqb A -> Eqb B -> Eqb (A * B) := {
+ eqb x y := eqb (fst x) (fst y) && eqb (snd x) (snd y)
+}.
+Proof.
+ intros [] []. split. intros; simpl in H.
+ * case (eqb a a0) eqn:aB, (eqb b b0) eqn:bB; try easy.
+ apply pair_equal_spec; destruct e, e0; split.
+ apply eqb_leibniz0; auto.
+ apply eqb_leibniz1; auto.
+ * intros. apply pair_equal_spec in H; destruct H; subst. simpl.
+ apply andb_true_intro; destruct e, e0; split.
+ apply eqb_leibniz0; auto.
+ apply eqb_leibniz1; auto.
+Qed.
+
+TC.Print_instances.
+TC.Get_class_info Eqb.
+
+(* Abstraction of elpi context variable *)
+Section Foo.
+ Variable (A B: Type) (HA : Eqb A) (HB : Eqb B).
+ #[refine] Global Instance eqProd' : Eqb (A * B) := {
+ eqb x y := eqb (fst x) (fst y) && eqb (snd x) (snd y)
+ }.
+ Proof.
+ intros [] []; simpl; split; intros.
+ apply eqb_leibniz. destruct H.
+ replace (eqb (a, b) (a0, b0)) with (eqb a a0 && eqb b b0); auto. admit.
+ apply andb_true_intro; apply pair_equal_spec in H; split;
+ apply eqb_leibniz; easy.
+ Admitted.
+
+ (* Here we see that HA and HB are compiled in elpi since their type is a class *)
+ TC.Print_instances Eqb.
+
+ (* The rules for eqProd' is as follows
+
+ shorten tc-tutorial.{tc-Eqb}.
+ tc-Eqb {{prod A B}} {{eqProd'}}.
+
+ Remark: Here A and B are not elpi variables, but the coq variables from the
+ context
+ *)
+
+ Elpi Print TC.Solver.
+End Foo.
+
+(*
+ On section end the local instances are removed (i.e. HA and HB disappears)
+ and eqProd' is recompiled
+*)
+TC.Print_instances Eqb.
+(*
+ the rules for eqProd' is as follows
+
+ shorten tc-tutorial.{tc-Eqb}.
+ tc-Eqb {{prod lp:A lp:B}} {{eqProd' lp:A lp:B lp:PA lp:PB}} :-
+ tc-Eqb A PA, tc-Eqb B PB.
+
+ Remark: Here A and B are elpi variables and PA, PB are the proof that we can
+ prove {{Eqb lp:A}} and {{Eqb lp:B}}
+*)
+
+TC.Get_class_info Eqb.
+
+Module Backtrack.
+ Elpi Override TC TC.Solver All.
+ Class NoBacktrack (n: nat).
+ TC.Set_deterministic NoBacktrack.
+ Class A (n: nat).
+
+ Instance a0 : A 0. Qed.
+ Instance nb0 : NoBacktrack 0. Qed.
+ Instance nb1 : NoBacktrack 1. Qed.
+ Instance a3 n : NoBacktrack n -> A n -> A 3. Qed.
+
+ Goal A 3. Fail apply _. Abort.
+
+ Elpi Print TC.Solver.
+End Backtrack.
+
+TC.Print_instances.
+TC.Get_class_info DecidableClass.Decidable.
diff --git a/apps/tc/src/META.coq-elpi-tc b/apps/tc/src/META.coq-elpi-tc
new file mode 100644
index 000000000..5c3045ab8
--- /dev/null
+++ b/apps/tc/src/META.coq-elpi-tc
@@ -0,0 +1,10 @@
+
+package "plugin" (
+ directory = "."
+ requires = "coq-core.plugins.ltac coq-elpi.elpi"
+ archive(byte) = "elpi_tc_plugin.cma"
+ archive(native) = "elpi_tc_plugin.cmxa"
+ plugin(byte) = "elpi_tc_plugin.cma"
+ plugin(native) = "elpi_tc_plugin.cmxs"
+)
+directory = "."
diff --git a/apps/tc/src/coq_elpi_class_tactics_hacked.ml b/apps/tc/src/coq_elpi_class_tactics_hacked.ml
new file mode 100644
index 000000000..1b9ff8113
--- /dev/null
+++ b/apps/tc/src/coq_elpi_class_tactics_hacked.ml
@@ -0,0 +1,1319 @@
+(************************************************************************)
+(* * The Coq Proof Assistant / The Coq Development Team *)
+(* v * Copyright INRIA, CNRS and contributors *)
+(* (unit -> Pp.t) -> unit
+
+ val get_debug : unit -> int
+
+ val set_typeclasses_debug : bool -> unit
+end = struct
+ let typeclasses_debug = ref 0
+
+ let set_typeclasses_debug d = (:=) typeclasses_debug (if d then 1 else 0)
+ let get_typeclasses_debug () = if !typeclasses_debug > 0 then true else false
+
+ let set_typeclasses_verbose = function
+ | None -> typeclasses_debug := 0
+ | Some n -> typeclasses_debug := n
+ let get_typeclasses_verbose () =
+ if !typeclasses_debug = 0 then None else Some !typeclasses_debug
+
+ let () =
+ let open Goptions in
+ declare_bool_option
+ { optstage = Summary.Stage.Interp;
+ optdepr = None;
+ optkey = ["Typeclassess";"Debug"];
+ optread = get_typeclasses_debug;
+ optwrite = set_typeclasses_debug; }
+
+ let () =
+ let open Goptions in
+ declare_int_option
+ { optstage = Summary.Stage.Interp;
+ optdepr = None;
+ optkey = ["Typeclassess";"Debug";"Verbosity"];
+ optread = get_typeclasses_verbose;
+ optwrite = set_typeclasses_verbose; }
+
+ let ppdebug lvl pp =
+ if !typeclasses_debug > lvl then Feedback.msg_debug (pp())
+
+ let get_debug () = !typeclasses_debug
+end
+open Debug
+let set_typeclasses_debug = set_typeclasses_debug
+
+type search_strategy = Dfs | Bfs
+
+let set_typeclasses_strategy = function
+ | Dfs -> Goptions.set_bool_option_value iterative_deepening_opt_name false
+ | Bfs -> Goptions.set_bool_option_value iterative_deepening_opt_name true
+
+let pr_ev evs ev =
+ let evi = Evd.find_undefined evs ev in
+ let env = Evd.evar_filtered_env (Global.env ()) evi in
+ Printer.pr_econstr_env env evs (Evd.evar_concl evi)
+
+let pr_ev_with_id evs ev =
+ Evar.print ev ++ str " : " ++ pr_ev evs ev
+
+ (** Typeclasses instance search tactic / eauto *)
+
+open Auto
+open Unification
+
+let auto_core_unif_flags st allowed_evars = {
+ modulo_conv_on_closed_terms = Some st;
+ use_metas_eagerly_in_conv_on_closed_terms = true;
+ use_evars_eagerly_in_conv_on_closed_terms = false;
+ modulo_delta = st;
+ modulo_delta_types = st;
+ check_applied_meta_types = false;
+ use_pattern_unification = true;
+ use_meta_bound_pattern_unification = true;
+ allowed_evars;
+ restrict_conv_on_strict_subterms = false; (* ? *)
+ modulo_betaiota = true;
+ modulo_eta = false;
+}
+
+let auto_unif_flags ?(allowed_evars = Evarsolve.AllowedEvars.all) st =
+ let fl = auto_core_unif_flags st allowed_evars in
+ { core_unify_flags = fl;
+ merge_unify_flags = fl;
+ subterm_unify_flags = fl;
+ allow_K_in_toplevel_higher_order_unification = false;
+ resolve_evars = false
+}
+
+let e_give_exact flags h =
+ let open Tacmach in
+ Proofview.Goal.enter begin fun gl ->
+ let env = Proofview.Goal.env gl in
+ let sigma = project gl in
+ let sigma, c = Hints.fresh_hint env sigma h in
+ let (sigma, t1) = Typing.type_of (pf_env gl) sigma c in
+ Proofview.Unsafe.tclEVARS sigma <*>
+ Clenv.unify ~flags t1 <*> exact_no_check c
+ end
+
+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 (Option.is_empty (fst @@ hint_as_term @@ h)) in
+ Proofview.Goal.enter begin fun gl ->
+ let env = Proofview.Goal.env gl in
+ let sigma = Tacmach.project gl in
+ let sigma, c = Hints.fresh_hint env sigma h in
+ let clenv = Clenv.mk_clenv_from_n env sigma diff (c, ty) in
+ Clenv.res_pf ~with_evars ~with_classes:false ~flags clenv
+ end
+
+(** Dealing with goals of the form A -> B and hints of the form
+ C -> A -> B.
+*)
+let with_prods nprods h f =
+ if get_typeclasses_limit_intros () then
+ Proofview.Goal.enter begin fun gl ->
+ if Option.has_some (fst @@ hint_as_term h) || Int.equal nprods 0 then f None
+ else
+ let sigma = Tacmach.project gl in
+ let ty = Retyping.get_type_of (Proofview.Goal.env gl) sigma (snd @@ hint_as_term h) in
+ let diff = nb_prod sigma ty - nprods in
+ if (>=) diff 0 then f (Some (diff, ty))
+ else Tacticals.tclZEROMSG (str"Not enough premisses")
+ end
+ else Proofview.Goal.enter
+ begin fun gl ->
+ if Int.equal nprods 0 then f None
+ else Tacticals.tclZEROMSG (str"Not enough premisses") end
+
+(** Semantics of type class resolution lemma application:
+
+ - Use unification to find a well-typed substitution. There might
+ be evars in the goal and the lemma. Evars in the goal can get refined.
+ - Independent evars are turned into goals, whatever their kind is.
+ - Dependent evars of the lemma corresponding to arguments which appear
+ in independent goals or the conclusion are turned into subgoals iff
+ they are of typeclass kind.
+ - The remaining dependent evars not of typeclass type are shelved,
+ and resolution must fill them for it to succeed, otherwise we
+ backtrack.
+ *)
+
+let pr_gls sigma gls =
+ prlist_with_sep spc
+ (fun ev -> int (Evar.repr ev) ++ spc () ++ pr_ev sigma ev) gls
+
+(** Ensure the dependent subgoals are shelved after an apply/eapply. *)
+let shelve_dependencies gls =
+ let open Proofview in
+ if CList.is_empty gls then tclUNIT ()
+ else
+ tclEVARMAP >>= fun sigma ->
+ ppdebug 1 (fun () -> str" shelving dependent subgoals: " ++ pr_gls sigma gls);
+ shelve_goals gls
+
+let hintmap_of env sigma hdc secvars concl =
+ match hdc with
+ | None -> fun db -> ModeMatch (NoMode, Hint_db.map_none ~secvars db)
+ | Some hdc ->
+ fun db -> Hint_db.map_eauto env sigma ~secvars hdc concl db
+
+(** Hack to properly solve dependent evars that are typeclasses *)
+let rec e_trivial_fail_db only_classes db_list local_db secvars =
+ let open Tacticals in
+ let open Tacmach in
+ let trivial_fail =
+ Proofview.Goal.enter
+ begin fun gl ->
+ let env = Proofview.Goal.env gl in
+ let sigma = Tacmach.project gl in
+ let d = NamedDecl.get_id @@ pf_last_hyp gl in
+ let hints = push_resolve_hyp env sigma d local_db in
+ e_trivial_fail_db only_classes db_list hints secvars
+ end
+ in
+ let trivial_resolve =
+ Proofview.Goal.enter
+ begin fun gl ->
+ let tacs = e_trivial_resolve db_list local_db secvars only_classes
+ (pf_env gl) (project gl) (pf_concl gl) in
+ tclFIRST (List.map (fun (x,_,_,_,_) -> x) tacs)
+ end
+ in
+ let tacl =
+ Eauto.e_assumption ::
+ (tclTHEN Tactics.intro trivial_fail :: [trivial_resolve])
+ in
+ tclSOLVE tacl
+
+and e_my_find_search db_list local_db secvars hdc complete only_classes env sigma concl0 =
+ let prods, concl = EConstr.decompose_prod_decls sigma concl0 in
+ let nprods = List.length prods in
+ let allowed_evars =
+ let all = Evarsolve.AllowedEvars.all in
+ try
+ match hdc with
+ | Some (hd,_) when only_classes ->
+ begin match Typeclasses.class_info hd with
+ | Some cl ->
+ if cl.cl_strict then
+ let undefined = lazy (Evarutil.undefined_evars_of_term sigma concl) in
+ let allowed evk = not (Evar.Set.mem evk (Lazy.force undefined)) in
+ Evarsolve.AllowedEvars.from_pred allowed
+ else all
+ | None -> all
+ end
+ | _ -> all
+ with e when CErrors.noncritical e -> all
+ in
+ let tac_of_hint =
+ fun (flags, h) ->
+ let name = FullHint.name h in
+ let tac = function
+ | Res_pf h ->
+ let tac =
+ with_prods nprods h (unify_resolve ~with_evars:false flags h) in
+ Proofview.tclBIND (Proofview.with_shelf tac)
+ (fun (gls, ()) -> shelve_dependencies gls)
+ | ERes_pf h ->
+ let tac =
+ with_prods nprods h (unify_resolve ~with_evars:true flags h) in
+ Proofview.tclBIND (Proofview.with_shelf tac)
+ (fun (gls, ()) -> shelve_dependencies gls)
+ | Give_exact h ->
+ e_give_exact flags h
+ | Res_pf_THEN_trivial_fail h ->
+ let fst = with_prods nprods h (unify_resolve ~with_evars:true flags h) in
+ let snd = if complete then Tacticals.tclIDTAC
+ else e_trivial_fail_db only_classes db_list local_db secvars in
+ Tacticals.tclTHEN fst snd
+ | Unfold_nth c ->
+ Proofview.tclPROGRESS (unfold_in_concl [AllOccurrences,c])
+ | Extern (p, tacast) -> conclPattern concl0 p tacast
+ in
+ let tac = FullHint.run h tac in
+ let tac = if complete then Tacticals.tclCOMPLETE tac else tac in
+ let extern = match FullHint.repr h with
+ | Extern _ -> true
+ | _ -> false
+ in
+ (tac, FullHint.priority h, extern, name, lazy (FullHint.print env sigma h))
+ in
+ let hint_of_db = hintmap_of env sigma hdc secvars concl in
+ let hintl = List.map_filter (fun db -> match hint_of_db db with
+ | ModeMatch (m, l) -> Some (db, m, l)
+ | ModeMismatch -> None)
+ (local_db :: db_list)
+ in
+ (* In case there is a mode mismatch in all the databases we get stuck.
+ Otherwise we consider the hints that match.
+ Recall the local database uses the union of all the modes in the other databases. *)
+ if List.is_empty hintl then None
+ else
+ let hintl =
+ CList.map
+ (fun (db, m, tacs) ->
+ let flags = auto_unif_flags ~allowed_evars (Hint_db.transparent_state db) in
+ m, List.map (fun x -> tac_of_hint (flags, x)) tacs)
+ hintl
+ in
+ let modes, hintl = List.split hintl in
+ let all_mode_match = List.for_all (fun m -> m != NoMode) modes in
+ let hintl = match hintl with
+ (* Optim: only sort if multiple hint sources were involved *)
+ | [hintl] -> hintl
+ | _ ->
+ let hintl = List.flatten hintl in
+ let hintl = List.stable_sort
+ (fun (_, pri1, _, _, _) (_, pri2, _, _, _) -> Int.compare pri1 pri2)
+ hintl
+ in
+ hintl
+ in
+ Some (all_mode_match, hintl)
+
+and e_trivial_resolve db_list local_db secvars only_classes env sigma concl =
+ let hd = try Some (decompose_app_bound sigma concl) with Bound -> None in
+ try
+ (match e_my_find_search db_list local_db secvars hd true only_classes env sigma concl with
+ | Some (_,l) -> l
+ | None -> [])
+ with Not_found -> []
+
+let e_possible_resolve db_list local_db secvars only_classes env sigma concl =
+ let hd = try Some (decompose_app_bound sigma concl) with Bound -> None in
+ try
+ e_my_find_search db_list local_db secvars hd false only_classes env sigma concl
+ with Not_found -> Some (true, [])
+
+let cut_of_hints h =
+ List.fold_left (fun cut db -> PathOr (Hint_db.cut db, cut)) PathEmpty h
+
+let pr_depth l =
+ let rec fmt elts =
+ match elts with
+ | [] -> []
+ | [n] -> [string_of_int n]
+ | n1::n2::rest ->
+ (string_of_int n1 ^ "." ^ string_of_int n2) :: fmt rest
+ in
+ prlist_with_sep (fun () -> str "-") str (fmt (List.rev l))
+
+let is_Prop env sigma concl =
+ let ty = Retyping.get_type_of env sigma concl in
+ match EConstr.kind sigma ty with
+ | Sort s ->
+ begin match ESorts.kind sigma s with
+ | Prop -> true
+ | _ -> false
+ end
+ | _ -> false
+
+let is_unique env sigma concl =
+ try
+ let (cl,u), args = dest_class_app env sigma concl in
+ cl.cl_unique
+ with e when CErrors.noncritical e -> false
+
+(** Sort the undefined variables from the least-dependent to most dependent. *)
+let top_sort evm undefs =
+ let l' = ref [] in
+ let tosee = ref undefs in
+ let cache = Evarutil.create_undefined_evars_cache () in
+ let rec visit ev evi =
+ let evs = Evarutil.filtered_undefined_evars_of_evar_info ~cache evm evi in
+ tosee := Evar.Set.remove ev !tosee;
+ Evar.Set.iter (fun ev ->
+ if Evar.Set.mem ev !tosee then
+ visit ev (Evd.find_undefined evm ev)) evs;
+ l' := ev :: !l';
+ in
+ while not (Evar.Set.is_empty !tosee) do
+ let ev = Evar.Set.choose !tosee in
+ visit ev (Evd.find_undefined evm ev)
+ done;
+ List.rev !l'
+
+(** We transform the evars that are concerned by this resolution
+ (according to predicate p) into goals.
+ Invariant: function p only manipulates and returns undefined evars
+*)
+
+let evars_to_goals p evm =
+ let goals, nongoals = Evar.Set.partition (p evm) (Evd.get_typeclass_evars evm) in
+ if Evar.Set.is_empty goals then None
+ else Some (goals, nongoals)
+
+(** Making local hints *)
+let make_resolve_hyp env sigma st only_classes decl db =
+ let id = NamedDecl.get_id decl in
+ let cty = Evarutil.nf_evar sigma (NamedDecl.get_type decl) in
+ let rec iscl env ty =
+ let ctx, ar = decompose_prod_decls sigma ty in
+ match EConstr.kind sigma (fst (decompose_app sigma ar)) with
+ | Const (c,_) -> is_class (GlobRef.ConstRef c)
+ | Ind (i,_) -> is_class (GlobRef.IndRef i)
+ | _ ->
+ let env' = push_rel_context ctx env in
+ let ty' = Reductionops.whd_all env' sigma ar in
+ if not (EConstr.eq_constr sigma ty' ar) then iscl env' ty'
+ else false
+ in
+ let is_class = iscl env cty in
+ let keep = not only_classes || is_class in
+ if keep then
+ let id = GlobRef.VarRef id in
+ push_resolves env sigma id db
+ else db
+
+let make_hints env sigma (modes,st) only_classes sign =
+ let db = Hint_db.add_modes modes @@ Hint_db.empty st true in
+ List.fold_right
+ (fun hyp hints ->
+ let consider =
+ not only_classes ||
+ try let t = hyp |> NamedDecl.get_id |> Global.lookup_named |> NamedDecl.get_type in
+ (* Section variable, reindex only if the type changed *)
+ not (EConstr.eq_constr sigma (EConstr.of_constr t) (NamedDecl.get_type hyp))
+ with Not_found -> true
+ in
+ if consider then
+ make_resolve_hyp env sigma st only_classes hyp hints
+ else hints)
+ sign db
+
+module Search = struct
+ type autoinfo =
+ { search_depth : int list;
+ last_tac : Pp.t Lazy.t;
+ search_dep : bool;
+ search_only_classes : bool;
+ search_cut : hints_path;
+ search_hints : hint_db;
+ search_best_effort : bool;
+ }
+
+ (** Local hints *)
+ let autogoal_cache = Summary.ref ~name:"autogoal_cachee"
+ (DirPath.empty, true, Context.Named.empty, GlobRef.Map.empty,
+ Hint_db.empty TransparentState.full true)
+
+ let make_autogoal_hints only_classes (modes,st as mst) gl =
+ let env = Proofview.Goal.env gl in
+ let sigma = Proofview.Goal.sigma gl in
+ let sign = EConstr.named_context env in
+ let (dir, onlyc, sign', cached_modes, cached_hints) = !autogoal_cache in
+ let cwd = Lib.cwd () in
+ let eq c1 c2 = EConstr.eq_constr sigma c1 c2 in
+ if DirPath.equal cwd dir &&
+ (onlyc == only_classes) &&
+ Context.Named.equal eq sign sign' &&
+ cached_modes == modes
+ then cached_hints
+ else
+ let hints = make_hints env sigma mst only_classes sign in
+ autogoal_cache := (cwd, only_classes, sign, modes, hints); hints
+
+ let make_autogoal mst only_classes dep cut best_effort i g =
+ let hints = make_autogoal_hints only_classes mst g in
+ { search_hints = hints;
+ search_depth = [i]; last_tac = lazy (str"none");
+ search_dep = dep;
+ search_only_classes = only_classes;
+ search_cut = cut;
+ search_best_effort = best_effort }
+
+ (** In the proof engine failures are represented as exceptions *)
+ exception ReachedLimit
+ exception NoApplicableHint
+ exception StuckGoal
+
+ (** ReachedLimit has priority over NoApplicableHint to handle
+ iterative deepening: it should fail when no hints are applicable,
+ but go to a deeper depth otherwise. *)
+ let merge_exceptions e e' =
+ match fst e, fst e' with
+ | ReachedLimit, _ -> e
+ | _, ReachedLimit -> e'
+ | _, _ -> e
+
+ (** Determine if backtracking is needed for this goal.
+ If the type class is unique or in Prop
+ and there are no evars in the goal then we do
+ NOT backtrack. *)
+ let needs_backtrack env evd unique concl =
+ if unique || is_Prop env evd concl then
+ occur_existential evd concl
+ else true
+
+ exception NonStuckFailure
+ (* exception Backtrack *)
+
+ let pr_goals s =
+ let open Proofview in
+ if get_debug() > 1 then
+ tclEVARMAP >>= fun sigma ->
+ Unsafe.tclGETGOALS >>= fun gls ->
+ let gls = CList.map Proofview.drop_state gls in
+ let j = List.length gls in
+ let pr_goal gl = pr_ev_with_id sigma gl in
+ Feedback.msg_debug
+ (s ++ int j ++ str" goals:" ++ spc () ++
+ prlist_with_sep Pp.fnl pr_goal gls);
+ tclUNIT ()
+ else
+ tclUNIT ()
+
+ let _ = CErrors.register_handler begin function
+ | NonStuckFailure -> Some (str "NonStuckFailure")
+ | NoApplicableHint -> Some (str "NoApplicableHint")
+ | _ -> None
+ end
+
+ (**
+ For each success of tac1 try tac2.
+ If tac2 raises NonStuckFailure, try the next success of tac1 until depleted.
+ If tac1 finally fails, returns the result of the first tac1 success, if any.
+ *)
+
+ type goal_status =
+ | IsInitial
+ | IsStuckGoal
+ | IsNonStuckFailure
+
+ let pr_goal_status = function
+ | IsInitial -> str "initial"
+ | IsStuckGoal -> str "stuck"
+ | IsNonStuckFailure -> str "stuck failure"
+
+
+ let pr_search_goal sigma (glid, ev, status, _) =
+ str"Goal " ++ int glid ++ str" evar: " ++ Evar.print ev ++ str " status: " ++ pr_goal_status status
+
+ let pr_search_goals sigma =
+ prlist_with_sep fnl (pr_search_goal sigma)
+
+ let search_fixpoint ~best_effort ~allow_out_of_order tacs =
+ let open Pp in
+ let open Proofview in
+ let open Proofview.Notations in
+ let rec fixpoint progress tacs stuck fk =
+ let next (glid, ev, status, tac) tacs stuck =
+ let () = ppdebug 1 (fun () ->
+ str "considering goal " ++ int glid ++
+ str " of status " ++ pr_goal_status status)
+ in
+ let rec kont = function
+ | Fail ((NonStuckFailure | StuckGoal as exn), info) when allow_out_of_order ->
+ let () = ppdebug 1 (fun () ->
+ str "Goal " ++ int glid ++
+ str" is stuck or failed without being stuck, trying other tactics.")
+ in
+ let status =
+ match exn with
+ | NonStuckFailure -> IsNonStuckFailure
+ | StuckGoal -> IsStuckGoal
+ | _ -> assert false
+ in
+ cycle 1 (* Puts the first goal last *) <*>
+ fixpoint progress tacs ((glid, ev, status, tac) :: stuck) fk (* Launches the search on the rest of the goals *)
+ | Fail (e, info) ->
+ let () = ppdebug 1 (fun () ->
+ str "Goal " ++ int glid ++ str" has no more solutions, returning exception: "
+ ++ CErrors.iprint (e, info))
+ in
+ fk (e, info)
+ | Next (res, fk') ->
+ let () = ppdebug 1 (fun () ->
+ str "Goal " ++ int glid ++ str" has a success, continuing resolution")
+ in
+ (* We try to solve the rest of the constraints, and if that fails
+ we backtrack to the next result of tac, etc.... Ultimately if none of the solutions
+ for tac work, we will come back to the failure continuation fk in one of
+ the above cases *)
+ fixpoint true tacs stuck (fun e -> tclCASE (fk' e) >>= kont)
+ in tclCASE tac >>= kont
+ in
+ tclEVARMAP >>= fun sigma ->
+ let () = ppdebug 1 (fun () ->
+ let stuck, failed = List.partition (fun (_, _, status, _) -> status = IsStuckGoal) stuck in
+ str"Calling fixpoint on : " ++
+ int (List.length tacs) ++ str" initial goals" ++
+ str", " ++ int (List.length stuck) ++ str" stuck goals" ++
+ str" and " ++ int (List.length failed) ++ str" non-stuck failures kept" ++
+ str" with " ++ str(if progress then "" else "no ") ++
+ str"progress made in this run." ++ fnl () ++
+ str "Stuck: " ++ pr_search_goals sigma stuck ++ fnl () ++
+ str "Failed: " ++ pr_search_goals sigma failed ++ fnl () ++
+ str "Initial: " ++ pr_search_goals sigma tacs)
+ in
+ tclCHECKINTERRUPT <*>
+ match tacs with
+ | tac :: tacs -> next tac tacs stuck
+ | [] -> (* All remaining goals are stuck *)
+ match stuck with
+ | [] ->
+ (* We found a solution! Great, but in case it's not good for the rest of the proof search,
+ we might have other solutions available through fk. *)
+ tclOR (tclUNIT ()) fk
+ | stuck ->
+ if progress then fixpoint false stuck [] fk
+ else (* No progress can be made on the stuck goals arising from this resolution,
+ try a different solution on the non-stuck goals, if any. *)
+ begin
+ tclORELSE (fk (NoApplicableHint, Exninfo.null))
+ (fun (e, info) ->
+ let () = ppdebug 1 (fun () -> int (List.length stuck) ++ str " remaining goals left, no progress, calling continuation failed")
+ in
+ (* We keep the stuck goals to display to the user *)
+ if best_effort then
+ let stuckgls, failedgls = List.partition (fun (_, _, status, _) ->
+ match status with
+ | IsStuckGoal -> true
+ | IsNonStuckFailure -> false
+ (* There should remain no initial goals at this point *)
+ | IsInitial -> assert false)
+ stuck
+ in
+ pr_goals (str "best_effort is on and remaining goals are: ") <*>
+ (* We shelve the stuck goals but we keep the non-stuck failures in the goal list.
+ This is for compat with Coq 8.12 but might not be the wisest choice in the long run.
+ *)
+ let to_shelve = List.map (fun (glid, ev, _, _) -> ev) stuckgls in
+ let () = ppdebug 1 (fun () ->
+ str "Shelving subgoals: " ++
+ prlist_with_sep spc Evar.print to_shelve)
+ in
+ Unsafe.tclNEWSHELVED to_shelve
+ else tclZERO ~info e)
+ end
+ in
+ pr_goals (str"Launching resolution fixpoint on ") <*>
+ Unsafe.tclGETGOALS >>= fun gls ->
+ (* We wrap all goals with their associated tactic.
+ It might happen that an initial goal is solved during the resolution of another goal,
+ hence the `tclUNIT` in case there is no goal for the tactic to apply anymore. *)
+ let tacs = List.map2_i
+ (fun i gls tac -> (succ i, Proofview.drop_state gls, IsInitial, tclFOCUS ~nosuchgoal:(tclUNIT ()) 1 1 tac))
+ 0 gls tacs
+ in
+ fixpoint false tacs [] (fun (e, info) -> tclZERO ~info e) <*>
+ pr_goals (str "Result goals after fixpoint: ")
+
+
+ (** The general hint application tactic.
+ tac1 + tac2 .... The choice of OR or ORELSE is determined
+ depending on the dependencies of the goal and the unique/Prop
+ status *)
+ let hints_tac_gl hints info kont gl : unit Proofview.tactic =
+ let open Proofview in
+ let open Proofview.Notations in
+ let env = Goal.env gl in
+ let concl = Goal.concl gl in
+ let sigma = Goal.sigma gl in
+ let unique = not info.search_dep || is_unique env sigma concl in
+ let backtrack = needs_backtrack env sigma unique concl in
+ let () = ppdebug 0 (fun () ->
+ pr_depth info.search_depth ++ str": looking for " ++
+ Printer.pr_econstr_env (Goal.env gl) sigma concl ++
+ (if backtrack then str" with backtracking"
+ else str" without backtracking"))
+ in
+ let secvars = compute_secvars gl in
+ match e_possible_resolve hints info.search_hints secvars
+ info.search_only_classes env sigma concl with
+ | None ->
+ Proofview.tclZERO StuckGoal
+ | Some (all_mode_match, poss) ->
+ (* If no goal depends on the solution of this one or the
+ instances are irrelevant/assumed to be unique, then
+ we don't need to backtrack, as long as no evar appears in the goal
+ This is an overapproximation. Evars could appear in this goal only
+ and not any other *)
+ let ortac = if backtrack then Proofview.tclOR else Proofview.tclORELSE in
+ let idx = ref 1 in
+ let foundone = ref false in
+ let rec onetac e (tac, pat, b, name, pp) tl =
+ let derivs = path_derivate info.search_cut name in
+ let pr_error ie =
+ ppdebug 1 (fun () ->
+ let idx = if fst ie == NoApplicableHint then pred !idx else !idx in
+ let header =
+ pr_depth (idx :: info.search_depth) ++ str": " ++
+ Lazy.force pp ++
+ (if !foundone != true then
+ str" on" ++ spc () ++ pr_ev sigma (Proofview.Goal.goal gl)
+ else mt ())
+ in
+ let msg =
+ match fst ie with
+ | ReachedLimit -> str "Proof-search reached its limit."
+ | NoApplicableHint -> str "Proof-search failed."
+ | StuckGoal | NonStuckFailure -> str "Proof-search got stuck."
+ | e -> CErrors.iprint ie
+ in
+ (header ++ str " failed with: " ++ msg))
+ in
+ let tac_of gls i j = Goal.enter begin fun gl' ->
+ let sigma' = Goal.sigma gl' in
+ let () = ppdebug 0 (fun () ->
+ pr_depth (succ j :: i :: info.search_depth) ++ str" : " ++
+ pr_ev sigma' (Proofview.Goal.goal gl'))
+ in
+ let eq c1 c2 = EConstr.eq_constr sigma' c1 c2 in
+ let hints' =
+ if b && not (Context.Named.equal eq (Goal.hyps gl') (Goal.hyps gl))
+ then
+ let st = Hint_db.transparent_state info.search_hints in
+ let modes = Hint_db.modes info.search_hints in
+ make_autogoal_hints info.search_only_classes (modes,st) gl'
+ else info.search_hints
+ in
+ let dep' = info.search_dep || Proofview.unifiable sigma' (Goal.goal gl') gls in
+ let info' =
+ { search_depth = succ j :: i :: info.search_depth;
+ last_tac = pp;
+ search_dep = dep';
+ search_only_classes = info.search_only_classes;
+ search_hints = hints';
+ search_cut = derivs;
+ search_best_effort = info.search_best_effort }
+ in kont info' end
+ in
+ let rec result (shelf, ()) i k =
+ foundone := true;
+ Proofview.Unsafe.tclGETGOALS >>= fun gls ->
+ let gls = CList.map Proofview.drop_state gls in
+ let j = List.length gls in
+ let () = ppdebug 0 (fun () ->
+ pr_depth (i :: info.search_depth) ++ str": " ++ Lazy.force pp
+ ++ str" on" ++ spc () ++ pr_ev sigma (Proofview.Goal.goal gl)
+ ++ str", " ++ int j ++ str" subgoal(s)" ++
+ (Option.cata (fun k -> str " in addition to the first " ++ int k)
+ (mt()) k))
+ in
+ let res =
+ if j = 0 then tclUNIT ()
+ else search_fixpoint ~best_effort:false ~allow_out_of_order:false
+ (List.init j (fun j' -> (tac_of gls i (Option.default 0 k + j'))))
+ in
+ let finish nestedshelf sigma =
+ let filter ev =
+ try
+ let evi = Evd.find_undefined sigma ev in
+ if info.search_only_classes then
+ Some (ev, not (is_class_evar sigma evi))
+ else Some (ev, true)
+ with Not_found -> None
+ in
+ let remaining = CList.map_filter filter shelf in
+ let () = ppdebug 1 (fun () ->
+ let prunsolved (ev, _) = int (Evar.repr ev) ++ spc () ++ pr_ev sigma ev in
+ let unsolved = prlist_with_sep spc prunsolved remaining in
+ pr_depth (i :: info.search_depth) ++
+ str": after " ++ Lazy.force pp ++ str" finished, " ++
+ int (List.length remaining) ++
+ str " goals are shelved and unsolved ( " ++
+ unsolved ++ str")")
+ in
+ begin
+ (* Some existentials produced by the original tactic were not solved
+ in the subgoals, turn them into subgoals now. *)
+ let shelved, goals = List.partition (fun (ev, s) -> s) remaining in
+ let shelved = List.map fst shelved @ nestedshelf and goals = List.map fst goals in
+ let () = if not (List.is_empty shelved && List.is_empty goals) then
+ ppdebug 1 (fun () ->
+ str"Adding shelved subgoals to the search: " ++
+ prlist_with_sep spc (pr_ev sigma) goals ++
+ str" while shelving " ++
+ prlist_with_sep spc (pr_ev sigma) shelved)
+ in
+ shelve_goals shelved <*>
+ if List.is_empty goals then tclUNIT ()
+ else
+ let make_unresolvables = tclEVARMAP >>= fun sigma ->
+ let sigma = make_unresolvables (fun x -> List.mem_f Evar.equal x goals) sigma in
+ Unsafe.tclEVARS sigma
+ in
+ let goals = CList.map Proofview.with_empty_state goals in
+ with_shelf (make_unresolvables <*> Unsafe.tclNEWGOALS goals) >>= fun s ->
+ result s i (Some (Option.default 0 k + j))
+ end
+ in
+ with_shelf res >>= fun (sh, ()) ->
+ tclEVARMAP >>= finish sh
+ in
+ if path_matches derivs [] then aux e tl
+ else
+ ortac
+ (with_shelf tac >>= fun s ->
+ let i = !idx in incr idx; result s i None)
+ (fun e' ->
+ (pr_error e'; aux (merge_exceptions e e') tl))
+ and aux e = function
+ | tac :: tacs -> onetac e tac tacs
+ | [] ->
+ let () = if !foundone == false then
+ ppdebug 0 (fun () ->
+ pr_depth info.search_depth ++ str": no match for " ++
+ Printer.pr_econstr_env (Goal.env gl) sigma concl ++
+ str ", " ++ int (List.length poss) ++
+ str" possibilities")
+ in
+ match e with
+ | (ReachedLimit,ie) -> Proofview.tclZERO ~info:ie ReachedLimit
+ | (StuckGoal,ie) -> Proofview.tclZERO ~info:ie StuckGoal
+ | (NoApplicableHint,ie) ->
+ (* If the constraint abides by the (non-trivial) modes but no
+ solution could be found, we consider it a failed goal, and let
+ proof search proceed on the rest of the
+ constraints, thus giving a more precise error message. *)
+ if all_mode_match &&
+ info.search_best_effort then
+ Proofview.tclZERO ~info:ie NonStuckFailure
+ else Proofview.tclZERO ~info:ie NoApplicableHint
+ | (_,ie) -> Proofview.tclZERO ~info:ie NoApplicableHint
+ in
+ if backtrack then aux (NoApplicableHint,Exninfo.null) poss
+ else tclONCE (aux (NoApplicableHint,Exninfo.null) poss)
+
+ let hints_tac hints info kont : unit Proofview.tactic =
+ Proofview.Goal.enter
+ (fun gl -> hints_tac_gl hints info kont gl)
+
+ let intro_tac info kont gl =
+ let open Proofview in
+ let env = Goal.env gl in
+ let sigma = Goal.sigma gl in
+ let decl = Tacmach.pf_last_hyp gl in
+ let ldb =
+ make_resolve_hyp env sigma (Hint_db.transparent_state info.search_hints)
+ info.search_only_classes decl info.search_hints in
+ let info' =
+ { info with search_hints = ldb; last_tac = lazy (str"intro");
+ search_depth = 1 :: 1 :: info.search_depth }
+ in kont info'
+
+ let intro info kont =
+ Proofview.tclBIND Tactics.intro
+ (fun _ -> Proofview.Goal.enter (fun gl -> intro_tac info kont gl))
+
+ let rec search_tac hints limit depth =
+ let kont info =
+ Proofview.numgoals >>= fun i ->
+ let () = ppdebug 1 (fun () ->
+ str "calling eauto recursively at depth " ++ int (succ depth) ++
+ str " on " ++ int i ++ str " subgoals")
+ in
+ search_tac hints limit (succ depth) info
+ in
+ fun info ->
+ if Int.equal depth (succ limit) then
+ let info = Exninfo.reify () in
+ Proofview.tclZERO ~info ReachedLimit
+ else
+ Proofview.tclOR (hints_tac hints info kont)
+ (fun e -> Proofview.tclOR (intro info kont)
+ (fun e' -> let (e, info) = merge_exceptions e e' in
+ Proofview.tclZERO ~info e))
+
+ let search_tac_gl mst only_classes dep hints best_effort depth i sigma gls gl :
+ unit Proofview.tactic =
+ let open Proofview in
+ let dep = dep || Proofview.unifiable sigma (Goal.goal gl) gls in
+ let info = make_autogoal mst only_classes dep (cut_of_hints hints)
+ best_effort i gl in
+ search_tac hints depth 1 info
+
+ let search_tac mst only_classes best_effort dep hints depth =
+ let open Proofview in
+ let tac sigma gls i =
+ Goal.enter
+ begin fun gl ->
+ search_tac_gl mst only_classes dep hints best_effort depth (succ i) sigma gls gl end
+ in
+ Proofview.Unsafe.tclGETGOALS >>= fun gls ->
+ let gls = CList.map Proofview.drop_state gls in
+ Proofview.tclEVARMAP >>= fun sigma ->
+ let j = List.length gls in
+ search_fixpoint ~best_effort ~allow_out_of_order:true (List.init j (fun i -> tac sigma gls i))
+
+ let fix_iterative t =
+ let rec aux depth =
+ Proofview.tclOR
+ (t depth)
+ (function
+ | (ReachedLimit,_) -> aux (succ depth)
+ | (e,ie) -> Proofview.tclZERO ~info:ie e)
+ in aux 1
+
+ let fix_iterative_limit limit t =
+ let open Proofview in
+ let rec aux depth =
+ if Int.equal depth (succ limit)
+ then
+ let info = Exninfo.reify () in
+ tclZERO ~info ReachedLimit
+ else tclOR (t depth) (function
+ | (ReachedLimit, _) -> aux (succ depth)
+ | (e,ie) -> Proofview.tclZERO ~info:ie e)
+ in aux 1
+
+ let eauto_tac_stuck mst ?(unique=false)
+ ~only_classes
+ ~best_effort
+ ?strategy ~depth ~dep hints =
+ let open Proofview in
+ let tac =
+ let search = search_tac mst only_classes best_effort dep hints in
+ let dfs =
+ match strategy with
+ | None -> not (get_typeclasses_iterative_deepening ())
+ | Some Dfs -> true
+ | Some Bfs -> false
+ in
+ if dfs then
+ let depth = match depth with None -> -1 | Some d -> d in
+ search depth
+ else
+ match depth with
+ | None -> fix_iterative search
+ | Some l -> fix_iterative_limit l search
+ in
+ let error (e, info) =
+ match e with
+ | ReachedLimit ->
+ Tacticals.tclFAIL ~info (str"Proof search reached its limit")
+ | NoApplicableHint ->
+ Tacticals.tclFAIL ~info (str"Proof search failed" ++
+ (if Option.is_empty depth then mt()
+ else str" without reaching its limit"))
+ | Proofview.MoreThanOneSuccess ->
+ Tacticals.tclFAIL ~info (str"Proof search failed: " ++
+ str"more than one success found")
+ | e -> Proofview.tclZERO ~info e
+ in
+ let tac = Proofview.tclOR tac error in
+ let tac =
+ if unique then
+ Proofview.tclEXACTLY_ONCE Proofview.MoreThanOneSuccess tac
+ else tac
+ in
+ with_shelf numgoals >>= fun (initshelf, i) ->
+ let () = ppdebug 1 (fun () ->
+ str"Starting resolution with " ++ int i ++
+ str" goal(s) under focus and " ++
+ int (List.length initshelf) ++ str " shelved goal(s)" ++
+ (if only_classes then str " in only_classes mode" else str " in regular mode") ++
+ match depth with
+ | None -> str ", unbounded"
+ | Some i -> str ", with depth limit " ++ int i)
+ in
+ tac <*> pr_goals (str "after eauto_tac_stuck: ")
+
+ let eauto_tac mst ?unique ~only_classes ~best_effort ?strategy ~depth ~dep hints =
+ Hints.wrap_hint_warning @@
+ (eauto_tac_stuck mst ?unique ~only_classes
+ ~best_effort ?strategy ~depth ~dep hints)
+
+ let run_on_goals env evm p tac goals nongoals =
+ let goalsl =
+ if get_typeclasses_dependency_order () then
+ top_sort evm goals
+ else Evar.Set.elements goals
+ in
+ let goalsl = List.map Proofview.with_empty_state goalsl in
+ let tac = Proofview.Unsafe.tclNEWGOALS goalsl <*> tac in
+ let evm = Evd.set_typeclass_evars evm Evar.Set.empty in
+ let evm = Evd.push_future_goals evm in
+ let _, pv = Proofview.init evm [] in
+ (* Instance may try to call this before a proof is set up!
+ Thus, give_me_the_proof will fail. Beware! *)
+ let name, poly =
+ (* try
+ * let Proof.{ name; poly } = Proof.data Proof_global.(give_me_the_proof ()) in
+ * name, poly
+ * with | Proof_global.NoCurrentProof -> *)
+ Id.of_string "instance", false
+ in
+ let tac =
+ if get_debug () > 1 then Proofview.Trace.record_info_trace tac
+ else tac
+ in
+ let (), pv', unsafe, info =
+ try Proofview.apply ~name ~poly env tac pv
+ with Logic_monad.TacticFailure _ -> raise Not_found
+ in
+ let () =
+ ppdebug 1 (fun () ->
+ str"The tactic trace is: " ++ hov 0 (Proofview.Trace.pr_info env evm ~lvl:1 info))
+ in
+ let finished = Proofview.finished pv' in
+ let evm' = Proofview.return pv' in
+ let _, evm' = Evd.pop_future_goals evm' in
+ let () = ppdebug 1 (fun () ->
+ str"Finished resolution with " ++ str(if finished then "a complete" else "an incomplete") ++
+ str" solution." ++ fnl() ++
+ str"Old typeclass evars not concerned by this resolution = " ++
+ hov 0 (prlist_with_sep spc (pr_ev_with_id evm')
+ (Evar.Set.elements (Evd.get_typeclass_evars evm'))) ++ fnl() ++
+ str"Shelf = " ++
+ hov 0 (prlist_with_sep spc (pr_ev_with_id evm')
+ (Evar.Set.elements (Evd.get_typeclass_evars evm'))))
+ in
+ let nongoals' =
+ Evar.Set.fold (fun ev acc -> match Evarutil.advance evm' ev with
+ | Some ev' -> Evar.Set.add ev acc
+ | None -> acc) (Evar.Set.union goals nongoals) (Evd.get_typeclass_evars evm')
+ in
+ (* FIXME: the need to merge metas seems to come from this being called
+ internally from Unification. It should be handled there instead. *)
+ let evm' = Evd.meta_merge (Evd.meta_list evm) (Evd.clear_metas evm') in
+ let evm' = Evd.set_typeclass_evars evm' nongoals' in
+ let () = ppdebug 1 (fun () ->
+ str"New typeclass evars are: " ++
+ hov 0 (prlist_with_sep spc (pr_ev_with_id evm') (Evar.Set.elements nongoals')))
+ in
+ Some (finished, evm')
+
+ let run_on_evars env evm p tac =
+ match evars_to_goals p evm with
+ | None -> None (* This happens only because there's no evar having p *)
+ | Some (goals, nongoals) ->
+ run_on_goals env evm p tac goals nongoals
+ let evars_eauto env evd depth only_classes ~best_effort unique dep mst hints p =
+ let eauto_tac = eauto_tac_stuck mst ~unique ~only_classes
+ ~best_effort
+ ~depth ~dep:(unique || dep) hints in
+ run_on_evars env evd p eauto_tac
+
+ let typeclasses_eauto env evd ?depth unique ~best_effort st hints p =
+ evars_eauto env evd depth true ~best_effort unique false st hints p
+ (** Typeclasses eauto is an eauto which tries to resolve only
+ goals of typeclass type, and assumes that the initially selected
+ evars in evd are independent of the rest of the evars *)
+
+ let typeclasses_resolve env evd depth unique ~best_effort p =
+ let db = searchtable_map typeclasses_db in
+ let st = Hint_db.transparent_state db in
+ let modes = Hint_db.modes db in
+ typeclasses_eauto env evd ?depth ~best_effort unique (modes,st) [db] p
+end
+
+let typeclasses_eauto ?(only_classes=false)
+ ?(best_effort=false)
+ ?(st=TransparentState.full)
+ ?strategy ~depth dbs =
+ let dbs = List.map_filter
+ (fun db -> try Some (searchtable_map db)
+ with e when CErrors.noncritical e -> None)
+ dbs
+ in
+ let st = match dbs with x :: _ -> Hint_db.transparent_state x | _ -> st in
+ let modes = List.map Hint_db.modes dbs in
+ let modes = List.fold_left (GlobRef.Map.union (fun _ m1 m2 -> Some (m1@m2))) GlobRef.Map.empty modes in
+ let depth = match depth with None -> get_typeclasses_depth () | Some l -> Some l in
+ Proofview.tclIGNORE
+ (Search.eauto_tac (modes,st) ~only_classes ?strategy
+ ~best_effort ~depth ~dep:true dbs)
+ (* Stuck goals can remain here, we could shelve them, but this way
+ the user can use `solve [typeclasses eauto]` to check there are
+ no stuck goals remaining, or use [typeclasses eauto; shelve] himself. *)
+
+(** We compute dependencies via a union-find algorithm.
+ Beware of the imperative effects on the partition structure,
+ it should not be shared, but only used locally. *)
+
+module Intpart = Unionfind.Make(Evar.Set)(Evar.Map)
+
+let deps_of_constraints cstrs evm p =
+ List.iter (fun (_, _, x, y) ->
+ let evx = Evarutil.undefined_evars_of_term evm x in
+ let evy = Evarutil.undefined_evars_of_term evm y in
+ Intpart.union_set (Evar.Set.union evx evy) p)
+ cstrs
+
+let evar_dependencies pred evm p =
+ let cache = Evarutil.create_undefined_evars_cache () in
+ Evd.fold_undefined
+ (fun ev evi _ ->
+ if Evd.is_typeclass_evar evm ev && pred evm ev evi then
+ let evars = Evar.Set.add ev (Evarutil.filtered_undefined_evars_of_evar_info ~cache evm evi)
+ in Intpart.union_set evars p
+ else ())
+ evm ()
+
+(** [split_evars] returns groups of undefined evars according to dependencies *)
+
+let split_evars pred evm =
+ let p = Intpart.create () in
+ evar_dependencies pred evm p;
+ deps_of_constraints (snd (extract_all_conv_pbs evm)) evm p;
+ Intpart.partition p
+
+let is_inference_forced p evd ev =
+ try
+ if Evar.Set.mem ev (Evd.get_typeclass_evars evd) && p ev
+ then
+ let (loc, k) = evar_source (Evd.find_undefined evd ev) in
+ match k with
+ | Evar_kinds.ImplicitArg (_, _, b) -> b
+ | Evar_kinds.QuestionMark _ -> false
+ | _ -> true
+ else true
+ with Not_found -> assert false
+
+let is_mandatory p comp evd =
+ Evar.Set.exists (is_inference_forced p evd) comp
+
+(** Check if an evar is concerned by the current resolution attempt,
+ (and in particular is in the current component).
+ Invariant : this should only be applied to undefined evars. *)
+
+let select_and_update_evars p oevd in_comp evd ev =
+ try
+ if Evd.is_typeclass_evar oevd ev then
+ (in_comp ev && p evd ev (Evd.find_undefined evd ev))
+ else false
+ with Not_found -> false
+
+(** Do we still have unresolved evars that should be resolved ? *)
+
+let has_undefined p oevd evd =
+ let check ev evi = p oevd ev in
+ Evar.Map.exists check (Evd.undefined_map evd)
+let find_undefined p oevd evd =
+ let check ev evi = p oevd ev in
+ Evar.Map.domain (Evar.Map.filter check (Evd.undefined_map evd))
+
+exception Unresolved of evar_map
+
+type solver_type = Environ.env -> evar_map ->
+ metavariable option -> prefix_of_inductive_support_flag ->
+ best_effort:prefix_of_inductive_support_flag ->
+ (evar_map -> Evar.t -> prefix_of_inductive_support_flag) ->
+ (prefix_of_inductive_support_flag * evar_map) option
+
+(** If [do_split] is [true], we try to separate the problem in
+ several components and then solve them separately *)
+let resolve_all_evars depth unique env p oevd fail =
+ let () =
+ ppdebug 0 (fun () ->
+ str"Calling typeclass resolution with flags: "++
+ str"depth = " ++ (match depth with None -> str "∞" | Some d -> int d) ++ str"," ++
+ str"unique = " ++ bool unique ++ str"," ++
+ str"fail = " ++ bool fail);
+ ppdebug 2 (fun () ->
+ str"Initial evar map: " ++
+ Termops.pr_evar_map ~with_univs:!Detyping.print_universes None env oevd)
+ in
+ let split = split_evars p oevd in
+ let split_solver = List.map (Coq_elpi_class_tactics_takeover.handle_takeover Search.typeclasses_resolve env oevd) split in
+ let in_comp comp ev = Evar.Set.mem ev comp in
+ let rec docomp evd = function
+ | [] ->
+ let () = ppdebug 2 (fun () ->
+ str"Final evar map: " ++
+ Termops.pr_evar_map ~with_univs:!Detyping.print_universes None env evd)
+ in
+ evd
+ | ((solver: solver_type), comp) :: comps ->
+ let p = select_and_update_evars p oevd (in_comp comp) in
+ try
+ (try
+ let res = solver env evd depth
+ ~best_effort:true unique p in
+ match res with
+ | Some (finished, evd') ->
+ if has_undefined p oevd evd' then
+ let () = if finished then ppdebug 1 (fun () ->
+ str"Proof is finished but there remain undefined evars: " ++
+ prlist_with_sep spc (pr_ev evd')
+ (Evar.Set.elements (find_undefined p oevd evd')))
+ in
+ raise (Unresolved evd')
+ else docomp evd' comps
+ | None -> docomp evd comps (* No typeclass evars left in this component *)
+ with Not_found ->
+ (* Typeclass resolution failed *)
+ raise (Unresolved evd))
+ with Unresolved evd' ->
+ if fail && is_mandatory (p evd') comp evd'
+ then (* Unable to satisfy the constraints. *)
+ error_unresolvable env evd' comp
+ else (* Best effort: use the best found solution on this component *)
+ docomp evd' comps
+ in docomp oevd split_solver
+
+let initial_select_evars filter =
+ fun evd ev evi ->
+ filter ev (Lazy.from_val (snd (Evd.evar_source evi))) &&
+ (* Typeclass evars can contain evars whose conclusion is not
+ yet determined to be a class or not. *)
+ Typeclasses.is_class_evar evd evi
+
+
+let classes_transparent_state () =
+ try Hint_db.transparent_state (searchtable_map typeclasses_db)
+ with Not_found -> TransparentState.empty
+
+let resolve_typeclass_evars depth unique env evd filter fail =
+ let evd =
+ try Evarconv.solve_unif_constraints_with_heuristics
+ ~flags:(Evarconv.default_flags_of (classes_transparent_state())) env evd
+ with e when CErrors.noncritical e -> evd
+ in
+ resolve_all_evars depth unique env
+ (initial_select_evars filter) evd fail
+
+let solve_inst env evd filter unique fail =
+ let ((), sigma) = Hints.wrap_hint_warning_fun env evd begin fun evd ->
+ (), resolve_typeclass_evars
+ (get_typeclasses_depth ())
+ unique env evd filter fail
+ end in
+ sigma
+
+let () =
+ Typeclasses.set_solve_all_instances solve_inst
+
+let resolve_one_typeclass env ?(sigma=Evd.from_env env) concl unique =
+ let (term, sigma) = Hints.wrap_hint_warning_fun env sigma begin fun sigma ->
+ let hints = searchtable_map typeclasses_db in
+ let st = Hint_db.transparent_state hints in
+ let modes = Hint_db.modes hints in
+ let depth = get_typeclasses_depth () in
+ let tac = Tacticals.tclCOMPLETE (Search.eauto_tac (modes,st)
+ ~only_classes:true ~best_effort:false
+ ~depth [hints] ~dep:true)
+ in
+ let entry, pv = Proofview.init sigma [env, concl] in
+ let pv =
+ let name = Names.Id.of_string "legacy_pe" in
+ match Proofview.apply ~name ~poly:false (Global.env ()) tac pv with
+ | (_, final, _, _) -> final
+ | exception (Logic_monad.TacticFailure (Tacticals.FailError _)) ->
+ raise Not_found
+ in
+ let evd = Proofview.return pv in
+ let term = match Proofview.partial_proof entry pv with [t] -> t | _ -> assert false in
+ term, evd
+ end in
+ (sigma, term)
+
+let () =
+ Typeclasses.set_solve_one_instance
+ (fun x y z w -> resolve_one_typeclass x ~sigma:y z w)
+
+(** Take the head of the arity of a constr.
+ Used in the partial application tactic. *)
+
+let rec head_of_constr sigma t =
+ let t = strip_outer_cast sigma t in
+ match EConstr.kind sigma t with
+ | Prod (_,_,c2) -> head_of_constr sigma c2
+ | LetIn (_,_,_,c2) -> head_of_constr sigma c2
+ | App (f,args) -> head_of_constr sigma f
+ | _ -> t
+
+let head_of_constr h c =
+ Proofview.tclEVARMAP >>= fun sigma ->
+ let c = head_of_constr sigma c in
+ letin_tac None (Name h) c None Locusops.allHyps
+
+let not_evar c =
+ Proofview.tclEVARMAP >>= fun sigma ->
+ match EConstr.kind sigma c with
+ | Evar _ -> Tacticals.tclFAIL (str"Evar")
+ | _ -> Proofview.tclUNIT ()
+
+let is_ground c =
+ let open Tacticals in
+ Proofview.tclEVARMAP >>= fun sigma ->
+ if Evarutil.is_ground_term sigma c then tclIDTAC
+ else tclFAIL (str"Not ground")
+
+let autoapply c i =
+ let open Proofview.Notations in
+ Hints.wrap_hint_warning @@
+ Proofview.Goal.enter begin fun gl ->
+ let hintdb = try Hints.searchtable_map i with Not_found ->
+ CErrors.user_err (Pp.str ("Unknown hint database " ^ i ^ "."))
+ in
+ let flags = auto_unif_flags
+ (Hints.Hint_db.transparent_state hintdb) in
+ let cty = Tacmach.pf_get_type_of gl c in
+ let env = Proofview.Goal.env gl in
+ let sigma = Proofview.Goal.sigma gl in
+ let ce = Clenv.mk_clenv_from env sigma (c,cty) in
+ Clenv.res_pf ~with_evars:true ~with_classes:false ~flags ce <*>
+ Proofview.tclEVARMAP >>= (fun sigma ->
+ let sigma = Typeclasses.make_unresolvables
+ (fun ev -> Typeclasses.all_goals ev (Lazy.from_val (snd (Evd.evar_source (Evd.find_undefined sigma ev))))) sigma in
+ Proofview.Unsafe.tclEVARS sigma) end
diff --git a/apps/tc/src/coq_elpi_class_tactics_takeover.ml b/apps/tc/src/coq_elpi_class_tactics_takeover.ml
new file mode 100644
index 000000000..24462edcf
--- /dev/null
+++ b/apps/tc/src/coq_elpi_class_tactics_takeover.ml
@@ -0,0 +1,176 @@
+(* license: GNU Lesser General Public License Version 2.1 or later *)
+(* ------------------------------------------------------------------------- *)
+
+open Util
+open Names
+open Typeclasses
+
+open Elpi
+
+module Intpart = Unionfind.Make(Evar.Set)(Evar.Map)
+
+open Elpi_plugin
+open Coq_elpi_utils
+
+type override =
+ | AllButFor of Names.GlobRef.Set.t
+ | Only of Names.GlobRef.Set.t
+
+type action =
+ | Set of Coq_elpi_utils.qualified_name * override
+ | Add of GlobRef.t list
+ | Rm of GlobRef.t list
+
+let elpi_solver = Summary.ref ~name:"tc_takeover" None
+
+let takeover action =
+ let open Names.GlobRef in
+ match !elpi_solver, action with
+ | _, Set(solver,mode) ->
+ elpi_solver := Some (mode,solver)
+ | None, (Add _ | Rm _) ->
+ CErrors.user_err Pp.(str "Set the override program first")
+ | Some(AllButFor s,solver), Add grl ->
+ let s' = List.fold_right Set.add grl Set.empty in
+ elpi_solver := Some (AllButFor (Set.diff s s'),solver)
+ | Some(AllButFor s,solver), Rm grl ->
+ let s' = List.fold_right Set.add grl Set.empty in
+ elpi_solver := Some (AllButFor (Set.union s s'),solver)
+ | Some(Only s,solver), Add grl ->
+ let s' = List.fold_right Set.add grl Set.empty in
+ elpi_solver := Some (Only (Set.union s s'),solver)
+ | Some(Only s,solver), Rm grl ->
+ let s' = List.fold_right Set.add grl Set.empty in
+ elpi_solver := Some (Only (Set.diff s s'),solver)
+
+let inTakeover =
+ let cache x = takeover x in
+ Libobject.(declare_object (superglobal_object_nodischarge "TC_HACK_OVERRIDE" ~cache ~subst:None))
+
+let takeover isNone l solver =
+ let open Names.GlobRef in
+ let l = List.map Coq_elpi_utils.locate_simple_qualid l in
+ let s = List.fold_right Set.add l Set.empty in
+ let mode = if isNone then Only Set.empty else if Set.is_empty s then AllButFor s else Only s in
+ Lib.add_leaf (inTakeover (Set(solver,mode)))
+
+let takeover_add l =
+ let l = List.map Coq_elpi_utils.locate_simple_qualid l in
+ Lib.add_leaf (inTakeover (Add l))
+
+let takeover_rm l =
+ let l = List.map Coq_elpi_utils.locate_simple_qualid l in
+ Lib.add_leaf (inTakeover (Rm l))
+
+let path2str = List.fold_left (fun acc e -> Printf.sprintf "%s/%s" acc e) ""
+let debug_covered_gref = CDebug.create ~name:"tc_current_gref" ()
+
+let covered1 env sigma classes i default=
+ let ei = Evd.find_undefined sigma i in
+ let ty = Evd.evar_concl ei in
+ match Typeclasses.class_of_constr env sigma ty with
+ | Some (_,(((cl: typeclass),_),_)) ->
+ let cl_impl = cl.Typeclasses.cl_impl in
+ debug_covered_gref (fun () -> Pp.(str "The current gref is: " ++
+ Printer.pr_global cl_impl ++ str ", with path: " ++ str (path2str (gr2path cl_impl))));
+ Names.GlobRef.Set.mem cl_impl classes
+ | None -> default
+
+let covered env sigma omode s =
+ match omode with
+ | AllButFor blacklist ->
+ Evar.Set.for_all (fun x -> not (covered1 env sigma blacklist x false)) s
+ | Only whitelist ->
+ Evar.Set.for_all (fun x -> covered1 env sigma whitelist x true) s
+
+let debug_handle_takeover = CDebug.create ~name:"handle_takeover" ()
+
+let elpi_fails program_name =
+ let open Pp in
+ let kind = "tactic/command" in
+ let name = show_qualified_name program_name in
+ CErrors.user_err (strbrk (String.concat " " [
+ "The elpi"; kind; name ; "failed without giving a specific error message.";
+ "Please report this inconvenience to the authors of the program."
+ ]))
+let solve_TC program env sigma depth unique ~best_effort filter =
+ let loc = API.Ast.Loc.initial "(unknown)" in
+ let atts = [] in
+ let glss, _ = Evar.Set.partition (filter sigma) (Evd.get_typeclass_evars sigma) in
+ let gls = Evar.Set.elements glss in
+ (* TODO: activate following row to compute new gls
+ this row to make goal sort in msolve *)
+ (* let evar_deps = List.map (fun e ->
+ let evar_info = Evd.find_undefined sigma e in
+ let evar_deps = Evarutil.filtered_undefined_evars_of_evar_info sigma evar_info in
+ e, Evar.Set.elements evar_deps
+ ) gls in *)
+ (* let g = Graph.build_graph evar_deps in *)
+ (* let gls = List.map (fun (e: 'a Graph.node) -> e.name ) (Graph.topo_sort g) in *)
+ let query ~depth state =
+ let state, (loc, q), gls =
+ Coq_elpi_HOAS.goals2query sigma gls loc ~main:(Coq_elpi_HOAS.Solve [])
+ ~in_elpi_tac_arg:Coq_elpi_arg_HOAS.in_elpi_tac ~depth state in
+ let state, qatts = Coq_elpi_vernacular.atts2impl loc ~depth state atts q in
+ let state = API.State.set Coq_elpi_builtins.tactic_mode state true in
+ state, (loc, qatts), gls
+ in
+ let cprogram, _ = Coq_elpi_vernacular.get_and_compile program in
+ match Coq_elpi_vernacular.run ~static_check:false cprogram (`Fun query) with
+ | API.Execute.Success solution ->
+ let sigma, _, _ = Coq_elpi_HOAS.solution2evd sigma solution glss in
+ Some(false,sigma)
+ | API.Execute.NoMoreSteps -> CErrors.user_err Pp.(str "elpi run out of steps")
+ | API.Execute.Failure -> elpi_fails program
+ | exception (Coq_elpi_utils.LtacFail (level, msg)) -> elpi_fails program
+
+let handle_takeover coq_solver env sigma (cl: Intpart.set) =
+ let t = Unix.gettimeofday () in
+ let is_elpi, res =
+ match !elpi_solver with
+ | Some(omode,solver) when covered env sigma omode cl ->
+ true, solve_TC solver
+ | _ -> false, coq_solver in
+ let is_elpi_text = if is_elpi then "Elpi" else "Coq" in
+ debug_handle_takeover (fun () ->
+ let len = (Evar.Set.cardinal cl) in Pp.str @@
+ Printf.sprintf "handle_takeover for %s - Class : %d - Time : %f"
+ is_elpi_text len (Unix.gettimeofday () -. t));
+ res, cl
+
+let assert_same_generated_TC = Goptions.declare_bool_option_and_ref
+ ~depr:(Deprecation.make ()) ~key:["assert_same_generated_TC"] ~value:false
+
+(* let same_solution evd1 evd2 i =
+ let print_discrepancy a b =
+ CErrors.anomaly Pp.(str
+ "Discrepancy in same solution: \n" ++
+ str"Expected : " ++ a ++ str"\n" ++
+ str"Found : " ++ b)
+ in
+ let get_types evd t = EConstr.to_constr ~abort_on_undefined_evars:false evd t in
+ try (
+ let t1 = Evd.find evd1 i in
+ let t2 = Evd.find evd2 i |> Evd.evar_body in
+ match t1, t2 with
+ | Evd.Evar_defined t1, Evd.Evar_defined t2 ->
+ let t1, t2 = get_types evd1 t1, get_types evd2 t2 in
+ let b = try Constr.eq_constr_nounivs t1 t2 with Not_found ->
+ CErrors.anomaly Pp.(str "Discrepancy in same solution: problem with universes") in
+ if (not b) then
+ print_discrepancy (Printer.pr_constr_env (Global.env ()) evd1 t1) (Printer.pr_constr_env (Global.env ()) evd2 t2)
+ else
+ b
+ | Evd.Evar_empty, Evd.Evar_empty -> true
+ | Evd.Evar_defined t1, Evar_empty ->
+ let t1 = get_types evd1 t1 in
+ print_discrepancy (Printer.pr_constr_env (Global.env ()) evd1 t1) (Pp.str "Nothing")
+ | Evd.Evar_empty, Evd.Evar_defined t2 ->
+ let t2 = get_types evd2 t2 in
+ print_discrepancy (Pp.str "Nothing") (Printer.pr_constr_env (Global.env ()) evd2 t2)
+ ) with Not_found ->
+ CErrors.anomaly Pp.(str "Discrepancy in same solution: Not found All") *)
+
+
+(* let same_solution comp evd1 evd2 =
+ Evar.Set.for_all (same_solution evd1 evd2) comp *)
diff --git a/apps/tc/src/coq_elpi_tc_hook.mlg b/apps/tc/src/coq_elpi_tc_hook.mlg
new file mode 100644
index 000000000..7003bdf38
--- /dev/null
+++ b/apps/tc/src/coq_elpi_tc_hook.mlg
@@ -0,0 +1,46 @@
+(* license: GNU Lesser General Public License Version 2.1 or later *)
+(* ------------------------------------------------------------------------- *)
+
+DECLARE PLUGIN "coq-elpi-tc.plugin"
+
+{
+open Stdarg
+open Elpi_plugin
+open Coq_elpi_arg_syntax
+open Coq_elpi_tc_register
+open Coq_elpi_class_tactics_takeover
+}
+
+VERNAC COMMAND EXTEND ElpiTypeclasses CLASSIFIED AS SIDEFF
+
+| #[ atts = any_attribute ] [ "Elpi" "Register" "TC" "Compiler" qualified_name(p) ] -> {
+ let () = ignore_unknown_attributes atts in
+ register_observer (fst p, snd p, atts) }
+
+| #[ atts = any_attribute ] [ "Elpi" "TC" "Activate" "Observer" qualified_name(p) ] -> {
+ let () = ignore_unknown_attributes atts in
+ activate_observer (snd p) }
+
+| #[ atts = any_attribute ] [ "Elpi" "TC" "Deactivate" "Observer" qualified_name(p) ] -> {
+ let () = ignore_unknown_attributes atts in
+ deactivate_observer (snd p) }
+
+| #[ atts = any_attribute ] [ "Elpi" "Override" "TC" qualified_name(p) "All" ] -> {
+ let () = ignore_unknown_attributes atts in
+ takeover false [] (snd p) }
+| #[ atts = any_attribute ] [ "Elpi" "Override" "TC" qualified_name(p) "None" ] -> {
+ let () = ignore_unknown_attributes atts in
+ takeover true [] (snd p) }
+
+
+| #[ atts = any_attribute ] [ "Elpi" "Override" "TC" qualified_name(p) "Only" ne_reference_list(cs) ] -> {
+ let () = ignore_unknown_attributes atts in
+ takeover false cs (snd p) }
+| #[ atts = any_attribute ] [ "Elpi" "Override" "TC" "+" reference_list(cs) ] -> {
+ let () = ignore_unknown_attributes atts in
+ takeover_add cs }
+| #[ atts = any_attribute ] [ "Elpi" "Override" "TC" "-" reference_list(cs) ] -> {
+ let () = ignore_unknown_attributes atts in
+ takeover_rm cs }
+
+END
\ No newline at end of file
diff --git a/apps/tc/src/coq_elpi_tc_register.ml b/apps/tc/src/coq_elpi_tc_register.ml
new file mode 100644
index 000000000..702d58a2f
--- /dev/null
+++ b/apps/tc/src/coq_elpi_tc_register.ml
@@ -0,0 +1,105 @@
+(* license: GNU Lesser General Public License Version 2.1 or later *)
+(* ------------------------------------------------------------------------- *)
+
+open Elpi_plugin
+open Classes
+open Coq_elpi_arg_HOAS
+open Names
+
+type qualified_name = Coq_elpi_utils.qualified_name
+
+type loc_name_atts = (Loc.t * qualified_name * Attributes.vernac_flags)
+
+(* Hack to convert a Coq GlobRef into an elpi string *)
+let gref2elpi_term (gref: GlobRef.t) : Cmd.raw =
+ let gref_2_string gref = Pp.string_of_ppcmds (Printer.pr_global gref) in
+ Cmd.String (gref_2_string gref)
+ (* TODO: maybe returning an elpi term is cleaner, but this creates a loop in
+ stdppInj test *)
+ (* Cmd.Term (CAst.make @@ Constrexpr.CRef(
+ Libnames.qualid_of_string @@ gref_2_string gref,None)) *)
+
+(* Returns the elpi term representing the type class received in argument *)
+let observer_class (x : Typeclasses.typeclass) : Coq_elpi_arg_HOAS.Cmd.raw list =
+ [gref2elpi_term x.cl_impl]
+
+(**
+ Returns the list of Cmd.raw arguments to be passed to the elpi program in charge
+ to compile instances. The arguments are [Inst, TC, Locality, Prio] where:
+ - Inst : is the elpi Term for the current instance
+ - TC : is the elpi Term for the type class implemented by Inst
+ - Locality : is the elpi String [Local|Global|Export] for the locality of Inst
+ - Prio : is the elpi Int N representing the priority of the instance. N is:
+ | -1 if the instance has no user-defined priority
+ | N if the instance has the user-defined priority N
+*)
+let observer_instance ({locality; instance; info; class_name} : instance) : Coq_elpi_arg_HOAS.Cmd.raw list =
+ let locality2elpi_string loc =
+ let hint2string = function
+ | Hints.Local -> "Local"
+ | Export -> "Export"
+ | SuperGlobal -> "Global" in
+ Cmd.String (hint2string loc) in
+ let prio2elpi_int (prio: Typeclasses.hint_info) =
+ Cmd.Int (Option.default (-1) prio.hint_priority) in
+ [
+ gref2elpi_term instance;
+ gref2elpi_term class_name;
+ locality2elpi_string locality;
+ prio2elpi_int info
+ ]
+
+let inObservation =
+ Libobject.declare_object @@
+ Libobject.local_object "TC_HACK_OBSERVER2"
+ ~cache:(fun (run,inst) -> run @@ observer_instance inst)
+ ~discharge:(fun (_,inst as x) -> if inst.locality = Local then None else Some x)
+
+let observer_evt ((loc, name, atts) : loc_name_atts) (x : Event.t) =
+ let open Coq_elpi_vernacular in
+ let run_program e = run_program loc name ~atts e in
+ match x with
+ | Event.NewClass cl -> run_program @@ observer_class cl
+ | Event.NewInstance inst -> Lib.add_leaf (inObservation (run_program,inst))
+
+module StringMap = Map.Make(String)
+
+type observers = observer StringMap.t
+
+let observers : observers ref = Summary.ref StringMap.empty ~name:"tc_observers"
+
+let build_observer_name (observer : qualified_name) =
+ String.concat "." observer
+
+type action =
+ | Create of string * loc_name_atts
+ | Activate of qualified_name
+ | Deactivate of qualified_name
+
+let action_manager = function
+ | Create (name, loc_name_atts) ->
+ let observer = Classes.register_observer ~name (observer_evt loc_name_atts) in
+ observers := StringMap.add name observer !observers;
+ Classes.activate_observer observer
+ | Activate observer ->
+ Classes.activate_observer (StringMap.find (build_observer_name observer) !observers)
+ | Deactivate observer ->
+ Classes.deactivate_observer (StringMap.find (build_observer_name observer) !observers)
+
+
+(* Take an action and execute it with the action manager *)
+let inTakeover =
+ let cache = action_manager
+ in Libobject.(declare_object
+ (superglobal_object_nodischarge "TC_HACK_OBSERVER" ~cache ~subst:None))
+
+(* Adds a new observer in coq and activate it *)
+let register_observer ((_, name, _) as lna : loc_name_atts) =
+ let obs_name = build_observer_name name in
+ Lib.add_leaf (inTakeover (Create (obs_name, lna)))
+
+let activate_observer (observer : qualified_name) =
+ Lib.add_leaf (inTakeover (Activate observer))
+
+let deactivate_observer (observer : qualified_name) =
+ Lib.add_leaf (inTakeover (Deactivate observer))
\ No newline at end of file
diff --git a/apps/tc/src/elpi_tc_plugin.mlpack b/apps/tc/src/elpi_tc_plugin.mlpack
new file mode 100644
index 000000000..b9c0c8e3b
--- /dev/null
+++ b/apps/tc/src/elpi_tc_plugin.mlpack
@@ -0,0 +1,4 @@
+Coq_elpi_tc_register
+Coq_elpi_class_tactics_takeover
+Coq_elpi_class_tactics_hacked
+Coq_elpi_tc_hook
\ No newline at end of file
diff --git a/apps/tc/tests/WIP/add_alias.v b/apps/tc/tests/WIP/add_alias.v
new file mode 100644
index 000000000..be23a47df
--- /dev/null
+++ b/apps/tc/tests/WIP/add_alias.v
@@ -0,0 +1,30 @@
+From elpi.apps Require Import tc.
+Elpi Override TC TC.Solver All.
+Elpi Debug "use-alias".
+
+Class foo (A : Type) := f : Type.
+
+Global Instance fooNat : foo nat := {f := nat}.
+Global Instance fooBool : foo bool := {f := bool}.
+
+Elpi AddClasses foo.
+Elpi AddInstances foo.
+
+Definition nat' := nat.
+
+
+Goal foo nat. apply _. Qed.
+Goal foo bool. apply _. Qed.
+Goal foo nat'. Fail apply _. Abort.
+
+Module A.
+ Elpi Accumulate TC.Solver lp:{{
+ alias {{nat'}} {{nat}}.
+ }}.
+ Goal foo nat'. apply _. Qed.
+End A.
+
+Definition nat'' := nat'.
+
+Elpi AddAlias (nat'') (nat').
+Goal foo nat''. apply _. Qed.
diff --git a/apps/tc/tests/WIP/cyclicTC_jarl.v b/apps/tc/tests/WIP/cyclicTC_jarl.v
new file mode 100644
index 000000000..75154e2fc
--- /dev/null
+++ b/apps/tc/tests/WIP/cyclicTC_jarl.v
@@ -0,0 +1,69 @@
+From elpi.apps Require Import tc.
+Elpi Debug "simple-compiler".
+Set TC NameShortPath.
+
+Elpi Override TC TC.Solver All.
+
+Class A (T1 : Type).
+Class B (T1 : Type).
+
+Global Instance instA' (T1 : Type) (T2 : Type) : A bool. Qed.
+Global Instance instA (T1 : Type) `(B T1) : A T1. Qed.
+
+Global Instance instB (T1 : Type) `(A T1) : B T1. Qed.
+Global Instance instB' : B nat . Qed.
+
+Elpi Accumulate tc.db lp:{{
+ pred explored_gref o:gref.
+
+ pred should_fail i:list gref, i:gref, i:gref.
+ should_fail [] _ _.
+ should_fail [Current | Tl] Current BlackElt :- !,
+ if (std.mem Tl BlackElt) fail true.
+ should_fail [_ | Tl] Current BlackElt :- !,
+ should_fail Tl Current BlackElt.
+
+ pred already_explored i:gref, i:gref.
+ already_explored Current BlackElt :-
+ std.findall (explored_gref _) As,
+ std.map As (x\r\ x = explored_gref r) As',
+ should_fail As' Current BlackElt.
+
+ pred get_other i:gref, o:gref.
+
+ pred under_extra i:gref, i:list prop, o:list prop.
+ under_extra A B C :- std.map B (x\r\ (explored_gref A => x) = r) C1,
+ C = [sigma x\ get_other A x, already_explored A x | C1].
+
+ :after "firstHook"
+ make-tc IsHead Ty Inst Hyp Clause :- !,
+ app [global TC | TL] = Ty,
+ gref->pred-name TC TC_Str,
+ std.append TL [Inst] Args,
+ coq.elpi.predicate TC_Str Args Q,
+ if (not IsHead) (Hyp = Hyp') (under_extra TC Hyp Hyp'),
+ Clause = (Q :- Hyp').
+}}.
+Elpi Typecheck TC.Solver.
+
+Elpi AddAllClasses.
+Elpi AddAllInstances.
+
+Elpi Command AddRecursivelyDependantTC.
+Elpi Accumulate Db tc.db.
+Elpi Accumulate lp:{{
+ main [trm (global A), trm (global B)] :-
+ coq.elpi.accumulate _ "tc.db"
+ (clause _ _ (get_other A B)),
+ coq.elpi.accumulate _ "tc.db"
+ (clause _ _ (get_other B A)).
+ main L :- coq.say L.
+}}.
+Elpi Typecheck.
+
+Elpi AddRecursivelyDependantTC (A) (B).
+
+Elpi Bound Steps 10000.
+Check (_ : B bool).
+Check (_ : A nat).
+
diff --git a/apps/tc/tests/WIP/eqSimpl.v b/apps/tc/tests/WIP/eqSimpl.v
new file mode 100644
index 000000000..4a29cc63f
--- /dev/null
+++ b/apps/tc/tests/WIP/eqSimpl.v
@@ -0,0 +1,26 @@
+(*
+ TODO: modes don't work, since, when compiled, instance does
+ not already know them
+*)
+Require Import Bool.
+From elpi.apps Require Import tc.
+
+Elpi Debug "simple-compiler".
+Set TC AddModes.
+
+Class MyEqb A : Type := eqb : A -> A -> bool.
+Global Hint Mode MyEqb + : typeclass_instances.
+
+Notation " x == y " := (eqb x y) (no associativity, at level 70).
+
+Global Instance eqU : MyEqb unit := { eqb x y := true }.
+Global Instance eqB : MyEqb bool := { eqb x y := if x then y else negb y }.
+Global Instance eqP {A B} `{MyEqb A} `{MyEqb B} : MyEqb (A * B) := {
+ eqb x y := (fst x == fst y) && (snd x == snd y) }.
+
+Fail Check (fun n m : _ => eqb n m).
+
+Goal (tt, (tt, true)) == (tt, (tt, true)) = true.
+ easy.
+Qed.
+
diff --git a/apps/tc/tests/WIP/included_proof.v b/apps/tc/tests/WIP/included_proof.v
new file mode 100644
index 000000000..ab7f9c79d
--- /dev/null
+++ b/apps/tc/tests/WIP/included_proof.v
@@ -0,0 +1,30 @@
+From elpi.apps Require Import tc.
+
+Class EqDec (A : Type) :=
+ { eqb : A -> A -> bool ;
+ eqb_leibniz : forall x y, eqb x y = true -> x = y }.
+
+Generalizable Variables A.
+
+Class Ord `(E : EqDec A) := { le : A -> A -> bool }.
+
+Class C (A : Set).
+
+Elpi Override TC TC.Solver All.
+Global Instance cInst `{e: EqDec nat} : Ord e -> C nat. Admitted.
+
+(*
+ We want to be sure that cInst when compiled has only one hypothesis: (Ord e).
+ We don't want the hypothesis {e : EqDec nat} since it will be verified by (Ord e)
+*)
+(* TODO: it should not fail *)
+Fail Elpi Query TC.Solver lp:{{
+ compile {{:gref cInst}} _ _ CL,
+ CL = (pi a\ pi b\ (_ :- (Hyp a b))),
+ coq.say Hyp,
+ pi a b\
+ expected-found (do _) (Hyp a b).
+}}.
+
+
+
diff --git a/apps/tc/tests/WIP/premisesSort/sort1.v b/apps/tc/tests/WIP/premisesSort/sort1.v
new file mode 100644
index 000000000..78ed6b833
--- /dev/null
+++ b/apps/tc/tests/WIP/premisesSort/sort1.v
@@ -0,0 +1,18 @@
+From elpi.apps.tc.tests.premisesSort Require Import sortCode.
+
+Set Warnings "+elpi".
+Class A (S : Type).
+Class B (S : Type).
+Class C (S : Type).
+
+Global Instance A1 : A nat. Admitted.
+Global Instance A2 : A bool. Admitted.
+
+Global Instance B1 : B nat. Admitted.
+
+Global Instance C1 {T : Type} `{A T, B T} : C bool. Admitted.
+
+(* Simpl example where we do backtrack *)
+Goal C bool.
+ apply _.
+Qed.
\ No newline at end of file
diff --git a/apps/tc/tests/WIP/premisesSort/sort2.v b/apps/tc/tests/WIP/premisesSort/sort2.v
new file mode 100644
index 000000000..9ecd88d2a
--- /dev/null
+++ b/apps/tc/tests/WIP/premisesSort/sort2.v
@@ -0,0 +1,32 @@
+From elpi.apps.tc.tests.premisesSort Require Import sortCode.
+Elpi Debug "simple-compiler".
+Set TC AddModes.
+
+Class A (S : Type).
+Class B (S : Type).
+Class C (S : Type).
+
+Global Hint Mode A + : typeclass_instances.
+
+Global Instance A1 : A nat. Admitted.
+
+Global Instance B1 : B nat. Admitted.
+
+(*
+ Here since the output of T is input in A, we want to reorder
+ the goals such that the proof of be is computed first.
+ Question do we want to raise an error or try to rearrange
+ subgoals in C1. We can try to make an analysis in the compiling
+ phase to raise the error.
+*)
+Global Instance C1 {T : Type} `{e : A T, B T} : C bool. Admitted.
+
+Elpi AddAllClasses.
+Elpi AddAllInstances.
+
+Elpi Override TC TC.Solver All.
+
+Elpi Print TC.Solver.
+Goal C bool.
+ apply _.
+Qed.
\ No newline at end of file
diff --git a/apps/tc/tests/WIP/premisesSort/sort3.v b/apps/tc/tests/WIP/premisesSort/sort3.v
new file mode 100644
index 000000000..878ba06dd
--- /dev/null
+++ b/apps/tc/tests/WIP/premisesSort/sort3.v
@@ -0,0 +1,28 @@
+From elpi.apps.tc.tests.premisesSort Require Import sortCode.
+Elpi Debug "simple-compiler".
+
+Class A (S : Type) (T : Type).
+Class B (S : Type) (T : Type).
+Class C (S : Type).
+
+Global Hint Mode A + - : typeclass_instances.
+Global Hint Mode B + - : typeclass_instances.
+Elpi AddAllClasses.
+
+Global Instance A1 : A nat nat. Admitted.
+Global Instance B1 : B nat nat. Admitted.
+
+Global Instance C1 {S T : Type} `{B S T, A T S} : C T. Admitted.
+
+Elpi AddAllInstances.
+Elpi Override TC TC.Solver All.
+Goal C nat.
+ apply _.
+Qed.
+
+(* Following has a cyclic dependecy, therefore error *)
+(* Global Instance C2 {S T : Type} `{A T S, B S T} : C bool. Admitted. *)
+(* Elpi AddInstances C2. *)
+
+(* Global Instance C3 {S T : Type} `{B T S} : C S. Admitted. *)
+(* Elpi AddInstances C3. *)
\ No newline at end of file
diff --git a/apps/tc/tests/WIP/premisesSort/sort4.v b/apps/tc/tests/WIP/premisesSort/sort4.v
new file mode 100644
index 000000000..0309430c2
--- /dev/null
+++ b/apps/tc/tests/WIP/premisesSort/sort4.v
@@ -0,0 +1,59 @@
+From elpi.apps.tc.tests.premisesSort Require Import sortCode.
+Elpi Debug "simple-compiler".
+Set TC AddModes.
+
+Class A (S : Type) (T : Type).
+Class C (S : Type) (T : Type).
+Class B (S : Type) (T : Type) `(A S T, C S T) := f : forall (x : S), x = x.
+
+Global Hint Mode A + + : typeclass_instances.
+Global Hint Mode C + + : typeclass_instances.
+
+Global Instance A1 : A nat nat. Admitted.
+Global Instance C1 : C nat nat. Admitted.
+Global Instance B1 (S : Type) (T : Type) (a : A S T) (c : C S T) : B S T a c. Admitted.
+
+Elpi AddAllClasses.
+Elpi AddAllInstances.
+Elpi Override TC TC.Solver All.
+
+Elpi Accumulate tc.db lp:{{
+ pred get-inout-sealed-goal i:argument_mode, i:sealed-goal, o:list term.
+ get-inout-sealed-goal AMode (seal (goal _ _ (app [global GR | L]) Sol _)) Res :-
+ tc-mode GR Modes, std.append L [Sol] L',
+ std.map2-filter L' Modes (t\m\r\ pr AMode _ = m, var t, r = t) Res.
+ get-inout-sealed-goal out (seal (goal _ _ _ Sol _)) [Sol].
+ get-inout-sealed-goal _ _ [].
+
+ pred sort-goals i:list sealed-goal, o:list int.
+ sort-goals L NL :-
+ std.map-i L (i\x\r\ r = pr x i) LookupList,
+ std.map L (x\r\ sigma M\ get-inout-sealed-goal in x M, r = pr x M) InputModes,
+ std.map L (x\r\ sigma Output Deps\
+ get-inout-sealed-goal out x Output,
+ std.map-filter InputModes (x\r\
+ sigma Fst Snd\ pr Fst Snd = x,
+ std.exists Output (v\ std.exists Snd (v1\ occurs_var v v1)), r = Fst) Deps, % O(N^2)
+ sigma Output2Nb Deps2Nb\
+ std.lookup! LookupList x Output2Nb,
+ std.map Deps (std.lookup! LookupList) Deps2Nb,
+ r = pr Output2Nb Deps2Nb) Graph,
+ coq.toposort Graph NL.
+
+ pred sort-sealed-goals i:list sealed-goal, o:list sealed-goal.
+ sort-sealed-goals SGL SortedSGL :-
+ sort-goals SGL SGLIndexes,
+ std.map SGLIndexes (x\r\ std.nth x SGL r) SortedSGL.
+
+ :after "firstHook" msolve L N :- !,
+ sort-sealed-goals L LSort,
+ coq.say LSort,
+ coq.ltac.all (coq.ltac.open solve) LSort N.
+
+ :after "firstHook" msolve A _ :- coq.say A, sep, fail.
+}}.
+Elpi Typecheck TC.Solver.
+
+Goal 3 = 3.
+ Fail apply f.
+Abort.
\ No newline at end of file
diff --git a/apps/tc/tests/WIP/premisesSort/sortCode.v b/apps/tc/tests/WIP/premisesSort/sortCode.v
new file mode 100644
index 000000000..720d4ce0c
--- /dev/null
+++ b/apps/tc/tests/WIP/premisesSort/sortCode.v
@@ -0,0 +1,90 @@
+
+From elpi Require Import tc.
+
+Elpi Accumulate tc.db lp:{{
+ pred get-pattern-fragment i:term, o:list term.
+
+ pred get-inout i:argument_mode, i:term, o:list term.
+ % TODO: the second arg may not be an (app L)
+ get-inout AMode (app [global GR | L]) Res :-
+ std.drop-last 1 {tc-mode GR} Modes,
+ std.map2-filter L Modes (t\m\r\ pr AMode _ = m, r = t) Res.
+ get-inout _ _ [].
+
+ pred input-must-have-predecessor i:term, i:term, i:list term, i:list term.
+ input-must-have-predecessor _ _ [] _ :- !.
+ input-must-have-predecessor Instance Premise [Mode | Modes] Premises :-
+ std.exists Premises (p\ sigma MOut\
+ get-inout out p MOut, std.mem MOut Mode),
+ input-must-have-predecessor Instance Premise Modes Premises.
+ input-must-have-predecessor Instance Premise [Mode | _] _ :-
+ coq.error "Input mode" Mode "of"
+ Premise "cannot be inferred from the other premises of the instance"
+ Instance.
+
+
+ % CurrentType is the type of the current instance to get its input variables,
+ % These variables should not create edges in the graph
+ pred sort-hypothesis i:term, i:term, i:list term, o:list int.
+ sort-hypothesis Instance (app [_ | InputCurrentType]) L NL :-
+ std.map-i L (i\x\r\ r = pr x i) LookupList,
+ std.map L (premise\r\ sigma M M'\ get-inout in premise M,
+ std.filter M (x\ not (std.mem InputCurrentType x)) M',
+ input-must-have-predecessor Instance premise M' L,
+ r = pr premise M') InputModes,
+ % foreach goal, we associate those goals having a dependency on it,
+ % in particular a goal G2 depends on G1 if a variable V is in
+ % output mode for G1 and in input mode for G2 (the dependency graph will
+ % and edge going from G1 to G2 : G1 -> G2)
+ std.map L (x\r\ sigma Output Deps\ % O(N^3 * check of occurs)
+ % the list of variable in input of the current goal G
+ get-inout out x Output,
+ % for each output modes of all goals, we keep those having an output
+ % which exists in the input variable of G
+ std.map-filter InputModes (x\r\
+ sigma Fst Snd\ pr Fst Snd = x,
+ std.exists Output (v\ std.exists Snd (v1\ occurs v v1)), r = Fst) Deps, % O(N^2)
+ sigma Output2Nb Deps2Nb\
+ std.lookup! LookupList x Output2Nb,
+ std.map Deps (std.lookup! LookupList) Deps2Nb,
+ r = pr Output2Nb Deps2Nb) Graph,
+ coq.toposort Graph NL.
+
+ pred sort-and-compile-premises i:term, i:term, i:list term, i:list term, i:prop, o:list prop.
+ sort-and-compile-premises Instance CurrentType Types Vars IsPositive Premises :-
+ sort-hypothesis Instance CurrentType Types TypesSortedIndexes, % O (n^3)
+ % std.map-i Types (i\e\r\ r = i) TypesSortedIndexes,
+ std.map TypesSortedIndexes (x\r\ std.nth x Vars r) SortedVars, % O (n^2)
+ std.map TypesSortedIndexes (x\r\ std.nth x Types r) SortedTypes, % O (n^2)
+ std.map2-filter SortedTypes SortedVars (t\v\r\
+ compile-aux1 t v [] [] [] (not IsPositive) false r _) Premises.
+
+ pred compile-aux1 i:term, i:term, i:list term, i:list univ, i:list term, i:prop, i:prop, o:prop, o:bool.
+ :name "compiler-aux:start"
+ compile-aux1 Ty I [] [X | XS] [] IsPositive IsHead (pi x\ C x) IsLeaf :- !,
+ pi x\ copy (sort (typ X)) (sort (typ x)) => copy Ty (Ty1 x),
+ compile-aux1 (Ty1 x) I [] XS [] IsPositive IsHead (C x) IsLeaf.
+ compile-aux1 (prod N T F) I ListVar [] Types IsPositive IsHead Clause ff :- !,
+ (if IsPositive (Clause = pi x\ C x) (Clause = (pi x\ decl x N T => C x))),
+ pi p\ sigma Type\
+ if (app-has-class T, not (occurs p (F p))) (Type = T) (Type = app []),
+ compile-aux1 (F p) I [p | ListVar] [] [Type | Types] IsPositive IsHead (C p) _.
+ :if "simple-compiler"
+ % TODO: here we don't do pattern fragment unification
+ compile-aux1 Ty I ListVar [] Types IsPositive IsHead Clause tt :- !,
+ sort-and-compile-premises I Ty Types ListVar IsPositive Premises,
+ coq.mk-app I {std.rev ListVar} AppInst,
+ make-tc IsHead Ty AppInst Premises Clause.
+ compile-aux1 Ty I ListVar [] Types IsPositive IsHead Clause tt :- !,
+ sort-and-compile-premises I Ty Types ListVar IsPositive Premises,
+ coq.mk-app I {std.rev ListVar} AppInst,
+ std.append {get-pattern-fragment Ty} {get-pattern-fragment AppInst} Term-to-be-fixed,
+ std.fold Term-to-be-fixed 0 (e\acc\r\ sigma L X\ e = app X, std.length X L, r is acc + L - 1) Len,
+ if (IsPositive) (IsPositiveBool = tt) (IsPositiveBool = ff),
+ remove-ho-unification IsHead IsPositiveBool Len Ty AppInst Premises Term-to-be-fixed [] [] [] [] [] Clause.
+
+ :after "firstHook"
+ compile-aux Ty Inst _Premises _VarAcc UnivL IsPositive IsHead Clause NoPremises :- !,
+ compile-aux1 Ty Inst [] UnivL [] (IsPositive = tt, true; false) IsHead Clause NoPremises.
+}}.
+Elpi Typecheck TC.Solver.
\ No newline at end of file
diff --git a/apps/tc/tests/auto_compile.v b/apps/tc/tests/auto_compile.v
new file mode 100644
index 000000000..aa3c44c5c
--- /dev/null
+++ b/apps/tc/tests/auto_compile.v
@@ -0,0 +1,73 @@
+From elpi.apps Require Import tc.
+
+Elpi Override TC TC.Solver All.
+
+Require Import Bool.
+
+(* TODO: How to add the #[deterministic] pragma in front of the class? *)
+(* #[deterministic] Class A (T : Type) := {succ : T -> T}. *)
+Class A (T : Type) := {succ : T -> T}.
+#[local] Instance B : A nat := {succ n := S n}.
+Instance C : A bool := {succ b := negb b}.
+Instance Prod (X Y: Type) `(A X, A Y) : A (X * Y) :=
+ {succ b := match b with (a, b) => (succ a, succ b) end}.
+
+Elpi Accumulate TC.Solver lp:{{
+ :after "firstHook"
+ solve _ _ :- coq.say "Solving in ELPI!", fail.
+}}.
+
+Goal A (nat * (nat * bool)). apply _. Qed.
+
+Module M.
+ Class B (T : nat).
+ Section A.
+ Instance X : B 1. Qed.
+ Goal B 1. apply _. Qed.
+
+ Global Instance Y : B 2. Qed.
+ Goal B 2. apply _. Qed.
+ End A.
+ Goal B 1. Proof. Fail apply _. Abort.
+ Goal B 2. Proof. apply _. Qed.
+
+ Section B.
+ Variable V : nat.
+ Global Instance Z : `(B 0) -> B V. Qed.
+ Global Instance W : B 0. Qed.
+ End B.
+
+ Goal B 0. apply _. Qed.
+ Goal B 10. apply _. Qed.
+End M.
+
+Goal M.B 1. apply M.X. Qed.
+Goal M.B 0. apply _. Qed.
+Goal M.B 10. apply _. Qed.
+
+Elpi Query TC.Solver lp:{{
+ % Small test for instance order
+ sigma I L\
+ std.findall (instance _ _ _) I,
+ std.map-filter I (x\y\ x = instance _ y {{:gref M.B}})
+ [{{:gref M.W}}, {{:gref M.Y}}, {{:gref M.Z}}].
+}}.
+
+Module S.
+ Class Cl (i: nat).
+ #[local] Instance Cl1 : Cl 1. Qed.
+ #[global] Instance Cl2 : Cl 2. Qed.
+ #[export] Instance Cl3 : Cl 3. Qed.
+End S.
+
+Elpi Override TC TC.Solver None.
+Goal S.Cl 1 /\ S.Cl 2 /\ S.Cl 3.
+Proof.
+ split. all:cycle 1.
+ split.
+ apply _.
+ Fail apply _.
+ Import S.
+ apply _.
+ Fail apply _.
+Abort.
\ No newline at end of file
diff --git a/apps/tc/tests/bigTest.v b/apps/tc/tests/bigTest.v
new file mode 100644
index 000000000..499f07b9a
--- /dev/null
+++ b/apps/tc/tests/bigTest.v
@@ -0,0 +1,1719 @@
+From elpi.apps Require Import tc.
+Elpi Override TC TC.Solver All.
+
+(** This file collects type class interfaces, notations, and general theorems
+that are used throughout the whole development. Most importantly it contains
+abstract interfaces for ordered structures, sets, and various other data
+structures. *)
+
+(* We want to ensure that [le] and [lt] refer to operations on [nat].
+These two functions being defined both in [Coq.Bool] and in [Coq.Peano],
+we must export [Coq.Peano] later than any export of [Coq.Bool]. *)
+(* We also want to ensure that notations from [Coq.Utf8] take precedence
+over the ones of [Coq.Peano] (see Coq PR#12950), so we import [Utf8] last. *)
+From Coq Require Export Morphisms RelationClasses List Bool Setoid Peano Utf8.
+From Coq Require Import Permutation.
+Export ListNotations.
+From Coq.Program Require Export Basics Syntax.
+
+TC.AddAllClasses.
+TC.AddAllInstances.
+
+(** This notation is necessary to prevent [length] from being printed
+as [strings.length] if strings.v is imported and later base.v. See
+also strings.v and
+https://gitlab.mpi-sws.org/iris/stdpp/-/merge_requests/144 and
+https://gitlab.mpi-sws.org/iris/stdpp/-/merge_requests/129. *)
+Notation length := Datatypes.length.
+
+(** * Enable implicit generalization. *)
+(** This option enables implicit generalization in arguments of the form
+ [`{...}] (i.e., anonymous arguments). Unfortunately, it also enables
+ implicit generalization in [Instance]. We think that the fact that both
+ behaviors are coupled together is a [bug in
+ Coq](https://github.com/coq/coq/issues/6030). *)
+Global Generalizable All Variables.
+
+(** * Tweak program *)
+(** 1. Since we only use Program to solve logical side-conditions, they should
+always be made Opaque, otherwise we end up with performance problems due to
+Coq blindly unfolding them.
+
+Note that in most cases we use [Next Obligation. (* ... *) Qed.], for which
+this option does not matter. However, sometimes we write things like
+[Solve Obligations with naive_solver (* ... *)], and then the obligations
+should surely be opaque. *)
+Global Unset Transparent Obligations.
+
+(** 2. Do not let Program automatically simplify obligations. The default
+obligation tactic is [Tactics.program_simpl], which, among other things,
+introduces all variables and gives them fresh names. As such, it becomes
+impossible to refer to hypotheses in a robust way. *)
+Global Obligation Tactic := idtac.
+
+(** 3. Hide obligations and unsealing lemmas from the results of the [Search]
+commands. *)
+Add Search Blacklist "_obligation_".
+Add Search Blacklist "_unseal".
+
+(** * Sealing off definitions *)
+#[projections(primitive=yes)]
+Record seal {A} (f : A) := { unseal : A; seal_eq : unseal = f }.
+Global Arguments unseal {_ _} _ : assert.
+Global Arguments seal_eq {_ _} _ : assert.
+
+(** * Solving type class instances *)
+(** The tactic [tc_solve] is used to solve type class goals by invoking type
+class search. It is similar to [apply _], but it is more robust since it does
+not affect unrelated goals/evars due to https://github.com/coq/coq/issues/6583.
+
+The tactic [tc_solve] is particularly useful when building custom tactics that
+need tight control over when type class search is invoked. In Iris, many of the
+proof mode tactics make use of [notypeclasses refine] and use [tc_solve] to
+manually invoke type class search.
+
+Note that [typeclasses eauto] is multi-success. That means, whenever subsequent
+tactics fail, it will backtrack to [typeclasses eauto] to try the next type
+class instance. This is almost always undesired and can lead to poor performance
+and horrible error messages. Hence, we wrap it in a [once]. *)
+Ltac tc_solve :=
+ solve [once (typeclasses eauto)].
+
+(** * Non-backtracking type classes *)
+(** The type class [TCNoBackTrack P] can be used to establish [P] without ever
+backtracking on the instance of [P] that has been found. Backtracking may
+normally happen when [P] contains evars that could be instanciated in different
+ways depending on which instance is picked, and type class search somewhere else
+depends on this evar.
+
+The proper way of handling this would be by setting Coq's option
+`Typeclasses Unique Instances`. However, this option seems to be broken, see Coq
+issue #6714.
+
+See https://gitlab.mpi-sws.org/FP/iris-coq/merge_requests/112 for a rationale
+of this type class. *)
+Class TCNoBackTrack (P : Prop) := TCNoBackTrack_intro { tc_no_backtrack : P }.
+Global Hint Extern 0 (TCNoBackTrack _) =>
+ notypeclasses refine (TCNoBackTrack_intro _ _); tc_solve : typeclass_instances.
+
+(* A conditional at the type class level. Note that [TCIf P Q R] is not the same
+as [TCOr (TCAnd P Q) R]: the latter will backtrack to [R] if it fails to
+establish [Q], i.e. does not have the behavior of a conditional. Furthermore,
+note that [TCOr (TCAnd P Q) (TCAnd (TCNot P) R)] would not work; we generally
+would not be able to prove the negation of [P]. *)
+Inductive TCIf (P Q R : Prop) : Prop :=
+ | TCIf_true : P → Q → TCIf P Q R
+ | TCIf_false : R → TCIf P Q R.
+Existing Class TCIf.
+
+Global Hint Extern 0 (TCIf _ _ _) =>
+ first [notypeclasses refine (TCIf_true _ _ _ _ _); [tc_solve|]
+ |notypeclasses refine (TCIf_false _ _ _ _)] : typeclass_instances.
+
+(** * Typeclass opaque definitions *)
+(** The constant [tc_opaque] is used to make definitions opaque for just type
+class search. Note that [simpl] is set up to always unfold [tc_opaque]. *)
+Definition tc_opaque {A} (x : A) : A := x.
+Global Typeclasses Opaque tc_opaque.
+Global Arguments tc_opaque {_} _ /.
+
+(** Below we define type class versions of the common logical operators. It is
+important to note that we duplicate the definitions, and do not declare the
+existing logical operators as type classes. That is, we do not say:
+
+ Existing Class or.
+ Existing Class and.
+
+If we could define the existing logical operators as classes, there is no way
+of disambiguating whether a premise of a lemma should be solved by type class
+resolution or not.
+
+These classes are useful for two purposes: writing complicated type class
+premises in a more concise way, and for efficiency. For example, using the [Or]
+class, instead of defining two instances [P → Q1 → R] and [P → Q2 → R] we could
+have one instance [P → Or Q1 Q2 → R]. When we declare the instance that way, we
+avoid the need to derive [P] twice. *)
+Inductive TCOr (P1 P2 : Prop) : Prop :=
+ | TCOr_l : P1 → TCOr P1 P2
+ | TCOr_r : P2 → TCOr P1 P2.
+Existing Class TCOr.
+Global Existing Instance TCOr_l | 9.
+Global Existing Instance TCOr_r | 10.
+Global Hint Mode TCOr ! ! : typeclass_instances.
+
+Inductive TCAnd (P1 P2 : Prop) : Prop := TCAnd_intro : P1 → P2 → TCAnd P1 P2.
+Existing Class TCAnd.
+Global Existing Instance TCAnd_intro.
+Global Hint Mode TCAnd ! ! : typeclass_instances.
+
+Inductive TCTrue : Prop := TCTrue_intro : TCTrue.
+Existing Class TCTrue.
+Global Existing Instance TCTrue_intro.
+
+(** The class [TCFalse] is not stricly necessary as one could also use
+[False]. However, users might expect that TCFalse exists and if it
+does not, it can cause hard to diagnose bugs due to automatic
+generalization. *)
+Inductive TCFalse : Prop :=.
+Existing Class TCFalse.
+
+(** The class [TCUnless] can be used to check that search for [P]
+fails. This is useful as a guard for certain instances together with
+classes like [TCFastDone] (see [tactics.v]) to prevent infinite loops
+(e.g. when saturating the context). *)
+Notation TCUnless P := (TCIf P TCFalse TCTrue).
+
+Inductive TCForall {A} (P : A → Prop) : list A → Prop :=
+ | TCForall_nil : TCForall P []
+ | TCForall_cons x xs : P x → TCForall P xs → TCForall P (x :: xs).
+Existing Class TCForall.
+Global Existing Instance TCForall_nil.
+Global Existing Instance TCForall_cons.
+Global Hint Mode TCForall ! ! ! : typeclass_instances.
+
+(** The class [TCForall2 P l k] is commonly used to transform an input list [l]
+into an output list [k], or the converse. Therefore there are two modes, either
+[l] input and [k] output, or [k] input and [l] input. *)
+Inductive TCForall2 {A B} (P : A → B → Prop) : list A → list B → Prop :=
+ | TCForall2_nil : TCForall2 P [] []
+ | TCForall2_cons x y xs ys :
+ P x y → TCForall2 P xs ys → TCForall2 P (x :: xs) (y :: ys).
+Existing Class TCForall2.
+Global Existing Instance TCForall2_nil.
+Global Existing Instance TCForall2_cons.
+Global Hint Mode TCForall2 ! ! ! ! - : typeclass_instances.
+Global Hint Mode TCForall2 ! ! ! - ! : typeclass_instances.
+
+Inductive TCExists {A} (P : A → Prop) : list A → Prop :=
+ | TCExists_cons_hd x l : P x → TCExists P (x :: l)
+ | TCExists_cons_tl x l: TCExists P l → TCExists P (x :: l).
+Existing Class TCExists.
+Global Existing Instance TCExists_cons_hd | 10.
+Global Existing Instance TCExists_cons_tl | 20.
+Global Hint Mode TCExists ! ! ! : typeclass_instances.
+
+Inductive TCElemOf {A} (x : A) : list A → Prop :=
+ | TCElemOf_here xs : TCElemOf x (x :: xs)
+ | TCElemOf_further y xs : TCElemOf x xs → TCElemOf x (y :: xs).
+Existing Class TCElemOf.
+Global Existing Instance TCElemOf_here.
+Global Existing Instance TCElemOf_further.
+Global Hint Mode TCElemOf ! ! ! : typeclass_instances.
+
+(** The intended use of [TCEq x y] is to use [x] as input and [y] as output, but
+this is not enforced. We use output mode [-] (instead of [!]) for [x] to ensure
+that type class search succeed on goals like [TCEq (if ? then e1 else e2) ?y],
+see https://gitlab.mpi-sws.org/iris/iris/merge_requests/391 for a use case.
+Mode [-] is harmless, the only instance of [TCEq] is [TCEq_refl] below, so we
+cannot create loops. *)
+Inductive TCEq {A} (x : A) : A → Prop := TCEq_refl : TCEq x x.
+Existing Class TCEq.
+Global Existing Instance TCEq_refl.
+Global Hint Mode TCEq ! - - : typeclass_instances.
+
+Lemma TCEq_eq {A} (x1 x2 : A) : TCEq x1 x2 ↔ x1 = x2.
+Proof. split; destruct 1; reflexivity. Qed.
+
+(** The [TCSimpl x y] type class is similar to [TCEq] but performs [simpl]
+before proving the goal by reflexivity. Similar to [TCEq], the argument [x]
+is the input and [y] the output. When solving [TCEq x y], the argument [x]
+should be a concrete term and [y] an evar for the [simpl]ed result. *)
+Class TCSimpl {A} (x x' : A) := TCSimpl_TCEq : TCEq x x'.
+Global Hint Extern 0 (TCSimpl _ _) =>
+ (* Since the second argument should be an evar, we can call [simpl] on the
+ whole goal. *)
+ simpl; notypeclasses refine (TCEq_refl _) : typeclass_instances.
+Global Hint Mode TCSimpl ! - - : typeclass_instances.
+
+Lemma TCSimpl_eq {A} (x1 x2 : A) : TCSimpl x1 x2 ↔ x1 = x2.
+Proof. apply TCEq_eq. Qed.
+
+Inductive TCDiag {A} (C : A → Prop) : A → A → Prop :=
+ | TCDiag_diag x : C x → TCDiag C x x.
+Existing Class TCDiag.
+Global Existing Instance TCDiag_diag.
+Global Hint Mode TCDiag ! ! ! - : typeclass_instances.
+Global Hint Mode TCDiag ! ! - ! : typeclass_instances.
+
+(** Given a proposition [P] that is a type class, [tc_to_bool P] will return
+[true] iff there is an instance of [P]. It is often useful in Ltac programming,
+where one can do [lazymatch tc_to_bool P with true => .. | false => .. end]. *)
+Definition tc_to_bool (P : Prop)
+ {p : bool} `{TCIf P (TCEq p true) (TCEq p false)} : bool := p.
+
+(** Throughout this development we use [stdpp_scope] for all general purpose
+notations that do not belong to a more specific scope. *)
+Declare Scope stdpp_scope.
+Delimit Scope stdpp_scope with stdpp.
+Global Open Scope stdpp_scope.
+
+(** Change [True] and [False] into notations in order to enable overloading.
+We will use this to give [True] and [False] a different interpretation for
+embedded logics. *)
+Notation "'True'" := True (format "True") : type_scope.
+Notation "'False'" := False (format "False") : type_scope.
+
+(** Change [forall] into a notation in order to enable overloading. *)
+Notation "'forall' x .. y , P" := (forall x, .. (forall y, P) ..)
+ (at level 200, x binder, y binder, right associativity,
+ only parsing) : type_scope.
+
+
+(** * Equality *)
+(** Introduce some Haskell style like notations. *)
+Notation "(=)" := eq (only parsing) : stdpp_scope.
+Notation "( x =.)" := (eq x) (only parsing) : stdpp_scope.
+Notation "(.= x )" := (λ y, eq y x) (only parsing) : stdpp_scope.
+Notation "(≠)" := (λ x y, x ≠ y) (only parsing) : stdpp_scope.
+Notation "( x ≠.)" := (λ y, x ≠ y) (only parsing) : stdpp_scope.
+Notation "(.≠ x )" := (λ y, y ≠ x) (only parsing) : stdpp_scope.
+
+Infix "=@{ A }" := (@eq A)
+ (at level 70, only parsing, no associativity) : stdpp_scope.
+Notation "(=@{ A } )" := (@eq A) (only parsing) : stdpp_scope.
+Notation "(≠@{ A } )" := (λ X Y, ¬X =@{A} Y) (only parsing) : stdpp_scope.
+Notation "X ≠@{ A } Y":= (¬X =@{ A } Y)
+ (at level 70, only parsing, no associativity) : stdpp_scope.
+
+Global Hint Extern 0 (_ = _) => reflexivity : core.
+Global Hint Extern 100 (_ ≠ _) => discriminate : core.
+
+Global Instance: ∀ A, PreOrder (=@{A}).
+Proof. split; repeat intro; congruence. Qed.
+
+(** ** Setoid equality *)
+(** We define an operational type class for setoid equality, i.e., the
+"canonical" equivalence for a type. The typeclass is tied to the \equiv
+symbol. This is based on (Spitters/van der Weegen, 2011). *)
+Class Equiv A := equiv: relation A.
+Global Hint Mode Equiv ! : typeclass_instances.
+
+(** We instruct setoid rewriting to infer [equiv] as a relation on
+type [A] when needed. This allows setoid_rewrite to solve constraints
+of shape [Proper (eq ==> ?R) f] using [Proper (eq ==> (equiv (A:=A))) f]
+when an equivalence relation is available on type [A]. We put this instance
+at level 150 so it does not take precedence over Coq's stdlib instances,
+favoring inference of [eq] (all Coq functions are automatically morphisms
+for [eq]). We have [eq] (at 100) < [≡] (at 150) < [⊑] (at 200). *)
+Global Instance equiv_rewrite_relation `{Equiv A} :
+ RewriteRelation (@equiv A _) | 150 := {}.
+
+Infix "≡" := equiv (at level 70, no associativity) : stdpp_scope.
+Infix "≡@{ A }" := (@equiv A _)
+ (at level 70, only parsing, no associativity) : stdpp_scope.
+
+Notation "(≡)" := equiv (only parsing) : stdpp_scope.
+Notation "( X ≡.)" := (equiv X) (only parsing) : stdpp_scope.
+Notation "(.≡ X )" := (λ Y, Y ≡ X) (only parsing) : stdpp_scope.
+Notation "(≢)" := (λ X Y, ¬X ≡ Y) (only parsing) : stdpp_scope.
+Notation "X ≢ Y":= (¬X ≡ Y) (at level 70, no associativity) : stdpp_scope.
+Notation "( X ≢.)" := (λ Y, X ≢ Y) (only parsing) : stdpp_scope.
+Notation "(.≢ X )" := (λ Y, Y ≢ X) (only parsing) : stdpp_scope.
+
+Notation "(≡@{ A } )" := (@equiv A _) (only parsing) : stdpp_scope.
+Notation "(≢@{ A } )" := (λ X Y, ¬X ≡@{A} Y) (only parsing) : stdpp_scope.
+Notation "X ≢@{ A } Y":= (¬X ≡@{ A } Y)
+ (at level 70, only parsing, no associativity) : stdpp_scope.
+
+(** The type class [LeibnizEquiv] collects setoid equalities that coincide
+with Leibniz equality. We provide the tactic [fold_leibniz] to transform such
+setoid equalities into Leibniz equalities, and [unfold_leibniz] for the
+reverse.
+
+Various std++ tactics assume that this class is only instantiated if [≡]
+is an equivalence relation. *)
+Class LeibnizEquiv A `{Equiv A} :=
+ leibniz_equiv (x y : A) : x ≡ y → x = y.
+Global Hint Mode LeibnizEquiv ! ! : typeclass_instances.
+
+Lemma leibniz_equiv_iff `{LeibnizEquiv A, !Reflexive (≡@{A})} (x y : A) :
+ x ≡ y ↔ x = y.
+Proof. split; [apply leibniz_equiv|]. intros ->; reflexivity. Qed.
+
+Ltac fold_leibniz := repeat
+ match goal with
+ | H : context [ _ ≡@{?A} _ ] |- _ =>
+ setoid_rewrite (leibniz_equiv_iff (A:=A)) in H
+ | |- context [ _ ≡@{?A} _ ] =>
+ setoid_rewrite (leibniz_equiv_iff (A:=A))
+ end.
+Ltac unfold_leibniz := repeat
+ match goal with
+ | H : context [ _ =@{?A} _ ] |- _ =>
+ setoid_rewrite <-(leibniz_equiv_iff (A:=A)) in H
+ | |- context [ _ =@{?A} _ ] =>
+ setoid_rewrite <-(leibniz_equiv_iff (A:=A))
+ end.
+
+Definition equivL {A} : Equiv A := (=).
+
+(** A [Params f n] instance forces the setoid rewriting mechanism not to
+rewrite in the first [n] arguments of the function [f]. We will declare such
+instances for all operational type classes in this development. *)
+Global Instance: Params (@equiv) 2 := {}.
+
+(** The following instance forces [setoid_replace] to use setoid equality
+(for types that have an [Equiv] instance) rather than the standard Leibniz
+equality. *)
+Global Instance equiv_default_relation `{Equiv A} :
+ DefaultRelation (≡@{A}) | 3 := {}.
+Global Hint Extern 0 (_ ≡ _) => reflexivity : core.
+Global Hint Extern 0 (_ ≡ _) => symmetry; assumption : core.
+
+
+(** * Type classes *)
+(** ** Decidable propositions *)
+(** This type class by (Spitters/van der Weegen, 2011) collects decidable
+propositions. *)
+Class Decision (P : Prop) := decide : {P} + {¬P}.
+Global Hint Mode Decision ! : typeclass_instances.
+Global Arguments decide _ {_} : simpl never, assert.
+
+(** Although [RelDecision R] is just [∀ x y, Decision (R x y)], we make this
+an explicit class instead of a notation for two reasons:
+
+- It allows us to control [Hint Mode] more precisely. In particular, if it were
+ defined as a notation, the above [Hint Mode] for [Decision] would not prevent
+ diverging instance search when looking for [RelDecision (@eq ?A)], which would
+ result in it looking for [Decision (@eq ?A x y)], i.e. an instance where the
+ head position of [Decision] is not en evar.
+- We use it to avoid inefficient computation due to eager evaluation of
+ propositions by [vm_compute]. This inefficiency arises for example if
+ [(x = y) := (f x = f y)]. Since [decide (x = y)] evaluates to
+ [decide (f x = f y)], this would then lead to evaluation of [f x] and [f y].
+ Using the [RelDecision], the [f] is hidden under a lambda, which prevents
+ unnecessary evaluation. *)
+Class RelDecision {A B} (R : A → B → Prop) :=
+ decide_rel x y :> Decision (R x y).
+Global Hint Mode RelDecision ! ! ! : typeclass_instances.
+Global Arguments decide_rel {_ _} _ {_} _ _ : simpl never, assert.
+Notation EqDecision A := (RelDecision (=@{A})).
+
+(** ** Inhabited types *)
+(** This type class collects types that are inhabited. *)
+Class Inhabited (A : Type) : Type := populate { inhabitant : A }.
+Global Hint Mode Inhabited ! : typeclass_instances.
+Global Arguments populate {_} _ : assert.
+
+(** ** Proof irrelevant types *)
+(** This type class collects types that are proof irrelevant. That means, all
+elements of the type are equal. We use this notion only used for propositions,
+but by universe polymorphism we can generalize it. *)
+Class ProofIrrel (A : Type) : Prop := proof_irrel (x y : A) : x = y.
+Global Hint Mode ProofIrrel ! : typeclass_instances.
+
+(** ** Common properties *)
+(** These operational type classes allow us to refer to common mathematical
+properties in a generic way. For example, for injectivity of [(k ++.)] it
+allows us to write [inj (k ++.)] instead of [app_inv_head k]. *)
+Class Inj {A B} (R : relation A) (S : relation B) (f : A → B) : Prop :=
+ inj x y : S (f x) (f y) → R x y.
+Class Inj2 {A B C} (R1 : relation A) (R2 : relation B)
+ (S : relation C) (f : A → B → C) : Prop :=
+ inj2 x1 x2 y1 y2 : S (f x1 x2) (f y1 y2) → R1 x1 y1 ∧ R2 x2 y2.
+Class Cancel {A B} (S : relation B) (f : A → B) (g : B → A) : Prop :=
+ cancel x : S (f (g x)) x.
+Class Surj {A B} (R : relation B) (f : A → B) :=
+ surj y : ∃ x, R (f x) y.
+Class IdemP {A} (R : relation A) (f : A → A → A) : Prop :=
+ idemp x : R (f x x) x.
+Class Comm {A B} (R : relation A) (f : B → B → A) : Prop :=
+ comm x y : R (f x y) (f y x).
+Class LeftId {A} (R : relation A) (i : A) (f : A → A → A) : Prop :=
+ left_id x : R (f i x) x.
+Class RightId {A} (R : relation A) (i : A) (f : A → A → A) : Prop :=
+ right_id x : R (f x i) x.
+Class Assoc {A} (R : relation A) (f : A → A → A) : Prop :=
+ assoc x y z : R (f x (f y z)) (f (f x y) z).
+Class LeftAbsorb {A} (R : relation A) (i : A) (f : A → A → A) : Prop :=
+ left_absorb x : R (f i x) i.
+Class RightAbsorb {A} (R : relation A) (i : A) (f : A → A → A) : Prop :=
+ right_absorb x : R (f x i) i.
+Class AntiSymm {A} (R S : relation A) : Prop :=
+ anti_symm x y : S x y → S y x → R x y.
+Class Total {A} (R : relation A) := total x y : R x y ∨ R y x.
+Class Trichotomy {A} (R : relation A) :=
+ trichotomy x y : R x y ∨ x = y ∨ R y x.
+Class TrichotomyT {A} (R : relation A) :=
+ trichotomyT x y : {R x y} + {x = y} + {R y x}.
+
+Notation Involutive R f := (Cancel R f f).
+Lemma involutive {A} {R : relation A} (f : A → A) `{Involutive R f} x :
+ R (f (f x)) x.
+Proof. auto. Qed.
+
+Global Arguments irreflexivity {_} _ {_} _ _ : assert.
+Global Arguments inj {_ _ _ _} _ {_} _ _ _ : assert.
+Global Arguments inj2 {_ _ _ _ _ _} _ {_} _ _ _ _ _: assert.
+Global Arguments cancel {_ _ _} _ _ {_} _ : assert.
+Global Arguments surj {_ _ _} _ {_} _ : assert.
+Global Arguments idemp {_ _} _ {_} _ : assert.
+Global Arguments comm {_ _ _} _ {_} _ _ : assert.
+Global Arguments left_id {_ _} _ _ {_} _ : assert.
+Global Arguments right_id {_ _} _ _ {_} _ : assert.
+Global Arguments assoc {_ _} _ {_} _ _ _ : assert.
+Global Arguments left_absorb {_ _} _ _ {_} _ : assert.
+Global Arguments right_absorb {_ _} _ _ {_} _ : assert.
+Global Arguments anti_symm {_ _} _ {_} _ _ _ _ : assert.
+Global Arguments total {_} _ {_} _ _ : assert.
+Global Arguments trichotomy {_} _ {_} _ _ : assert.
+Global Arguments trichotomyT {_} _ {_} _ _ : assert.
+
+Lemma not_symmetry `{R : relation A, !Symmetric R} x y : ¬R x y → ¬R y x.
+Proof. intuition. Qed.
+Lemma symmetry_iff `(R : relation A) `{!Symmetric R} x y : R x y ↔ R y x.
+Proof. intuition. Qed.
+
+Lemma not_inj `{Inj A B R R' f} x y : ¬R x y → ¬R' (f x) (f y).
+Proof. intuition. Qed.
+Lemma not_inj2_1 `{Inj2 A B C R R' R'' f} x1 x2 y1 y2 :
+ ¬R x1 x2 → ¬R'' (f x1 y1) (f x2 y2).
+Proof. intros HR HR''. destruct (inj2 f x1 y1 x2 y2); auto. Qed.
+Lemma not_inj2_2 `{Inj2 A B C R R' R'' f} x1 x2 y1 y2 :
+ ¬R' y1 y2 → ¬R'' (f x1 y1) (f x2 y2).
+Proof. intros HR' HR''. destruct (inj2 f x1 y1 x2 y2); auto. Qed.
+
+Lemma inj_iff {A B} {R : relation A} {S : relation B} (f : A → B)
+ `{!Inj R S f} `{!Proper (R ==> S) f} x y : S (f x) (f y) ↔ R x y.
+Proof. firstorder. Qed.
+Global Instance inj2_inj_1 `{Inj2 A B C R1 R2 R3 f} y : Inj R1 R3 (λ x, f x y).
+Proof. repeat intro; edestruct (inj2 f); eauto. Qed.
+Global Instance inj2_inj_2 `{Inj2 A B C R1 R2 R3 f} x : Inj R2 R3 (f x).
+Proof. repeat intro; edestruct (inj2 f); eauto. Qed.
+Elpi Override TC - ProperProxy.
+
+Lemma cancel_inj `{Cancel A B R1 f g, !Equivalence R1, !Proper (R2 ==> R1) f} :
+ Inj R1 R2 g.
+Proof.
+ intros x y E. rewrite <-(cancel f g x), <-(cancel f g y), E. reflexivity.
+Qed.
+Lemma cancel_surj `{Cancel A B R1 f g} : Surj R1 f.
+Proof. intros y. exists (g y). auto. Qed.
+
+(** The following lemmas are specific versions of the projections of the above
+type classes for Leibniz equality. These lemmas allow us to enforce Coq not to
+use the setoid rewriting mechanism. *)
+Lemma idemp_L {A} f `{!@IdemP A (=) f} x : f x x = x.
+Proof. auto. Qed.
+Lemma comm_L {A B} f `{!@Comm A B (=) f} x y : f x y = f y x.
+Proof. auto. Qed.
+Lemma left_id_L {A} i f `{!@LeftId A (=) i f} x : f i x = x.
+Proof. auto. Qed.
+Lemma right_id_L {A} i f `{!@RightId A (=) i f} x : f x i = x.
+Proof. auto. Qed.
+Lemma assoc_L {A} f `{!@Assoc A (=) f} x y z : f x (f y z) = f (f x y) z.
+Proof. auto. Qed.
+Lemma left_absorb_L {A} i f `{!@LeftAbsorb A (=) i f} x : f i x = i.
+Proof. auto. Qed.
+Lemma right_absorb_L {A} i f `{!@RightAbsorb A (=) i f} x : f x i = i.
+Proof. auto. Qed.
+
+(** ** Generic orders *)
+(** The classes [PreOrder], [PartialOrder], and [TotalOrder] use an arbitrary
+relation [R] instead of [⊆] to support multiple orders on the same type. *)
+Definition strict {A} (R : relation A) : relation A := λ X Y, R X Y ∧ ¬R Y X.
+Global Instance: Params (@strict) 2 := {}.
+
+Class PartialOrder {A} (R : relation A) : Prop := {
+ partial_order_pre :> PreOrder R;
+ partial_order_anti_symm :> AntiSymm (=) R
+}.
+Global Hint Mode PartialOrder ! ! : typeclass_instances.
+
+Class TotalOrder {A} (R : relation A) : Prop := {
+ total_order_partial :> PartialOrder R;
+ total_order_trichotomy :> Trichotomy (strict R)
+}.
+Global Hint Mode TotalOrder ! ! : typeclass_instances.
+
+(** * Logic *)
+Global Instance prop_inhabited : Inhabited Prop := populate True.
+
+Notation "(∧)" := and (only parsing) : stdpp_scope.
+Notation "( A ∧.)" := (and A) (only parsing) : stdpp_scope.
+Notation "(.∧ B )" := (λ A, A ∧ B) (only parsing) : stdpp_scope.
+
+Notation "(∨)" := or (only parsing) : stdpp_scope.
+Notation "( A ∨.)" := (or A) (only parsing) : stdpp_scope.
+Notation "(.∨ B )" := (λ A, A ∨ B) (only parsing) : stdpp_scope.
+
+Notation "(↔)" := iff (only parsing) : stdpp_scope.
+Notation "( A ↔.)" := (iff A) (only parsing) : stdpp_scope.
+Notation "(.↔ B )" := (λ A, A ↔ B) (only parsing) : stdpp_scope.
+
+Global Hint Extern 0 (_ ↔ _) => reflexivity : core.
+Global Hint Extern 0 (_ ↔ _) => symmetry; assumption : core.
+
+Lemma or_l P Q : ¬Q → P ∨ Q ↔ P.
+Proof. tauto. Qed.
+Lemma or_r P Q : ¬P → P ∨ Q ↔ Q.
+Proof. tauto. Qed.
+Lemma and_wlog_l (P Q : Prop) : (Q → P) → Q → (P ∧ Q).
+Proof. tauto. Qed.
+Lemma and_wlog_r (P Q : Prop) : P → (P → Q) → (P ∧ Q).
+Proof. tauto. Qed.
+Lemma impl_transitive (P Q R : Prop) : (P → Q) → (Q → R) → (P → R).
+Proof. tauto. Qed.
+Lemma forall_proper {A} (P Q : A → Prop) :
+ (∀ x, P x ↔ Q x) → (∀ x, P x) ↔ (∀ x, Q x).
+Proof. firstorder. Qed.
+Lemma exist_proper {A} (P Q : A → Prop) :
+ (∀ x, P x ↔ Q x) → (∃ x, P x) ↔ (∃ x, Q x).
+Proof. firstorder. Qed.
+
+Global Instance eq_comm {A} : Comm (↔) (=@{A}).
+Proof. red; intuition. Qed.
+Global Instance flip_eq_comm {A} : Comm (↔) (λ x y, y =@{A} x).
+Proof. red; intuition. Qed.
+Global Instance iff_comm : Comm (↔) (↔).
+Proof. red; intuition. Qed.
+Global Instance and_comm : Comm (↔) (∧).
+Proof. red; intuition. Qed.
+Global Instance and_assoc : Assoc (↔) (∧).
+Proof. red; intuition. Qed.
+Global Instance and_idemp : IdemP (↔) (∧).
+Proof. red; intuition. Qed.
+Global Instance or_comm : Comm (↔) (∨).
+Proof. red; intuition. Qed.
+Global Instance or_assoc : Assoc (↔) (∨).
+Proof. red; intuition. Qed.
+Global Instance or_idemp : IdemP (↔) (∨).
+Proof. red; intuition. Qed.
+Global Instance True_and : LeftId (↔) True (∧).
+Proof. red; intuition. Qed.
+Global Instance and_True : RightId (↔) True (∧).
+Proof. red; intuition. Qed.
+Global Instance False_and : LeftAbsorb (↔) False (∧).
+Proof. red; intuition. Qed.
+Global Instance and_False : RightAbsorb (↔) False (∧).
+Proof. red; intuition. Qed.
+Global Instance False_or : LeftId (↔) False (∨).
+Proof. red; intuition. Qed.
+Global Instance or_False : RightId (↔) False (∨).
+Proof. red; intuition. Qed.
+Global Instance True_or : LeftAbsorb (↔) True (∨).
+Proof. red; intuition. Qed.
+Global Instance or_True : RightAbsorb (↔) True (∨).
+Proof. red; intuition. Qed.
+Global Instance True_impl : LeftId (↔) True impl.
+Proof. unfold impl. red; intuition. Qed.
+Global Instance impl_True : RightAbsorb (↔) True impl.
+Proof. unfold impl. red; intuition. Qed.
+
+
+(** * Common data types *)
+(** ** Functions *)
+Notation "(→)" := (λ A B, A → B) (only parsing) : stdpp_scope.
+Notation "( A →.)" := (λ B, A → B) (only parsing) : stdpp_scope.
+Notation "(.→ B )" := (λ A, A → B) (only parsing) : stdpp_scope.
+
+Notation "t $ r" := (t r)
+ (at level 65, right associativity, only parsing) : stdpp_scope.
+Notation "($)" := (λ f x, f x) (only parsing) : stdpp_scope.
+Notation "(.$ x )" := (λ f, f x) (only parsing) : stdpp_scope.
+
+Infix "∘" := compose : stdpp_scope.
+Notation "(∘)" := compose (only parsing) : stdpp_scope.
+Notation "( f ∘.)" := (compose f) (only parsing) : stdpp_scope.
+Notation "(.∘ f )" := (λ g, compose g f) (only parsing) : stdpp_scope.
+
+Global Instance impl_inhabited {A} `{Inhabited B} : Inhabited (A → B) :=
+ populate (λ _, inhabitant).
+
+(** Ensure that [simpl] unfolds [id], [compose], and [flip] when fully
+applied. *)
+Global Arguments id _ _ / : assert.
+Global Arguments compose _ _ _ _ _ _ / : assert.
+Global Arguments flip _ _ _ _ _ _ / : assert.
+Global Arguments const _ _ _ _ / : assert.
+Global Typeclasses Transparent id compose flip const.
+
+Definition fun_map {A A' B B'} (f: A' → A) (g: B → B') (h : A → B) : A' → B' :=
+ g ∘ h ∘ f.
+
+Global Instance const_proper `{R1 : relation A, R2 : relation B} (x : B) :
+ Reflexive R2 → Proper (R1 ==> R2) (λ _, x).
+Proof. intros ? y1 y2; reflexivity. Qed.
+
+Global Instance id_inj {A} : Inj (=) (=) (@id A).
+Proof. intros ??; auto. Qed.
+Global Instance compose_inj {A B C} R1 R2 R3 (f : A → B) (g : B → C) :
+ Inj R1 R2 f → Inj R2 R3 g → Inj R1 R3 (g ∘ f).
+Proof. red; intuition. Qed.
+
+Global Instance id_surj {A} : Surj (=) (@id A).
+Proof. intros y; exists y; reflexivity. Qed.
+Global Instance compose_surj {A B C} R (f : A → B) (g : B → C) :
+ Surj (=) f → Surj R g → Surj R (g ∘ f).
+Proof.
+ intros ?? x. unfold compose. destruct (surj g x) as [y ?].
+ destruct (surj f y) as [z ?]. exists z. congruence.
+Qed.
+
+Global Instance const2_comm {A B} (x : B) : Comm (=) (λ _ _ : A, x).
+Proof. intros ?; reflexivity. Qed.
+Global Instance const2_assoc {A} (x : A) : Assoc (=) (λ _ _ : A, x).
+Proof. intros ???; reflexivity. Qed.
+Global Instance id1_assoc {A} : Assoc (=) (λ x _ : A, x).
+Proof. intros ???; reflexivity. Qed.
+Global Instance id2_assoc {A} : Assoc (=) (λ _ x : A, x).
+Proof. intros ???; reflexivity. Qed.
+Global Instance id1_idemp {A} : IdemP (=) (λ x _ : A, x).
+Proof. intros ?; reflexivity. Qed.
+Global Instance id2_idemp {A} : IdemP (=) (λ _ x : A, x).
+Proof. intros ?; reflexivity. Qed.
+
+(** ** Lists *)
+Global Instance list_inhabited {A} : Inhabited (list A) := populate [].
+
+Definition zip_with {A B C} (f : A → B → C) : list A → list B → list C :=
+ fix go l1 l2 :=
+ match l1, l2 with x1 :: l1, x2 :: l2 => f x1 x2 :: go l1 l2 | _ , _ => [] end.
+Notation zip := (zip_with pair).
+
+(** ** Booleans *)
+(** The following coercion allows us to use Booleans as propositions. *)
+Coercion Is_true : bool >-> Sortclass.
+Global Hint Unfold Is_true : core.
+Global Hint Immediate Is_true_eq_left : core.
+Global Hint Resolve orb_prop_intro andb_prop_intro : core.
+Notation "(&&)" := andb (only parsing).
+Notation "(||)" := orb (only parsing).
+Infix "&&*" := (zip_with (&&)) (at level 40).
+Infix "||*" := (zip_with (||)) (at level 50).
+
+Global Instance bool_inhabated : Inhabited bool := populate true.
+
+Definition bool_le (β1 β2 : bool) : Prop := negb β1 || β2.
+Infix "=.>" := bool_le (at level 70).
+Infix "=.>*" := (Forall2 bool_le) (at level 70).
+Global Instance: PartialOrder bool_le.
+Proof. repeat split; repeat intros [|]; compute; tauto. Qed.
+
+Lemma andb_True b1 b2 : b1 && b2 ↔ b1 ∧ b2.
+Proof. destruct b1, b2; simpl; tauto. Qed.
+Lemma orb_True b1 b2 : b1 || b2 ↔ b1 ∨ b2.
+Proof. destruct b1, b2; simpl; tauto. Qed.
+Lemma negb_True b : negb b ↔ ¬b.
+Proof. destruct b; simpl; tauto. Qed.
+Lemma Is_true_true (b : bool) : b ↔ b = true.
+Proof. now destruct b. Qed.
+Lemma Is_true_true_1 (b : bool) : b → b = true.
+Proof. apply Is_true_true. Qed.
+Lemma Is_true_true_2 (b : bool) : b = true → b.
+Proof. apply Is_true_true. Qed.
+Lemma Is_true_false (b : bool) : ¬ b ↔ b = false.
+Proof. now destruct b; simpl. Qed.
+Lemma Is_true_false_1 (b : bool) : ¬b → b = false.
+Proof. apply Is_true_false. Qed.
+Lemma Is_true_false_2 (b : bool) : b = false → ¬b.
+Proof. apply Is_true_false. Qed.
+
+(** ** Unit *)
+Global Instance unit_equiv : Equiv unit := λ _ _, True.
+Global Instance unit_equivalence : Equivalence (≡@{unit}).
+Proof. repeat split. Qed.
+Global Instance unit_leibniz : LeibnizEquiv unit.
+Proof. intros [] []; reflexivity. Qed.
+Global Instance unit_inhabited: Inhabited unit := populate ().
+
+(** ** Empty *)
+Global Instance Empty_set_equiv : Equiv Empty_set := λ _ _, True.
+Global Instance Empty_set_equivalence : Equivalence (≡@{Empty_set}).
+Proof. repeat split. Qed.
+Global Instance Empty_set_leibniz : LeibnizEquiv Empty_set.
+Proof. intros [] []; reflexivity. Qed.
+
+(** ** Products *)
+Notation "( x ,.)" := (pair x) (only parsing) : stdpp_scope.
+Notation "(., y )" := (λ x, (x,y)) (only parsing) : stdpp_scope.
+
+Notation "p .1" := (fst p) (at level 2, left associativity, format "p .1").
+Notation "p .2" := (snd p) (at level 2, left associativity, format "p .2").
+
+Global Instance: Params (@pair) 2 := {}.
+Global Instance: Params (@fst) 2 := {}.
+Global Instance: Params (@snd) 2 := {}.
+
+Global Instance: Params (@curry) 3 := {}.
+Global Instance: Params (@uncurry) 3 := {}.
+
+Definition uncurry3 {A B C D} (f : A → B → C → D) (p : A * B * C) : D :=
+ let '(a,b,c) := p in f a b c.
+Global Instance: Params (@uncurry3) 4 := {}.
+Definition uncurry4 {A B C D E} (f : A → B → C → D → E) (p : A * B * C * D) : E :=
+ let '(a,b,c,d) := p in f a b c d.
+Global Instance: Params (@uncurry4) 5 := {}.
+
+Definition curry3 {A B C D} (f : A * B * C → D) (a : A) (b : B) (c : C) : D :=
+ f (a, b, c).
+Global Instance: Params (@curry3) 4 := {}.
+Definition curry4 {A B C D E} (f : A * B * C * D → E)
+ (a : A) (b : B) (c : C) (d : D) : E := f (a, b, c, d).
+Global Instance: Params (@curry4) 5 := {}.
+
+Definition prod_map {A A' B B'} (f: A → A') (g: B → B') (p : A * B) : A' * B' :=
+ (f (p.1), g (p.2)).
+Global Instance: Params (@prod_map) 4 := {}.
+Global Arguments prod_map {_ _ _ _} _ _ !_ / : assert.
+
+Definition prod_zip {A A' A'' B B' B''} (f : A → A' → A'') (g : B → B' → B'')
+ (p : A * B) (q : A' * B') : A'' * B'' := (f (p.1) (q.1), g (p.2) (q.2)).
+Global Instance: Params (@prod_zip) 6 := {}.
+Global Arguments prod_zip {_ _ _ _ _ _} _ _ !_ !_ / : assert.
+
+Definition prod_swap {A B} (p : A * B) : B * A := (p.2, p.1).
+Global Arguments prod_swap {_ _} !_ /.
+Global Instance: Params (@prod_swap) 2 := {}.
+
+Global Instance prod_inhabited {A B} (iA : Inhabited A)
+ (iB : Inhabited B) : Inhabited (A * B) :=
+ match iA, iB with populate x, populate y => populate (x,y) end.
+
+(** Note that we need eta for products for the [uncurry_curry] lemmas to hold
+in non-applied form ([uncurry (curry f) = f]). *)
+Lemma curry_uncurry {A B C} (f : A → B → C) : curry (uncurry f) = f.
+Proof. reflexivity. Qed.
+Lemma uncurry_curry {A B C} (f : A * B → C) p : uncurry (curry f) p = f p.
+Proof. destruct p; reflexivity. Qed.
+Lemma curry3_uncurry3 {A B C D} (f : A → B → C → D) : curry3 (uncurry3 f) = f.
+Proof. reflexivity. Qed.
+Lemma uncurry3_curry3 {A B C D} (f : A * B * C → D) p :
+ uncurry3 (curry3 f) p = f p.
+Proof. destruct p as [[??] ?]; reflexivity. Qed.
+Lemma curry4_uncurry4 {A B C D E} (f : A → B → C → D → E) :
+ curry4 (uncurry4 f) = f.
+Proof. reflexivity. Qed.
+Lemma uncurry4_curry4 {A B C D E} (f : A * B * C * D → E) p :
+ uncurry4 (curry4 f) p = f p.
+Proof. destruct p as [[[??] ?] ?]; reflexivity. Qed.
+
+(** [pair_eq] as a name is more consistent with our usual naming. *)
+Lemma pair_eq {A B} (a1 a2 : A) (b1 b2 : B) :
+ (a1, b1) = (a2, b2) ↔ a1 = a2 ∧ b1 = b2.
+Proof. apply pair_equal_spec. Qed.
+
+Global Instance pair_inj {A B} : Inj2 (=) (=) (=) (@pair A B).
+Proof. injection 1; auto. Qed.
+Global Instance prod_map_inj {A A' B B'} (f : A → A') (g : B → B') :
+ Inj (=) (=) f → Inj (=) (=) g → Inj (=) (=) (prod_map f g).
+Proof.
+ intros ?? [??] [??] ?; simpl in *; f_equal;
+ [apply (inj f)|apply (inj g)]; congruence.
+Qed.
+
+Elpi Override TC - ProperProxy Proper.
+
+Global Instance prod_swap_cancel {A B} :
+ Cancel (=) (@prod_swap A B) (@prod_swap B A).
+Proof. intros [??]; reflexivity. Qed.
+Global Instance prod_swap_inj {A B} : Inj (=) (=) (@prod_swap A B).
+Proof. apply cancel_inj. Qed.
+Global Instance prod_swap_surj {A B} : Surj (=) (@prod_swap A B).
+Proof. apply cancel_surj. Qed.
+
+Definition prod_relation {A B} (R1 : relation A) (R2 : relation B) :
+ relation (A * B) := λ x y, R1 (x.1) (y.1) ∧ R2 (x.2) (y.2).
+
+Section prod_relation.
+ Context `{RA : relation A, RB : relation B}.
+
+ Global Instance prod_relation_refl :
+ Reflexive RA → Reflexive RB → Reflexive (prod_relation RA RB).
+ Proof. firstorder eauto. Qed.
+ Global Instance prod_relation_sym :
+ Symmetric RA → Symmetric RB → Symmetric (prod_relation RA RB).
+ Proof. firstorder eauto. Qed.
+ Global Instance prod_relation_trans :
+ Transitive RA → Transitive RB → Transitive (prod_relation RA RB).
+ Proof. firstorder eauto. Qed.
+ Global Instance prod_relation_equiv :
+ Equivalence RA → Equivalence RB → Equivalence (prod_relation RA RB).
+ Proof. split; apply _. Qed.
+
+ Global Instance pair_proper' : Proper (RA ==> RB ==> prod_relation RA RB) pair.
+ Proof. firstorder eauto. Qed.
+ Global Instance pair_inj' : Inj2 RA RB (prod_relation RA RB) pair.
+ Proof. inversion_clear 1; eauto. Qed.
+ Global Instance fst_proper' : Proper (prod_relation RA RB ==> RA) fst.
+ Proof. firstorder eauto. Qed.
+ Global Instance snd_proper' : Proper (prod_relation RA RB ==> RB) snd.
+ Proof. firstorder eauto. Qed.
+
+ Global Instance prod_swap_proper' :
+ Proper (prod_relation RA RB ==> prod_relation RB RA) prod_swap.
+ Proof. firstorder eauto. Qed.
+
+ Global Instance curry_proper' `{RC : relation C} :
+ Proper ((prod_relation RA RB ==> RC) ==> RA ==> RB ==> RC) curry.
+ Proof. firstorder eauto. Qed.
+ Global Instance uncurry_proper' `{RC : relation C} :
+ Proper ((RA ==> RB ==> RC) ==> prod_relation RA RB ==> RC) uncurry.
+ Proof. intros f1 f2 Hf [x1 y1] [x2 y2] []; apply Hf; assumption. Qed.
+
+ Global Instance curry3_proper' `{RC : relation C, RD : relation D} :
+ Proper ((prod_relation (prod_relation RA RB) RC ==> RD) ==>
+ RA ==> RB ==> RC ==> RD) curry3.
+ Proof. firstorder eauto. Qed.
+ Global Instance uncurry3_proper' `{RC : relation C, RD : relation D} :
+ Proper ((RA ==> RB ==> RC ==> RD) ==>
+ prod_relation (prod_relation RA RB) RC ==> RD) uncurry3.
+ Proof. intros f1 f2 Hf [[??] ?] [[??] ?] [[??] ?]; apply Hf; assumption. Qed.
+
+ Global Instance curry4_proper' `{RC : relation C, RD : relation D, RE : relation E} :
+ Proper ((prod_relation (prod_relation (prod_relation RA RB) RC) RD ==> RE) ==>
+ RA ==> RB ==> RC ==> RD ==> RE) curry4.
+ Proof. firstorder eauto. Qed.
+ Global Instance uncurry4_proper' `{RC : relation C, RD : relation D, RE : relation E} :
+ Proper ((RA ==> RB ==> RC ==> RD ==> RE) ==>
+ prod_relation (prod_relation (prod_relation RA RB) RC) RD ==> RE) uncurry4.
+ Proof.
+ intros f1 f2 Hf [[[??] ?] ?] [[[??] ?] ?] [[[??] ?] ?]; apply Hf; assumption.
+ Qed.
+End prod_relation.
+
+Global Instance prod_equiv `{Equiv A,Equiv B} : Equiv (A * B) :=
+ prod_relation (≡) (≡).
+
+(** Below we make [prod_equiv] type class opaque, so we first lift all
+instances *)
+Section prod_setoid.
+ Context `{Equiv A, Equiv B}.
+ Elpi Accumulate TC.Solver lp:{{
+ shorten tc-Coq.Classes.RelationClasses.{tc-Equivalence}.
+ :after "lastHook"
+ tc-Equivalence A RA R :-
+ RA = {{@equiv _ (@prod_equiv _ _ _ _)}},
+ RA' = {{@prod_relation _ _ _ _}},
+ coq.unify-eq RA RA' ok,
+ % coq.say A RA,
+ tc-Equivalence A RA' R.
+ }}.
+ (* Elpi Typecheck TC.Solver. *)
+
+ Global Instance prod_equivalence@{i} (C D: Type@{i}) `{Equiv C, Equiv D}:
+ @Equivalence C (≡@{C}) → @Equivalence D (≡@{D}) → @Equivalence (C * D) (≡@{C * D}) := _.
+
+ Elpi Accumulate TC.Solver lp:{{
+
+ pred remove_equiv_prod_equiv i:term, o:term.
+ remove_equiv_prod_equiv T1 T3 :-
+ T1 = {{@equiv _ (@prod_equiv _ _ _ _)}}, !,
+ T2 = {{@prod_relation lp:F lp:G lp:A lp:B}},
+ coq.unify-eq T1 T2 ok,
+ remove_equiv_prod_equiv A X,
+ remove_equiv_prod_equiv B Y,
+ {{@prod_relation lp:F lp:G lp:X lp:Y}} = T3.
+ remove_equiv_prod_equiv (app L1) (app L2) :- !,
+ std.map L1 remove_equiv_prod_equiv L2.
+ remove_equiv_prod_equiv A A.
+
+ shorten tc-Coq.Classes.Morphisms.{tc-Proper}.
+
+ :after "lastHook"
+ tc-Proper A B C R :-
+ B = {{ @respectful _ _ _ _ }},
+ remove_equiv_prod_equiv B B1,
+ tc-Proper A B1 C R.
+
+ tc-Proper A {{@respectful lp:K1 lp:K2 lp:B1 (@respectful lp:K3 lp:K4 lp:B2 lp:B3)}} C S :-
+ C1 = {{ @equiv _ _ }},
+ C2 = {{ @equiv _ _ }},
+ C3 = {{ @prod_relation _ _ _ _ }},
+ coq.unify-eq B1 C1 ok,
+ coq.unify-eq B2 C2 ok,
+ coq.unify-eq B3 C3 ok,
+ tc-Proper A {{@respectful lp:K1 lp:K2 lp:C1 (@respectful lp:K3 lp:K4 lp:C2 lp:C3)}} C S.
+
+ }}.
+ Elpi Typecheck TC.Solver.
+
+ Global Instance pair_proper : Proper ((≡) ==> (≡) ==> (≡@{A*B})) pair := _.
+
+ Elpi Accumulate TC.Solver lp:{{
+ shorten tc-elpi.apps.tc.tests.bigTest.{tc-Inj2}.
+ % shorten tc-bigTest.{tc-Inj2}.
+ :after "lastHook"
+ tc-Inj2 A B C RA RB RC F S :-
+ RC = app [global {coq.locate "equiv"} | _],
+ remove_equiv_prod_equiv RC RC',
+ tc-Inj2 A B C RA RB RC' F S.
+ }}.
+ Elpi Typecheck TC.Solver.
+
+ Global Instance pair_equiv_inj : Inj2 (≡) (≡) (≡@{A*B}) pair := _.
+ Global Instance fst_proper : Proper ((≡@{A*B}) ==> (≡)) fst := _.
+ Global Instance snd_proper : Proper ((≡@{A*B}) ==> (≡)) snd := _.
+
+ Global Instance prod_swap_proper :
+ Proper ((≡@{A*B}) ==> (≡@{B*A})) prod_swap := _.
+
+ Global Instance curry_proper `{Equiv C} :
+ Proper (((≡@{A*B}) ==> (≡@{C})) ==> (≡) ==> (≡) ==> (≡)) curry := _.
+ Global Instance uncurry_proper `{Equiv C} :
+ Proper (((≡) ==> (≡) ==> (≡)) ==> (≡@{A*B}) ==> (≡@{C})) uncurry := _.
+
+ Global Instance curry3_proper `{Equiv C, Equiv D} :
+ Proper (((≡@{A*B*C}) ==> (≡@{D})) ==>
+ (≡) ==> (≡) ==> (≡) ==> (≡)) curry3 := _.
+ Global Instance uncurry3_proper `{Equiv C, Equiv D} :
+ Proper (((≡) ==> (≡) ==> (≡) ==> (≡)) ==>
+ (≡@{A*B*C}) ==> (≡@{D})) uncurry3 := _.
+
+ Global Instance curry4_proper `{Equiv C, Equiv D, Equiv E} :
+ Proper (((≡@{A*B*C*D}) ==> (≡@{E})) ==>
+ (≡) ==> (≡) ==> (≡) ==> (≡) ==> (≡)) curry4 := _.
+ Global Instance uncurry4_proper `{Equiv C, Equiv D, Equiv E} :
+ Proper (((≡) ==> (≡) ==> (≡) ==> (≡) ==> (≡)) ==>
+ (≡@{A*B*C*D}) ==> (≡@{E})) uncurry4 := _.
+
+ Lemma pair_equiv (a1 a2 : A) (b1 b2 : B) :
+ (a1, b1) ≡ (a2, b2) ↔ a1 ≡ a2 ∧ b1 ≡ b2.
+ Proof. reflexivity. Qed.
+End prod_setoid.
+
+Global Typeclasses Opaque prod_equiv.
+
+Global Instance prod_leibniz `{LeibnizEquiv A, LeibnizEquiv B} :
+ LeibnizEquiv (A * B).
+Proof. intros [??] [??] [??]; f_equal; apply leibniz_equiv; auto. Qed.
+
+(** ** Sums *)
+Definition sum_map {A A' B B'} (f: A → A') (g: B → B') (xy : A + B) : A' + B' :=
+ match xy with inl x => inl (f x) | inr y => inr (g y) end.
+Global Arguments sum_map {_ _ _ _} _ _ !_ / : assert.
+
+Global Instance sum_inhabited_l {A B} (iA : Inhabited A) : Inhabited (A + B) :=
+ match iA with populate x => populate (inl x) end.
+Global Instance sum_inhabited_r {A B} (iB : Inhabited B) : Inhabited (A + B) :=
+ match iB with populate y => populate (inr y) end.
+
+Global Instance inl_inj {A B} : Inj (=) (=) (@inl A B).
+Proof. injection 1; auto. Qed.
+Global Instance inr_inj {A B} : Inj (=) (=) (@inr A B).
+Proof. injection 1; auto. Qed.
+
+Global Instance sum_map_inj {A A' B B'} (f : A → A') (g : B → B') :
+ Inj (=) (=) f → Inj (=) (=) g → Inj (=) (=) (sum_map f g).
+Proof. intros ?? [?|?] [?|?] [=]; f_equal; apply (inj _); auto. Qed.
+
+Inductive sum_relation {A B}
+ (RA : relation A) (RB : relation B) : relation (A + B) :=
+ | inl_related x1 x2 : RA x1 x2 → sum_relation RA RB (inl x1) (inl x2)
+ | inr_related y1 y2 : RB y1 y2 → sum_relation RA RB (inr y1) (inr y2).
+
+Section sum_relation.
+ Context `{RA : relation A, RB : relation B}.
+ Global Instance sum_relation_refl :
+ Reflexive RA → Reflexive RB → Reflexive (sum_relation RA RB).
+ Proof. intros ?? [?|?]; constructor; reflexivity. Qed.
+ Global Instance sum_relation_sym :
+ Symmetric RA → Symmetric RB → Symmetric (sum_relation RA RB).
+ Proof. destruct 3; constructor; eauto. Qed.
+ Global Instance sum_relation_trans :
+ Transitive RA → Transitive RB → Transitive (sum_relation RA RB).
+ Proof. destruct 3; inversion_clear 1; constructor; eauto. Qed.
+ Global Instance sum_relation_equiv :
+ Equivalence RA → Equivalence RB → Equivalence (sum_relation RA RB).
+ Proof. split; apply _. Qed.
+ Global Instance inl_proper' : Proper (RA ==> sum_relation RA RB) inl.
+ Proof. constructor; auto. Qed.
+ Global Instance inr_proper' : Proper (RB ==> sum_relation RA RB) inr.
+ Proof. constructor; auto. Qed.
+ Global Instance inl_inj' : Inj RA (sum_relation RA RB) inl.
+ Proof. inversion_clear 1; auto. Qed.
+ Global Instance inr_inj' : Inj RB (sum_relation RA RB) inr.
+ Proof. inversion_clear 1; auto. Qed.
+End sum_relation.
+
+Global Instance sum_equiv `{Equiv A, Equiv B} : Equiv (A + B) := sum_relation (≡) (≡).
+
+Elpi Accumulate TC.Solver lp:{{
+ pred remove_equiv_sum_equiv i:term, o:term.
+ remove_equiv_sum_equiv T1 T3 :-
+ T1 = {{@equiv _ (@sum_equiv _ _ _ _)}}, !,
+ T2 = {{@sum_relation lp:F lp:G lp:A lp:B}},
+ coq.unify-eq T1 T2 ok,
+ remove_equiv_sum_equiv A X,
+ remove_equiv_sum_equiv B Y,
+ {{@sum_relation lp:F lp:G lp:X lp:Y}} = T3.
+ remove_equiv_sum_equiv (app L1) (app L2) :- !,
+ std.map L1 remove_equiv_sum_equiv L2.
+ remove_equiv_sum_equiv A A.
+
+ shorten tc-Coq.Classes.Morphisms.{tc-Proper}.
+ :after "lastHook"
+ tc-Proper A B C R :-
+ B = {{ @respectful _ _ _ _ }},
+ remove_equiv_sum_equiv B B1,
+ tc-Proper A B1 C R.
+}}.
+Elpi Typecheck TC.Solver.
+
+
+Global Instance inl_proper `{Equiv A, Equiv B} : Proper ((≡) ==> (≡)) (@inl A B) := _.
+Global Instance inr_proper `{Equiv A, Equiv B} : Proper ((≡) ==> (≡)) (@inr A B) := _.
+
+
+Elpi Accumulate TC.Solver lp:{{
+ shorten tc-elpi.apps.tc.tests.bigTest.{tc-Inj}.
+ % shorten tc-bigTest.{tc-Inj}.
+ :after "lastHook"
+ tc-Inj A B R1 R2 S C :-
+ R2 = {{@equiv (sum _ _) sum_equiv}},
+ R2' = {{sum_relation _ _}},
+ coq.unify-eq R2 R2' ok,
+ tc-Inj A B R1 R2' S C.
+}}.
+Elpi Typecheck TC.Solver.
+
+Global Instance inl_equiv_inj `{Equiv A, Equiv B} : Inj (≡) (≡) (@inl A B) := _.
+Global Instance inr_equiv_inj `{Equiv A, Equiv B} : Inj (≡) (≡) (@inr A B) := _.
+Global Typeclasses Opaque sum_equiv.
+
+(** ** Option *)
+Global Instance option_inhabited {A} : Inhabited (option A) := populate None.
+
+(** ** Sigma types *)
+Global Arguments existT {_ _} _ _ : assert.
+Global Arguments projT1 {_ _} _ : assert.
+Global Arguments projT2 {_ _} _ : assert.
+
+Global Arguments exist {_} _ _ _ : assert.
+Global Arguments proj1_sig {_ _} _ : assert.
+Global Arguments proj2_sig {_ _} _ : assert.
+Notation "x ↾ p" := (exist _ x p) (at level 20) : stdpp_scope.
+Notation "` x" := (proj1_sig x) (at level 10, format "` x") : stdpp_scope.
+
+Lemma proj1_sig_inj {A} (P : A → Prop) x (Px : P x) y (Py : P y) :
+ x↾Px = y↾Py → x = y.
+Proof. injection 1; trivial. Qed.
+
+Section sig_map.
+ Context `{P : A → Prop} `{Q : B → Prop} (f : A → B) (Hf : ∀ x, P x → Q (f x)).
+ Definition sig_map (x : sig P) : sig Q := f (`x) ↾ Hf _ (proj2_sig x).
+ Global Instance sig_map_inj:
+ (∀ x, ProofIrrel (P x)) → Inj (=) (=) f → Inj (=) (=) sig_map.
+ Proof.
+ intros ?? [x Hx] [y Hy]. injection 1. intros Hxy.
+ apply (inj f) in Hxy; subst. rewrite (proof_irrel _ Hy). auto.
+ Qed.
+End sig_map.
+Global Arguments sig_map _ _ _ _ _ _ !_ / : assert.
+
+Definition proj1_ex {P : Prop} {Q : P → Prop} (p : ∃ x, Q x) : P :=
+ let '(ex_intro _ x _) := p in x.
+Definition proj2_ex {P : Prop} {Q : P → Prop} (p : ∃ x, Q x) : Q (proj1_ex p) :=
+ let '(ex_intro _ x H) := p in H.
+
+(** * Operations on sets *)
+(** We define operational type classes for the traditional operations and
+relations on sets: the empty set [∅], the union [(∪)],
+intersection [(∩)], and difference [(∖)], the singleton [{[_]}], the subset
+[(⊆)] and element of [(∈)] relation, and disjointess [(##)]. *)
+Class Empty A := empty: A.
+Global Hint Mode Empty ! : typeclass_instances.
+Notation "∅" := empty (format "∅") : stdpp_scope.
+
+Global Instance empty_inhabited `(Empty A) : Inhabited A := populate ∅.
+
+Class Union A := union: A → A → A.
+Global Hint Mode Union ! : typeclass_instances.
+Global Instance: Params (@union) 2 := {}.
+Infix "∪" := union (at level 50, left associativity) : stdpp_scope.
+Notation "(∪)" := union (only parsing) : stdpp_scope.
+Notation "( x ∪.)" := (union x) (only parsing) : stdpp_scope.
+Notation "(.∪ x )" := (λ y, union y x) (only parsing) : stdpp_scope.
+Infix "∪*" := (zip_with (∪)) (at level 50, left associativity) : stdpp_scope.
+Notation "(∪*)" := (zip_with (∪)) (only parsing) : stdpp_scope.
+
+Definition union_list `{Empty A} `{Union A} : list A → A := fold_right (∪) ∅.
+Global Arguments union_list _ _ _ !_ / : assert.
+Notation "⋃ l" := (union_list l) (at level 20, format "⋃ l") : stdpp_scope.
+
+Class Intersection A := intersection: A → A → A.
+Global Hint Mode Intersection ! : typeclass_instances.
+Global Instance: Params (@intersection) 2 := {}.
+Infix "∩" := intersection (at level 40) : stdpp_scope.
+Notation "(∩)" := intersection (only parsing) : stdpp_scope.
+Notation "( x ∩.)" := (intersection x) (only parsing) : stdpp_scope.
+Notation "(.∩ x )" := (λ y, intersection y x) (only parsing) : stdpp_scope.
+
+Class Difference A := difference: A → A → A.
+Global Hint Mode Difference ! : typeclass_instances.
+Global Instance: Params (@difference) 2 := {}.
+Infix "∖" := difference (at level 40, left associativity) : stdpp_scope.
+Notation "(∖)" := difference (only parsing) : stdpp_scope.
+Notation "( x ∖.)" := (difference x) (only parsing) : stdpp_scope.
+Notation "(.∖ x )" := (λ y, difference y x) (only parsing) : stdpp_scope.
+Infix "∖*" := (zip_with (∖)) (at level 40, left associativity) : stdpp_scope.
+Notation "(∖*)" := (zip_with (∖)) (only parsing) : stdpp_scope.
+
+Class Singleton A B := singleton: A → B.
+Global Hint Mode Singleton - ! : typeclass_instances.
+Global Instance: Params (@singleton) 3 := {}.
+Notation "{[ x ]}" := (singleton x) (at level 1) : stdpp_scope.
+Notation "{[ x ; y ; .. ; z ]}" :=
+ (union .. (union (singleton x) (singleton y)) .. (singleton z))
+ (at level 1) : stdpp_scope.
+
+Class SubsetEq A := subseteq: relation A.
+Global Hint Mode SubsetEq ! : typeclass_instances.
+Global Instance: Params (@subseteq) 2 := {}.
+Infix "⊆" := subseteq (at level 70) : stdpp_scope.
+Notation "(⊆)" := subseteq (only parsing) : stdpp_scope.
+Notation "( X ⊆.)" := (subseteq X) (only parsing) : stdpp_scope.
+Notation "(.⊆ X )" := (λ Y, Y ⊆ X) (only parsing) : stdpp_scope.
+Notation "X ⊈ Y" := (¬X ⊆ Y) (at level 70) : stdpp_scope.
+Notation "(⊈)" := (λ X Y, X ⊈ Y) (only parsing) : stdpp_scope.
+Notation "( X ⊈.)" := (λ Y, X ⊈ Y) (only parsing) : stdpp_scope.
+Notation "(.⊈ X )" := (λ Y, Y ⊈ X) (only parsing) : stdpp_scope.
+
+Infix "⊆@{ A }" := (@subseteq A _) (at level 70, only parsing) : stdpp_scope.
+Notation "(⊆@{ A } )" := (@subseteq A _) (only parsing) : stdpp_scope.
+
+Infix "⊆*" := (Forall2 (⊆)) (at level 70) : stdpp_scope.
+Notation "(⊆*)" := (Forall2 (⊆)) (only parsing) : stdpp_scope.
+
+Global Hint Extern 0 (_ ⊆ _) => reflexivity : core.
+Global Hint Extern 0 (_ ⊆* _) => reflexivity : core.
+
+Infix "⊂" := (strict (⊆)) (at level 70) : stdpp_scope.
+Notation "(⊂)" := (strict (⊆)) (only parsing) : stdpp_scope.
+Notation "( X ⊂.)" := (strict (⊆) X) (only parsing) : stdpp_scope.
+Notation "(.⊂ X )" := (λ Y, Y ⊂ X) (only parsing) : stdpp_scope.
+Notation "X ⊄ Y" := (¬X ⊂ Y) (at level 70) : stdpp_scope.
+Notation "(⊄)" := (λ X Y, X ⊄ Y) (only parsing) : stdpp_scope.
+Notation "( X ⊄.)" := (λ Y, X ⊄ Y) (only parsing) : stdpp_scope.
+Notation "(.⊄ X )" := (λ Y, Y ⊄ X) (only parsing) : stdpp_scope.
+
+Infix "⊂@{ A }" := (strict (⊆@{A})) (at level 70, only parsing) : stdpp_scope.
+Notation "(⊂@{ A } )" := (strict (⊆@{A})) (only parsing) : stdpp_scope.
+
+Notation "X ⊆ Y ⊆ Z" := (X ⊆ Y ∧ Y ⊆ Z) (at level 70, Y at next level) : stdpp_scope.
+Notation "X ⊆ Y ⊂ Z" := (X ⊆ Y ∧ Y ⊂ Z) (at level 70, Y at next level) : stdpp_scope.
+Notation "X ⊂ Y ⊆ Z" := (X ⊂ Y ∧ Y ⊆ Z) (at level 70, Y at next level) : stdpp_scope.
+Notation "X ⊂ Y ⊂ Z" := (X ⊂ Y ∧ Y ⊂ Z) (at level 70, Y at next level) : stdpp_scope.
+
+(** We define type classes for multisets: disjoint union [⊎] and the multiset
+singleton [{[+ _ +]}]. Multiset literals [{[+ x1; ..; xn +]}] are defined in
+terms of iterated disjoint union [{[+ x1 +]} ⊎ .. ⊎ {[+ xn +]}], and are thus
+different from set literals [{[ x1; ..; xn ]}], which use [∪].
+
+Note that in principle we could reuse the set singleton [{[ _ ]}] for multisets,
+and define [{[+ x1; ..; xn +]}] as [{[ x1 ]} ⊎ .. ⊎ {[ xn ]}]. However, this
+would risk accidentally using [{[ x1; ..; xn ]}] for multisets (leading to
+unexpected results) and lead to ambigious pretty printing for [{[+ x +]}]. *)
+Class DisjUnion A := disj_union: A → A → A.
+Global Hint Mode DisjUnion ! : typeclass_instances.
+Global Instance: Params (@disj_union) 2 := {}.
+Infix "⊎" := disj_union (at level 50, left associativity) : stdpp_scope.
+Notation "(⊎)" := disj_union (only parsing) : stdpp_scope.
+Notation "( x ⊎.)" := (disj_union x) (only parsing) : stdpp_scope.
+Notation "(.⊎ x )" := (λ y, disj_union y x) (only parsing) : stdpp_scope.
+
+Class SingletonMS A B := singletonMS: A → B.
+Global Hint Mode SingletonMS - ! : typeclass_instances.
+Global Instance: Params (@singletonMS) 3 := {}.
+Notation "{[+ x +]}" := (singletonMS x)
+ (at level 1, format "{[+ x +]}") : stdpp_scope.
+Notation "{[+ x ; y ; .. ; z +]}" :=
+ (disj_union .. (disj_union (singletonMS x) (singletonMS y)) .. (singletonMS z))
+ (at level 1, format "{[+ x ; y ; .. ; z +]}") : stdpp_scope.
+
+Definition option_to_set `{Singleton A C, Empty C} (mx : option A) : C :=
+ match mx with None => ∅ | Some x => {[ x ]} end.
+Fixpoint list_to_set `{Singleton A C, Empty C, Union C} (l : list A) : C :=
+ match l with [] => ∅ | x :: l => {[ x ]} ∪ list_to_set l end.
+Fixpoint list_to_set_disj `{SingletonMS A C, Empty C, DisjUnion C} (l : list A) : C :=
+ match l with [] => ∅ | x :: l => {[+ x +]} ⊎ list_to_set_disj l end.
+
+Class ScalarMul N A := scalar_mul : N → A → A.
+Global Hint Mode ScalarMul - ! : typeclass_instances.
+(** The [N] arguments is typically [nat] or [Z], so we do not want to rewrite
+in that. Hence, the value of [Params] is 3. *)
+Global Instance: Params (@scalar_mul) 3 := {}.
+(** The notation [*:] and level is taken from ssreflect, see
+https://github.com/math-comp/math-comp/blob/master/mathcomp/ssreflect/ssrnotations.v *)
+Infix "*:" := scalar_mul (at level 40) : stdpp_scope.
+Notation "(*:)" := scalar_mul (only parsing) : stdpp_scope.
+Notation "( x *:.)" := (scalar_mul x) (only parsing) : stdpp_scope.
+Notation "(.*: x )" := (λ y, scalar_mul y x) (only parsing) : stdpp_scope.
+
+(** The class [Lexico A] is used for the lexicographic order on [A]. This order
+is used to create finite maps, finite sets, etc, and is typically different from
+the order [(⊆)]. *)
+Class Lexico A := lexico: relation A.
+Global Hint Mode Lexico ! : typeclass_instances.
+
+Class ElemOf A B := elem_of: A → B → Prop.
+Global Hint Mode ElemOf - ! : typeclass_instances.
+Global Instance: Params (@elem_of) 3 := {}.
+Infix "∈" := elem_of (at level 70) : stdpp_scope.
+Notation "(∈)" := elem_of (only parsing) : stdpp_scope.
+Notation "( x ∈.)" := (elem_of x) (only parsing) : stdpp_scope.
+Notation "(.∈ X )" := (λ x, elem_of x X) (only parsing) : stdpp_scope.
+Notation "x ∉ X" := (¬x ∈ X) (at level 80) : stdpp_scope.
+Notation "(∉)" := (λ x X, x ∉ X) (only parsing) : stdpp_scope.
+Notation "( x ∉.)" := (λ X, x ∉ X) (only parsing) : stdpp_scope.
+Notation "(.∉ X )" := (λ x, x ∉ X) (only parsing) : stdpp_scope.
+
+Infix "∈@{ B }" := (@elem_of _ B _) (at level 70, only parsing) : stdpp_scope.
+Notation "(∈@{ B } )" := (@elem_of _ B _) (only parsing) : stdpp_scope.
+
+Notation "x ∉@{ B } X" := (¬x ∈@{B} X) (at level 80, only parsing) : stdpp_scope.
+Notation "(∉@{ B } )" := (λ x X, x ∉@{B} X) (only parsing) : stdpp_scope.
+
+Class Disjoint A := disjoint : A → A → Prop.
+Global Hint Mode Disjoint ! : typeclass_instances.
+Global Instance: Params (@disjoint) 2 := {}.
+Infix "##" := disjoint (at level 70) : stdpp_scope.
+Notation "(##)" := disjoint (only parsing) : stdpp_scope.
+Notation "( X ##.)" := (disjoint X) (only parsing) : stdpp_scope.
+Notation "(.## X )" := (λ Y, Y ## X) (only parsing) : stdpp_scope.
+
+Infix "##@{ A }" := (@disjoint A _) (at level 70, only parsing) : stdpp_scope.
+Notation "(##@{ A } )" := (@disjoint A _) (only parsing) : stdpp_scope.
+
+Infix "##*" := (Forall2 (##)) (at level 70) : stdpp_scope.
+Notation "(##*)" := (Forall2 (##)) (only parsing) : stdpp_scope.
+
+Global Hint Extern 0 (_ ## _) => symmetry; eassumption : core.
+Global Hint Extern 0 (_ ##* _) => symmetry; eassumption : core.
+
+Class Filter A B := filter: ∀ (P : A → Prop) `{∀ x, Decision (P x)}, B → B.
+Global Hint Mode Filter - ! : typeclass_instances.
+
+Class UpClose A B := up_close : A → B.
+Global Hint Mode UpClose - ! : typeclass_instances.
+Notation "↑ x" := (up_close x) (at level 20, format "↑ x").
+
+(** * Monadic operations *)
+(** We define operational type classes for the monadic operations bind, join
+and fmap. We use these type classes merely for convenient overloading of
+notations and do not formalize any theory on monads (we do not even define a
+class with the monad laws). *)
+Class MRet (M : Type → Type) := mret: ∀ {A}, A → M A.
+Global Arguments mret {_ _ _} _ : assert.
+Global Instance: Params (@mret) 3 := {}.
+Global Hint Mode MRet ! : typeclass_instances.
+
+Class MBind (M : Type → Type) := mbind : ∀ {A B}, (A → M B) → M A → M B.
+Global Arguments mbind {_ _ _ _} _ !_ / : assert.
+Global Instance: Params (@mbind) 4 := {}.
+Global Hint Mode MBind ! : typeclass_instances.
+
+Class MJoin (M : Type → Type) := mjoin: ∀ {A}, M (M A) → M A.
+Global Arguments mjoin {_ _ _} !_ / : assert.
+Global Instance: Params (@mjoin) 3 := {}.
+Global Hint Mode MJoin ! : typeclass_instances.
+
+Class FMap (M : Type → Type) := fmap : ∀ {A B}, (A → B) → M A → M B.
+Global Arguments fmap {_ _ _ _} _ !_ / : assert.
+Global Instance: Params (@fmap) 4 := {}.
+Global Hint Mode FMap ! : typeclass_instances.
+
+Class OMap (M : Type → Type) := omap: ∀ {A B}, (A → option B) → M A → M B.
+Global Arguments omap {_ _ _ _} _ !_ / : assert.
+Global Instance: Params (@omap) 4 := {}.
+Global Hint Mode OMap ! : typeclass_instances.
+
+Notation "m ≫= f" := (mbind f m) (at level 60, right associativity) : stdpp_scope.
+Notation "( m ≫=.)" := (λ f, mbind f m) (only parsing) : stdpp_scope.
+Notation "(.≫= f )" := (mbind f) (only parsing) : stdpp_scope.
+Notation "(≫=)" := (λ m f, mbind f m) (only parsing) : stdpp_scope.
+
+Notation "x ← y ; z" := (y ≫= (λ x : _, z))
+ (at level 20, y at level 100, z at level 200, only parsing) : stdpp_scope.
+
+Notation "' x ← y ; z" := (y ≫= (λ x : _, z))
+ (at level 20, x pattern, y at level 100, z at level 200, only parsing) : stdpp_scope.
+
+Infix "<$>" := fmap (at level 61, left associativity) : stdpp_scope.
+
+Notation "x ;; z" := (x ≫= λ _, z)
+ (at level 100, z at level 200, only parsing, right associativity): stdpp_scope.
+
+Notation "ps .*1" := (fmap (M:=list) fst ps)
+ (at level 2, left associativity, format "ps .*1").
+Notation "ps .*2" := (fmap (M:=list) snd ps)
+ (at level 2, left associativity, format "ps .*2").
+
+(** For any monad that has a builtin way to throw an exception/error *)
+Class MThrow (E : Type) (M : Type → Type) := mthrow : ∀ {A}, E → M A.
+Global Arguments mthrow {_ _ _ _} _ : assert.
+Global Instance: Params (@mthrow) 4 := {}.
+Global Hint Mode MThrow ! ! : typeclass_instances.
+
+(** We use unit as the error content for monads that can only report an error
+ without any payload like an option *)
+Global Notation MFail := (MThrow ()).
+Global Notation mfail := (mthrow ()).
+
+Definition guard_or {E} (e : E) `{MThrow E M, MRet M} P `{Decision P} : M P :=
+ match decide P with
+ | left H => mret H
+ | right _ => mthrow e
+ end.
+Global Notation guard := (guard_or ()).
+
+
+(** * Operations on maps *)
+(** In this section we define operational type classes for the operations
+on maps. In the file [fin_maps] we will axiomatize finite maps.
+The function look up [m !! k] should yield the element at key [k] in [m]. *)
+Class Lookup (K A M : Type) := lookup: K → M → option A.
+Global Hint Mode Lookup - - ! : typeclass_instances.
+Global Instance: Params (@lookup) 5 := {}.
+Notation "m !! i" := (lookup i m) (at level 20) : stdpp_scope.
+Notation "(!!)" := lookup (only parsing) : stdpp_scope.
+Notation "( m !!.)" := (λ i, m !! i) (only parsing) : stdpp_scope.
+Notation "(.!! i )" := (lookup i) (only parsing) : stdpp_scope.
+Global Arguments lookup _ _ _ _ !_ !_ / : simpl nomatch, assert.
+
+(** The function [lookup_total] should be the total over-approximation
+of the partial [lookup] function. *)
+Class LookupTotal (K A M : Type) := lookup_total : K → M → A.
+Global Hint Mode LookupTotal - - ! : typeclass_instances.
+Global Instance: Params (@lookup_total) 5 := {}.
+Notation "m !!! i" := (lookup_total i m) (at level 20) : stdpp_scope.
+Notation "(!!!)" := lookup_total (only parsing) : stdpp_scope.
+Notation "( m !!!.)" := (λ i, m !!! i) (only parsing) : stdpp_scope.
+Notation "(.!!! i )" := (lookup_total i) (only parsing) : stdpp_scope.
+Global Arguments lookup_total _ _ _ _ !_ !_ / : simpl nomatch, assert.
+
+(** The singleton map *)
+Class SingletonM K A M := singletonM: K → A → M.
+Global Hint Mode SingletonM - - ! : typeclass_instances.
+Global Instance: Params (@singletonM) 5 := {}.
+Notation "{[ k := a ]}" := (singletonM k a) (at level 1) : stdpp_scope.
+
+(** The function insert [<[k:=a]>m] should update the element at key [k] with
+value [a] in [m]. *)
+Class Insert (K A M : Type) := insert: K → A → M → M.
+Global Hint Mode Insert - - ! : typeclass_instances.
+Global Instance: Params (@insert) 5 := {}.
+Notation "<[ k := a ]>" := (insert k a)
+ (at level 5, right associativity, format "<[ k := a ]>") : stdpp_scope.
+Global Arguments insert _ _ _ _ !_ _ !_ / : simpl nomatch, assert.
+
+(** Notation for more elements (up to 13) *)
+(* Defining a generic notation does not seem possible with Coq's
+ recursive notation system, so we define individual notations
+ for some cases relevant in practice. *)
+(* The "format" makes sure that linebreaks are placed after the separating semicola [;] when printing. *)
+(* TODO : we are using parantheses in the "de-sugaring" of the notation instead of [$] because Coq 8.12
+ and earlier have trouble with using the notation for printing otherwise.
+ Once support for Coq 8.12 is dropped, this can be replaced with [$]. *)
+Notation "{[ k1 := a1 ; k2 := a2 ]}" :=
+ (<[ k1 := a1 ]>{[ k2 := a2 ]})
+ (at level 1, format
+ "{[ '[hv' '[' k1 := a1 ; ']' '/' '[' k2 := a2 ']' ']' ]}") : stdpp_scope.
+Notation "{[ k1 := a1 ; k2 := a2 ; k3 := a3 ]}" :=
+ (<[ k1 := a1 ]> ( <[ k2 := a2 ]>{[ k3 := a3 ]}))
+ (at level 1, format
+ "{[ '[hv' '[' k1 := a1 ; ']' '/' '[' k2 := a2 ; ']' '/' '[' k3 := a3 ']' ']' ]}") : stdpp_scope.
+Notation "{[ k1 := a1 ; k2 := a2 ; k3 := a3 ; k4 := a4 ]}" :=
+ (<[ k1 := a1 ]> ( <[ k2 := a2 ]> ( <[ k3 := a3 ]>{[ k4 := a4 ]})))
+ (at level 1, format
+ "{[ '[hv' '[' k1 := a1 ; ']' '/' '[' k2 := a2 ; ']' '/' '[' k3 := a3 ; ']' '/' '[' k4 := a4 ']' ']' ]}") : stdpp_scope.
+Notation "{[ k1 := a1 ; k2 := a2 ; k3 := a3 ; k4 := a4 ; k5 := a5 ]}" :=
+ (<[ k1 := a1 ]> ( <[ k2 := a2 ]> ( <[ k3 := a3 ]> ( <[ k4 := a4 ]>{[ k5 := a5 ]}))))
+ (at level 1, format
+ "{[ '[hv' '[' k1 := a1 ; ']' '/' '[' k2 := a2 ; ']' '/' '[' k3 := a3 ; ']' '/' '[' k4 := a4 ; ']' '/' '[' k5 := a5 ']' ']' ]}") : stdpp_scope.
+Notation "{[ k1 := a1 ; k2 := a2 ; k3 := a3 ; k4 := a4 ; k5 := a5 ; k6 := a6 ]}" :=
+ (<[ k1 := a1 ]> ( <[ k2 := a2 ]> ( <[ k3 := a3 ]> ( <[ k4 := a4 ]> (
+ <[ k5 := a5 ]>{[ k6 := a6 ]})))))
+ (at level 1, format
+ "{[ '[hv' '[' k1 := a1 ; ']' '/' '[' k2 := a2 ; ']' '/' '[' k3 := a3 ; ']' '/' '[' k4 := a4 ; ']' '/' '[' k5 := a5 ; ']' '/' '[' k6 := a6 ']' ']' ]}") : stdpp_scope.
+Notation "{[ k1 := a1 ; k2 := a2 ; k3 := a3 ; k4 := a4 ; k5 := a5 ; k6 := a6 ; k7 := a7 ]}" :=
+ (<[ k1 := a1 ]> ( <[ k2 := a2 ]> ( <[ k3 := a3 ]> ( <[ k4 := a4 ]> (
+ <[ k5 := a5 ]> ( <[ k6 := a6 ]>{[ k7 := a7 ]}))))))
+ (at level 1, format
+ "{[ '[hv' '[' k1 := a1 ; ']' '/' '[' k2 := a2 ; ']' '/' '[' k3 := a3 ; ']' '/' '[' k4 := a4 ; ']' '/' '[' k5 := a5 ; ']' '/' '[' k6 := a6 ; ']' '/' '[' k7 := a7 ']' ']' ]}") : stdpp_scope.
+Notation "{[ k1 := a1 ; k2 := a2 ; k3 := a3 ; k4 := a4 ; k5 := a5 ; k6 := a6 ; k7 := a7 ; k8 := a8 ]}" :=
+ (<[ k1 := a1 ]> ( <[ k2 := a2 ]> ( <[ k3 := a3 ]> ( <[ k4 := a4 ]> (
+ <[ k5 := a5 ]> ( <[ k6 := a6 ]> ( <[ k7 := a7 ]>{[ k8 := a8 ]})))))))
+ (at level 1, format
+ "{[ '[hv' '[' k1 := a1 ; ']' '/' '[' k2 := a2 ; ']' '/' '[' k3 := a3 ; ']' '/' '[' k4 := a4 ; ']' '/' '[' k5 := a5 ; ']' '/' '[' k6 := a6 ; ']' '/' '[' k7 := a7 ; ']' '/' '[' k8 := a8 ']' ']' ]}") : stdpp_scope.
+Notation "{[ k1 := a1 ; k2 := a2 ; k3 := a3 ; k4 := a4 ; k5 := a5 ; k6 := a6 ; k7 := a7 ; k8 := a8 ; k9 := a9 ]}" :=
+ (<[ k1 := a1 ]> ( <[ k2 := a2 ]> ( <[ k3 := a3 ]> ( <[ k4 := a4 ]> (
+ <[ k5 := a5 ]> ( <[ k6 := a6 ]> ( <[ k7 := a7 ]> ( <[ k8 := a8 ]>{[ k9 := a9 ]}))))))))
+ (at level 1, format
+ "{[ '[hv' '[' k1 := a1 ; ']' '/' '[' k2 := a2 ; ']' '/' '[' k3 := a3 ; ']' '/' '[' k4 := a4 ; ']' '/' '[' k5 := a5 ; ']' '/' '[' k6 := a6 ; ']' '/' '[' k7 := a7 ; ']' '/' '[' k8 := a8 ; ']' '/' '[' k9 := a9 ']' ']' ]}") : stdpp_scope.
+Notation "{[ k1 := a1 ; k2 := a2 ; k3 := a3 ; k4 := a4 ; k5 := a5 ; k6 := a6 ; k7 := a7 ; k8 := a8 ; k9 := a9 ; k10 := a10 ]}" :=
+ (<[ k1 := a1 ]> ( <[ k2 := a2 ]> ( <[ k3 := a3 ]> ( <[ k4 := a4 ]> (
+ <[ k5 := a5 ]> ( <[ k6 := a6 ]> ( <[ k7 := a7 ]> ( <[ k8 := a8 ]> (
+ <[ k9 := a9 ]>{[ k10 := a10 ]})))))))))
+ (at level 1, format
+ "{[ '[hv' '[' k1 := a1 ; ']' '/' '[' k2 := a2 ; ']' '/' '[' k3 := a3 ; ']' '/' '[' k4 := a4 ; ']' '/' '[' k5 := a5 ; ']' '/' '[' k6 := a6 ; ']' '/' '[' k7 := a7 ; ']' '/' '[' k8 := a8 ; ']' '/' '[' k9 := a9 ; ']' '/' '[' k10 := a10 ']' ']' ]}") : stdpp_scope.
+Notation "{[ k1 := a1 ; k2 := a2 ; k3 := a3 ; k4 := a4 ; k5 := a5 ; k6 := a6 ; k7 := a7 ; k8 := a8 ; k9 := a9 ; k10 := a10 ; k11 := a11 ]}" :=
+ (<[ k1 := a1 ]> ( <[ k2 := a2 ]> ( <[ k3 := a3 ]> ( <[ k4 := a4 ]> (
+ <[ k5 := a5 ]> ( <[ k6 := a6 ]> ( <[ k7 := a7 ]> ( <[ k8 := a8 ]> (
+ <[ k9 := a9 ]> ( <[ k10 := a10 ]>{[ k11 := a11 ]}))))))))))
+ (at level 1, format
+ "{[ '[hv' '[' k1 := a1 ; ']' '/' '[' k2 := a2 ; ']' '/' '[' k3 := a3 ; ']' '/' '[' k4 := a4 ; ']' '/' '[' k5 := a5 ; ']' '/' '[' k6 := a6 ; ']' '/' '[' k7 := a7 ; ']' '/' '[' k8 := a8 ; ']' '/' '[' k9 := a9 ; ']' '/' '[' k10 := a10 ; ']' '/' '[' k11 := a11 ']' ']' ]}") : stdpp_scope.
+Notation "{[ k1 := a1 ; k2 := a2 ; k3 := a3 ; k4 := a4 ; k5 := a5 ; k6 := a6 ; k7 := a7 ; k8 := a8 ; k9 := a9 ; k10 := a10 ; k11 := a11 ; k12 := a12 ]}" :=
+ (<[ k1 := a1 ]> ( <[ k2 := a2 ]> ( <[ k3 := a3 ]> ( <[ k4 := a4 ]> (
+ <[ k5 := a5 ]> ( <[ k6 := a6 ]> ( <[ k7 := a7 ]> ( <[ k8 := a8 ]> (
+ <[ k9 := a9 ]> ( <[ k10 := a10 ]> ( <[ k11 := a11 ]>{[ k12 := a12 ]})))))))))))
+ (at level 1, format
+ "{[ '[hv' '[' k1 := a1 ; ']' '/' '[' k2 := a2 ; ']' '/' '[' k3 := a3 ; ']' '/' '[' k4 := a4 ; ']' '/' '[' k5 := a5 ; ']' '/' '[' k6 := a6 ; ']' '/' '[' k7 := a7 ; ']' '/' '[' k8 := a8 ; ']' '/' '[' k9 := a9 ; ']' '/' '[' k10 := a10 ; ']' '/' '[' k11 := a11 ; ']' '/' '[' k12 := a12 ']' ']' ]}") : stdpp_scope.
+Notation "{[ k1 := a1 ; k2 := a2 ; k3 := a3 ; k4 := a4 ; k5 := a5 ; k6 := a6 ; k7 := a7 ; k8 := a8 ; k9 := a9 ; k10 := a10 ; k11 := a11 ; k12 := a12 ; k13 := a13 ]}" :=
+ (<[ k1 := a1 ]> ( <[ k2 := a2 ]> ( <[ k3 := a3 ]> ( <[ k4 := a4 ]> (
+ <[ k5 := a5 ]> ( <[ k6 := a6 ]> ( <[ k7 := a7 ]> ( <[ k8 := a8 ]> (
+ <[ k9 := a9 ]> ( <[ k10 := a10 ]> ( <[ k11 := a11 ]> ( <[ k12 := a12 ]>{[ k13 := a13 ]}))))))))))))
+ (at level 1, format
+ "{[ '[hv' '[' k1 := a1 ; ']' '/' '[' k2 := a2 ; ']' '/' '[' k3 := a3 ; ']' '/' '[' k4 := a4 ; ']' '/' '[' k5 := a5 ; ']' '/' '[' k6 := a6 ; ']' '/' '[' k7 := a7 ; ']' '/' '[' k8 := a8 ; ']' '/' '[' k9 := a9 ; ']' '/' '[' k10 := a10 ; ']' '/' '[' k11 := a11 ; ']' '/' '[' k12 := a12 ; ']' '/' '[' k13 := a13 ']' ']' ]}") : stdpp_scope.
+
+(** The function delete [delete k m] should delete the value at key [k] in
+[m]. If the key [k] is not a member of [m], the original map should be
+returned. *)
+Class Delete (K M : Type) := delete: K → M → M.
+Global Hint Mode Delete - ! : typeclass_instances.
+Global Instance: Params (@delete) 4 := {}.
+Global Arguments delete _ _ _ !_ !_ / : simpl nomatch, assert.
+
+(** The function [alter f k m] should update the value at key [k] using the
+function [f], which is called with the original value. *)
+Class Alter (K A M : Type) := alter: (A → A) → K → M → M.
+Global Hint Mode Alter - - ! : typeclass_instances.
+Global Instance: Params (@alter) 4 := {}.
+Global Arguments alter {_ _ _ _} _ !_ !_ / : simpl nomatch, assert.
+
+(** The function [partial_alter f k m] should update the value at key [k] using the
+function [f], which is called with the original value at key [k] or [None]
+if [k] is not a member of [m]. The value at [k] should be deleted if [f]
+yields [None]. *)
+Class PartialAlter (K A M : Type) :=
+ partial_alter: (option A → option A) → K → M → M.
+Global Hint Mode PartialAlter - - ! : typeclass_instances.
+Global Instance: Params (@partial_alter) 4 := {}.
+Global Arguments partial_alter _ _ _ _ _ !_ !_ / : simpl nomatch, assert.
+
+(** The function [dom m] should yield the domain of [m]. That is a finite
+set of type [D] that contains the keys that are a member of [m].
+[D] is an output of the typeclass, i.e., there can be only one instance per map
+type [M]. *)
+Class Dom (M D : Type) := dom: M → D.
+Global Hint Mode Dom ! - : typeclass_instances.
+Global Instance: Params (@dom) 3 := {}.
+Global Arguments dom : clear implicits.
+Global Arguments dom {_ _ _} !_ / : simpl nomatch, assert.
+
+(** The function [merge f m1 m2] should merge the maps [m1] and [m2] by
+constructing a new map whose value at key [k] is [f (m1 !! k) (m2 !! k)].*)
+Class Merge (M : Type → Type) :=
+ merge: ∀ {A B C}, (option A → option B → option C) → M A → M B → M C.
+Global Hint Mode Merge ! : typeclass_instances.
+Global Instance: Params (@merge) 4 := {}.
+Global Arguments merge _ _ _ _ _ _ !_ !_ / : simpl nomatch, assert.
+
+(** The function [union_with f m1 m2] is supposed to yield the union of [m1]
+and [m2] using the function [f] to combine values of members that are in
+both [m1] and [m2]. *)
+Class UnionWith (A M : Type) :=
+ union_with: (A → A → option A) → M → M → M.
+Global Hint Mode UnionWith - ! : typeclass_instances.
+Global Instance: Params (@union_with) 3 := {}.
+Global Arguments union_with {_ _ _} _ !_ !_ / : simpl nomatch, assert.
+
+(** Similarly for intersection and difference. *)
+Class IntersectionWith (A M : Type) :=
+ intersection_with: (A → A → option A) → M → M → M.
+Global Hint Mode IntersectionWith - ! : typeclass_instances.
+Global Instance: Params (@intersection_with) 3 := {}.
+Global Arguments intersection_with {_ _ _} _ !_ !_ / : simpl nomatch, assert.
+
+Class DifferenceWith (A M : Type) :=
+ difference_with: (A → A → option A) → M → M → M.
+Global Hint Mode DifferenceWith - ! : typeclass_instances.
+Global Instance: Params (@difference_with) 3 := {}.
+Global Arguments difference_with {_ _ _} _ !_ !_ / : simpl nomatch, assert.
+
+Definition intersection_with_list `{IntersectionWith A M}
+ (f : A → A → option A) : M → list M → M := fold_right (intersection_with f).
+Global Arguments intersection_with_list _ _ _ _ _ !_ / : assert.
+
+(** * Notations for lattices. *)
+(** SqSubsetEq registers the "canonical" partial order for a type, and is used
+for the \sqsubseteq symbol. *)
+Class SqSubsetEq A := sqsubseteq: relation A.
+Global Hint Mode SqSubsetEq ! : typeclass_instances.
+Global Instance: Params (@sqsubseteq) 2 := {}.
+Infix "⊑" := sqsubseteq (at level 70) : stdpp_scope.
+Notation "(⊑)" := sqsubseteq (only parsing) : stdpp_scope.
+Notation "( x ⊑.)" := (sqsubseteq x) (only parsing) : stdpp_scope.
+Notation "(.⊑ y )" := (λ x, sqsubseteq x y) (only parsing) : stdpp_scope.
+
+Infix "⊑@{ A }" := (@sqsubseteq A _) (at level 70, only parsing) : stdpp_scope.
+Notation "(⊑@{ A } )" := (@sqsubseteq A _) (only parsing) : stdpp_scope.
+
+(** [sqsubseteq] does not take precedence over the stdlib's instances (like [eq],
+[impl], [iff]) or std++'s [equiv].
+We have [eq] (at 100) < [≡] (at 150) < [⊑] (at 200). *)
+Global Instance sqsubseteq_rewrite `{SqSubsetEq A} : RewriteRelation (⊑@{A}) | 200 := {}.
+
+Global Hint Extern 0 (_ ⊑ _) => reflexivity : core.
+
+Class Meet A := meet: A → A → A.
+Global Hint Mode Meet ! : typeclass_instances.
+Global Instance: Params (@meet) 2 := {}.
+Infix "⊓" := meet (at level 40) : stdpp_scope.
+Notation "(⊓)" := meet (only parsing) : stdpp_scope.
+Notation "( x ⊓.)" := (meet x) (only parsing) : stdpp_scope.
+Notation "(.⊓ y )" := (λ x, meet x y) (only parsing) : stdpp_scope.
+
+Class Join A := join: A → A → A.
+Global Hint Mode Join ! : typeclass_instances.
+Global Instance: Params (@join) 2 := {}.
+Infix "⊔" := join (at level 50) : stdpp_scope.
+Notation "(⊔)" := join (only parsing) : stdpp_scope.
+Notation "( x ⊔.)" := (join x) (only parsing) : stdpp_scope.
+Notation "(.⊔ y )" := (λ x, join x y) (only parsing) : stdpp_scope.
+
+Class Top A := top : A.
+Global Hint Mode Top ! : typeclass_instances.
+Notation "⊤" := top (format "⊤") : stdpp_scope.
+
+Class Bottom A := bottom : A.
+Global Hint Mode Bottom ! : typeclass_instances.
+Notation "⊥" := bottom (format "⊥") : stdpp_scope.
+
+
+(** * Axiomatization of sets *)
+(** The classes [SemiSet A C], [Set_ A C], and [TopSet A C] axiomatize sets of
+type [C] with elements of type [A]. The first class, [SemiSet] does not include
+intersection and difference. It is useful for the case of lists, where decidable
+equality is needed to implement intersection and difference, but not union.
+
+Note that we cannot use the name [Set] since that is a reserved keyword. Hence
+we use [Set_]. *)
+Class SemiSet A C `{ElemOf A C,
+ Empty C, Singleton A C, Union C} : Prop := {
+ not_elem_of_empty (x : A) : x ∉@{C} ∅; (* We prove
+ [elem_of_empty : x ∈@{C} ∅ ↔ False] in [sets.v], which is more convenient for
+ rewriting. *)
+ elem_of_singleton (x y : A) : x ∈@{C} {[ y ]} ↔ x = y;
+ elem_of_union (X Y : C) (x : A) : x ∈ X ∪ Y ↔ x ∈ X ∨ x ∈ Y
+}.
+Global Hint Mode SemiSet - ! - - - - : typeclass_instances.
+
+Class Set_ A C `{ElemOf A C, Empty C, Singleton A C,
+ Union C, Intersection C, Difference C} : Prop := {
+ set_semi_set :> SemiSet A C;
+ elem_of_intersection (X Y : C) (x : A) : x ∈ X ∩ Y ↔ x ∈ X ∧ x ∈ Y;
+ elem_of_difference (X Y : C) (x : A) : x ∈ X ∖ Y ↔ x ∈ X ∧ x ∉ Y
+}.
+Global Hint Mode Set_ - ! - - - - - - : typeclass_instances.
+
+Class TopSet A C `{ElemOf A C, Empty C, Top C, Singleton A C,
+ Union C, Intersection C, Difference C} : Prop := {
+ top_set_set :> Set_ A C;
+ elem_of_top' (x : A) : x ∈@{C} ⊤; (* We prove [elem_of_top : x ∈@{C} ⊤ ↔ True]
+ in [sets.v], which is more convenient for rewriting. *)
+}.
+Global Hint Mode TopSet - ! - - - - - - - : typeclass_instances.
+
+(** We axiomative a finite set as a set whose elements can be
+enumerated as a list. These elements, given by the [elements] function, may be
+in any order and should not contain duplicates. *)
+Class Elements A C := elements: C → list A.
+Global Hint Mode Elements - ! : typeclass_instances.
+Global Instance: Params (@elements) 3 := {}.
+
+(** We redefine the standard library's [In] and [NoDup] using type classes. *)
+Inductive elem_of_list {A} : ElemOf A (list A) :=
+ | elem_of_list_here (x : A) l : x ∈ x :: l
+ | elem_of_list_further (x y : A) l : x ∈ l → x ∈ y :: l.
+Global Existing Instance elem_of_list.
+
+Lemma elem_of_list_In {A} (l : list A) x : x ∈ l ↔ In x l.
+Proof.
+ split.
+ - induction 1; simpl; auto.
+ - induction l; destruct 1; subst; constructor; auto.
+Qed.
+
+Inductive NoDup {A} : list A → Prop :=
+ | NoDup_nil_2 : NoDup []
+ | NoDup_cons_2 x l : x ∉ l → NoDup l → NoDup (x :: l).
+
+Lemma NoDup_ListNoDup {A} (l : list A) : NoDup l ↔ List.NoDup l.
+Proof.
+ split.
+ - induction 1; constructor; rewrite <-?elem_of_list_In; auto.
+ - induction 1; constructor; rewrite ?elem_of_list_In; auto.
+Qed.
+
+(** Decidability of equality of the carrier set is admissible, but we add it
+anyway so as to avoid cycles in type class search. *)
+Class FinSet A C `{ElemOf A C, Empty C, Singleton A C, Union C,
+ Intersection C, Difference C, Elements A C, EqDecision A} : Prop := {
+ fin_set_set :> Set_ A C;
+ elem_of_elements (X : C) x : x ∈ elements X ↔ x ∈ X;
+ NoDup_elements (X : C) : NoDup (elements X)
+}.
+Global Hint Mode FinSet - ! - - - - - - - - : typeclass_instances.
+
+Class Size C := size: C → nat.
+Global Hint Mode Size ! : typeclass_instances.
+Global Arguments size {_ _} !_ / : simpl nomatch, assert.
+Global Instance: Params (@size) 2 := {}.
+
+(** The class [MonadSet M] axiomatizes a type constructor [M] that can be
+used to construct a set [M A] with elements of type [A]. The advantage
+of this class, compared to [Set_], is that it also axiomatizes the
+the monadic operations. The disadvantage is that not many inhabitants are
+possible: we will only provide as inhabitants [propset] and [listset], which are
+represented respectively using Boolean functions and lists with duplicates.
+
+More interesting implementations typically need
+decidable equality, or a total order on the elements, which do not fit
+in a type constructor of type [Type → Type]. *)
+Class MonadSet M `{∀ A, ElemOf A (M A),
+ ∀ A, Empty (M A), ∀ A, Singleton A (M A), ∀ A, Union (M A),
+ !MBind M, !MRet M, !FMap M, !MJoin M} : Prop := {
+ monad_set_semi_set A :> SemiSet A (M A);
+ elem_of_bind {A B} (f : A → M B) (X : M A) (x : B) :
+ x ∈ X ≫= f ↔ ∃ y, x ∈ f y ∧ y ∈ X;
+ elem_of_ret {A} (x y : A) : x ∈@{M A} mret y ↔ x = y;
+ elem_of_fmap {A B} (f : A → B) (X : M A) (x : B) :
+ x ∈ f <$> X ↔ ∃ y, x = f y ∧ y ∈ X;
+ elem_of_join {A} (X : M (M A)) (x : A) :
+ x ∈ mjoin X ↔ ∃ Y : M A, x ∈ Y ∧ Y ∈ X
+}.
+
+(** The [Infinite A] class axiomatizes types [A] with infinitely many elements.
+It contains a function [fresh : list A → A] that given a list [xs] gives an
+element [fresh xs ∉ xs].
+
+We do not directly make [fresh] a field of the [Infinite] class, but use a
+separate operational type class [Fresh] for it. That way we can overload [fresh]
+to pick fresh elements from other data structure like sets. See the file
+[fin_sets], where we define [fresh : C → A] for any finite set implementation
+[FinSet C A].
+
+Note: we require [fresh] to respect permutations, which is needed to define the
+aforementioned [fresh] function on finite sets that respects set equality.
+
+Instead of instantiating [Infinite] directly, consider using [max_infinite] or
+[inj_infinite] from the [infinite] module. *)
+Class Fresh A C := fresh: C → A.
+Global Hint Mode Fresh - ! : typeclass_instances.
+Global Instance: Params (@fresh) 3 := {}.
+Global Arguments fresh : simpl never.
+
+Class Infinite A := {
+ infinite_fresh :> Fresh A (list A);
+ infinite_is_fresh (xs : list A) : fresh xs ∉ xs;
+ infinite_fresh_Permutation :> Proper (@Permutation A ==> (=)) fresh;
+}.
+Global Hint Mode Infinite ! : typeclass_instances.
+Global Arguments infinite_fresh : simpl never.
+
+(** * Miscellaneous *)
+Class Half A := half: A → A.
+Global Hint Mode Half ! : typeclass_instances.
+Notation "½" := half (format "½") : stdpp_scope.
+Notation "½*" := (fmap (M:=list) half) : stdpp_scope.
diff --git a/apps/tc/tests/compile_add_pred.v b/apps/tc/tests/compile_add_pred.v
new file mode 100644
index 000000000..6c56855dd
--- /dev/null
+++ b/apps/tc/tests/compile_add_pred.v
@@ -0,0 +1,127 @@
+From elpi Require Import elpi.
+
+Elpi Db tc.db lp:{{
+ pred classes i:gref.
+
+ pred bool->mode-term i:bool, o:string.
+ bool->mode-term tt "i:term".
+ bool->mode-term ff "o:term".
+
+ pred modes->string i:list bool, o:string.
+ modes->string L S :-
+ std.map L bool->mode-term L',
+ std.string.concat "," L' S.
+
+ pred list-init i:int, i:(int -> A -> prop), o:list A.
+ list-init N _ _ :- N < 0, std.fatal-error "list-init negative length".
+ list-init 0 _ [] :- !.
+ list-init N F [A | TL] :-
+ F N A, N1 is N - 1, list-init N1 F TL.
+
+ pred fail->bool i:prop, o:bool.
+ fail->bool P ff :- P, !.
+ fail->bool _ tt.
+
+ pred make-tc-modes i:int, o:string.
+ make-tc-modes NB_args ModesStr :-
+ list-init NB_args (x\r\ fail->bool (x = 1) r) ModesBool,
+ modes->string ModesBool ModesStr.
+
+ pred gref->pred-name i:gref, o:string.
+ gref->pred-name Gr S :-
+ coq.gref->id Gr S',
+ S is "tc-" ^ S'.
+
+ pred add-tc-pred i:gref, i:int.
+ add-tc-pred Gr NbArgs :-
+ not (classes Gr),
+ make-tc-modes NbArgs Modes,
+ gref->pred-name Gr GrStr,
+ D is "pred " ^ GrStr ^ " " ^ Modes ^ ".",
+ coq.elpi.add-predicate "tc.db" D,
+ coq.elpi.accumulate _ "tc.db" (clause _ _ (classes Gr)).
+ add-tc-pred _ _.
+
+ pred make-tc i:term, i:term, i:list prop, o:prop.
+ make-tc Ty Inst Hyp Clause :-
+ app [global TC | TL] = Ty,
+ gref->pred-name TC TC_Str,
+ std.append TL [Inst] Args,
+ std.length Args ArgsLen,
+ add-tc-pred TC ArgsLen,
+ coq.elpi.predicate TC_Str Args Q,
+ Clause = (Q :- Hyp).
+
+ pred app-has-class i:term, o:gref.
+ app-has-class (prod _ _ T) C :- pi x\ app-has-class (T x) C.
+ app-has-class (app [global T|_]) T :- coq.TC.class? T.
+
+ pred compile i:term, i:term, i:list prop, i:list term, o:prop.
+ compile (prod _ T F) I ListRHS ListVar (pi x\ C x) :- !,
+ pi p cond\ sigma Clause L\
+ if (app-has-class T _) (compile T p [] [] Clause, L = [Clause | ListRHS]) (L = ListRHS),
+ compile (F p) I L [p | ListVar] (C p).
+ compile Ty I Premises ListVar Clause :- !,
+ std.rev Premises PremisesRev,
+ coq.mk-app I {std.rev ListVar} AppInst,
+ make-tc Ty AppInst PremisesRev Clause.
+}}.
+
+Elpi Command addClass.
+Elpi Accumulate Db tc.db.
+Elpi Accumulate lp:{{
+ main [str TC_Name] :-
+ coq.locate TC_Name TC_Gr,
+ coq.env.typeof TC_Gr TC_Ty,
+ coq.count-prods TC_Ty N',
+ N is N' + 1, % Plus one for the solution
+ add-tc-pred TC_Gr N.
+}}.
+Elpi Typecheck.
+
+Elpi Command compile.
+Elpi Accumulate Db tc.db.
+Elpi Accumulate lp:{{
+ main [str InstName] :-
+ coq.locate InstName InstGr,
+ coq.env.typeof InstGr InstTy,
+ compile InstTy (global InstGr) [] [] Cl,
+ coq.say Cl,
+ coq.elpi.accumulate _ "tc.db" (clause _ _ Cl).
+}}.
+Elpi Typecheck.
+
+Elpi Tactic solver.
+Elpi Accumulate Db tc.db.
+Elpi Accumulate lp:{{
+ msolve L N :- !,
+ coq.ltac.all (coq.ltac.open solve) {std.rev L} N.
+
+ solve (goal _ _ Ty Sol _ as G) GL :-
+ var Sol,
+ Ty = app [global TC | TL'],
+ std.append TL' [X] TL,
+ if (coq.elpi.predicate {gref->pred-name TC} TL Q, Q)
+ (
+ refine X G GL;
+ coq.say "illtyped solution:" {coq.term->string X}
+ )
+ (GL = [seal G]).
+}}.
+Elpi Typecheck.
+
+Class EqSimpl (T : Type) := {eqb : T -> T -> bool}.
+
+Global Instance EqU : EqSimpl unit := { eqb A B := true }.
+Global Instance EqP {A B: Type} `(EqSimpl A, EqSimpl B) : EqSimpl (A * B) := { eqb A B := true }.
+
+Elpi addClass EqSimpl.
+Elpi compile EqU.
+Elpi compile EqP.
+
+Elpi Override TC solver All.
+
+Check (_ : EqSimpl unit).
+Check (_ : EqSimpl (unit * unit)).
+
+
diff --git a/apps/tc/tests/contextDeepHierarchy.v b/apps/tc/tests/contextDeepHierarchy.v
new file mode 100644
index 000000000..b215775d3
--- /dev/null
+++ b/apps/tc/tests/contextDeepHierarchy.v
@@ -0,0 +1,19 @@
+From elpi.apps Require Import tc.
+Unset Typeclass Resolution For Conversion.
+Set TC NameShortPath.
+Elpi Override TC TC.Solver All.
+
+
+Class X (A: Type).
+Class Y (A: Type).
+Class Z (A: Type).
+
+Local Instance Inst1@{i} {A: Type@{i}} : X A -> Y A. Qed.
+Local Instance Inst2@{i} (A : Type@{i}): (forall A : Type@{i}, X A -> Y A) -> Z A. Qed.
+
+(* TODO: here Elpi Trace Fails... *)
+
+Goal forall A, Z A.
+ intros.
+ apply _.
+Qed.
\ No newline at end of file
diff --git a/apps/tc/tests/eqSimplDef.v b/apps/tc/tests/eqSimplDef.v
new file mode 100644
index 000000000..916cde199
--- /dev/null
+++ b/apps/tc/tests/eqSimplDef.v
@@ -0,0 +1,11 @@
+Require Import Bool Arith List.
+
+Class Eqb A : Type := eqb : A -> A -> bool.
+Global Hint Mode Eqb + : typeclass_instances.
+
+Notation " x == y " := (eqb x y) (no associativity, at level 70).
+
+Global Instance eqU : Eqb unit := { eqb x y := true }.
+Global Instance eqB : Eqb bool := { eqb x y := if x then y else negb y }.
+Global Instance eqP {A B} `{Eqb A} `{Eqb B} : Eqb (A * B) := {
+ eqb x y := (fst x == fst y) && (snd x == snd y) }.
\ No newline at end of file
diff --git a/apps/tc/tests/hook_test.v b/apps/tc/tests/hook_test.v
new file mode 100644
index 000000000..9d847f6e2
--- /dev/null
+++ b/apps/tc/tests/hook_test.v
@@ -0,0 +1,18 @@
+From elpi.apps Require Import tc.
+Elpi Override TC TC.Solver All.
+
+Elpi TC.AddHook after 1000 1513.
+Elpi TC.AddHook before 1513 1512.
+
+Class A (n : nat).
+Instance Inst1 : A 3 | 1513. Qed.
+Instance Inst2 : A 100 | 1512. Qed.
+
+Elpi Query TC.Solver lp:{{
+ sigma InstL GrefL\
+ std.findall (instance _ _ {{:gref A}}) InstL,
+ std.map InstL (x\r\ x = instance _ r _) GrefL,
+ GrefL = [{{:gref Inst2}}, {{:gref Inst1}}].
+}}.
+
+
diff --git a/apps/tc/tests/importOrder/f1.v b/apps/tc/tests/importOrder/f1.v
new file mode 100644
index 000000000..70c4c1c1c
--- /dev/null
+++ b/apps/tc/tests/importOrder/f1.v
@@ -0,0 +1,5 @@
+From elpi.apps.tc.tests.importOrder Require Export sameOrderCommand.
+
+Class A (T : Set) := f : T -> T.
+
+Elpi SameOrderImport.
\ No newline at end of file
diff --git a/apps/tc/tests/importOrder/f2a.v b/apps/tc/tests/importOrder/f2a.v
new file mode 100644
index 000000000..9c3839098
--- /dev/null
+++ b/apps/tc/tests/importOrder/f2a.v
@@ -0,0 +1,10 @@
+From elpi.apps.tc.tests.importOrder Require Export f1.
+From elpi.apps.tc.tests.importOrder Require Export sameOrderCommand.
+
+
+Global Instance f2aa : A nat := {f x := x}.
+Global Instance f2ab : A nat := {f x := x}.
+Global Instance f2ac : A nat := {f x := x}.
+Global Instance f2ad : A nat := {f x := x}.
+
+Elpi SameOrderImport.
\ No newline at end of file
diff --git a/apps/tc/tests/importOrder/f2b.v b/apps/tc/tests/importOrder/f2b.v
new file mode 100644
index 000000000..b7ec3d03e
--- /dev/null
+++ b/apps/tc/tests/importOrder/f2b.v
@@ -0,0 +1,9 @@
+From elpi.apps.tc.tests.importOrder Require Export f1.
+
+Global Instance f2ba : A nat := {f x := x}.
+Global Instance f2bb : A nat := {f x := x}.
+Global Instance f2bc : A nat := {f x := x}.
+Global Instance f2bd : A nat := {f x := x}.
+
+
+(* Elpi SameOrderImport. *)
diff --git a/apps/tc/tests/importOrder/f3a.v b/apps/tc/tests/importOrder/f3a.v
new file mode 100644
index 000000000..58d5444fd
--- /dev/null
+++ b/apps/tc/tests/importOrder/f3a.v
@@ -0,0 +1,4 @@
+From elpi.apps.tc.tests.importOrder Require Import f2a.
+From elpi.apps.tc.tests.importOrder Require Import f2b.
+
+Elpi SameOrderImport.
diff --git a/apps/tc/tests/importOrder/f3b.v b/apps/tc/tests/importOrder/f3b.v
new file mode 100644
index 000000000..41f84e7aa
--- /dev/null
+++ b/apps/tc/tests/importOrder/f3b.v
@@ -0,0 +1,4 @@
+From elpi.apps.tc.tests.importOrder Require Import f2b.
+From elpi.apps.tc.tests.importOrder Require Import f2a.
+
+Elpi SameOrderImport.
\ No newline at end of file
diff --git a/apps/tc/tests/importOrder/f3c.v b/apps/tc/tests/importOrder/f3c.v
new file mode 100644
index 000000000..2c94dfcb2
--- /dev/null
+++ b/apps/tc/tests/importOrder/f3c.v
@@ -0,0 +1,41 @@
+From elpi.apps.tc.tests.importOrder Require Export f1.
+
+Global Instance f3a : A nat := {f x := x}.
+Global Instance f3b : A nat := {f x := x}.
+Global Instance f3c : A nat := {f x := x}.
+
+Elpi SameOrderImport.
+
+Section S1. Variable X : Type.
+ Local Instance f3d : A nat := {f x := x}.
+ Global Instance f3e : A nat := {f x := x}.
+ Global Instance f3f : A nat := {f x := x}.
+
+ Elpi SameOrderImport.
+End S1.
+
+
+Elpi SameOrderImport.
+
+Section S2.
+ Context (T : Set).
+ Global Instance f3g : A T := {f x := x}.
+
+ Elpi SameOrderImport.
+End S2.
+
+Elpi SameOrderImport.
+
+Section S3.
+ Context (T : Set).
+ Global Instance f3g2 : A (T: Set) := {f x := x}.
+
+ Global Instance f3h T1 T2 `(A T1, A T2) : A (T1 * T2) := {f x := x}.
+
+ Global Instance f3g3 : A (T: Set) := {f x := x}.
+ Global Instance f3g4 : A (T: Set) | 10 := {f x := x}.
+
+ Elpi SameOrderImport.
+End S3.
+
+Elpi SameOrderImport.
\ No newline at end of file
diff --git a/apps/tc/tests/importOrder/f3d.v b/apps/tc/tests/importOrder/f3d.v
new file mode 100644
index 000000000..84c4b3b45
--- /dev/null
+++ b/apps/tc/tests/importOrder/f3d.v
@@ -0,0 +1,32 @@
+From elpi.apps.tc.tests.importOrder Require Export f1.
+From elpi.apps.tc.tests.importOrder Require Import f2b.
+Elpi SameOrderImport.
+
+Global Instance f3a' T1 T2 `(A T1, A T2) : A (T1 * T2) := {f x := x}.
+
+
+Elpi SameOrderImport.
+Module M4'.
+ (* From elpi.apps.tc.tests.importOrder Require Import f2a. *)
+ Elpi SameOrderImport.
+
+ Global Instance f3a : A nat := {f x := x}.
+
+
+ Section S1. Variable X : Type.
+ Global Instance f3b : A nat := {f x := x}.
+
+ Section S1'. Variable Y : Type.
+ Global Instance f3c : A nat := {f x := x}.
+
+ End S1'.
+ End S1.
+
+ Elpi SameOrderImport.
+
+ Section S2. Variable X : Type.
+ Global Instance f3h T1 T2 `(A T1, A T2) : A (T1 * T2) := {f x := x}.
+ End S2.
+End M4'.
+
+Elpi SameOrderImport.
diff --git a/apps/tc/tests/importOrder/f3e.v b/apps/tc/tests/importOrder/f3e.v
new file mode 100644
index 000000000..0de8467ce
--- /dev/null
+++ b/apps/tc/tests/importOrder/f3e.v
@@ -0,0 +1,24 @@
+From elpi.apps.tc.tests.importOrder Require Export f1.
+From elpi.apps.tc.tests.importOrder Require Import f2b.
+From elpi.apps.tc.tests.importOrder Require Import f2a.
+
+Global Instance f3a' T1 T2 `(A T1, A T2) : A (T1 * T2) := {f x := x}.
+
+Elpi SameOrderImport.
+Module M4'.
+ Global Instance f3a : A nat := {f x := x}.
+
+ Section S1. Variable X : Type.
+ Global Instance f3b : A nat := {f x := x}.
+ Section S1'. Variable Y : Type.
+ Global Instance f3c : A nat := {f x := x}.
+ End S1'.
+ End S1.
+
+ Section S2. Variable X : Type.
+ Global Instance f3h T1 T2 `(A T1, A T2) : A (T1 * T2) | 100 := {f x := x}.
+ End S2.
+End M4'.
+
+
+Elpi SameOrderImport.
\ No newline at end of file
diff --git a/apps/tc/tests/importOrder/f3f.v b/apps/tc/tests/importOrder/f3f.v
new file mode 100644
index 000000000..2b0db45ee
--- /dev/null
+++ b/apps/tc/tests/importOrder/f3f.v
@@ -0,0 +1,17 @@
+From elpi.apps.tc.tests.importOrder Require Import f1.
+
+Section S1.
+ Context (T : Set).
+ Global Instance f3a : A T := {f x := x}.
+
+ Elpi SameOrderImport.
+
+ Section S2.
+ Context (T1 : Set).
+ Global Instance f3b : A T1 := {f x := x}.
+
+ End S2.
+
+ Elpi SameOrderImport.
+End S1.
+Elpi SameOrderImport.
\ No newline at end of file
diff --git a/apps/tc/tests/importOrder/f3g.v b/apps/tc/tests/importOrder/f3g.v
new file mode 100644
index 000000000..608efd7f1
--- /dev/null
+++ b/apps/tc/tests/importOrder/f3g.v
@@ -0,0 +1,9 @@
+From elpi.apps.tc.tests.importOrder Require Export f1.
+
+Module M8.
+ Class Classe (A: Type) (B: Type).
+
+ Global Instance I (a b c d: Type): Classe a a -> Classe b c. Admitted.
+
+ Elpi SameOrderImport.
+End M8.
diff --git a/apps/tc/tests/importOrder/f4.v b/apps/tc/tests/importOrder/f4.v
new file mode 100644
index 000000000..0d73340cd
--- /dev/null
+++ b/apps/tc/tests/importOrder/f4.v
@@ -0,0 +1,8 @@
+From elpi.apps.tc.tests.importOrder Require Import f3f.
+From elpi.apps.tc.tests.importOrder Require Import f2a.
+From elpi.apps.tc.tests.importOrder Require Import f2b.
+From elpi.apps.tc.tests.importOrder Require Import f3c.
+From elpi.apps.tc.tests.importOrder Require Import f3d.
+From elpi.apps.tc.tests.importOrder Require Import f3g.
+
+Elpi SameOrderImport.
\ No newline at end of file
diff --git a/apps/tc/tests/importOrder/sameOrderCommand.v b/apps/tc/tests/importOrder/sameOrderCommand.v
new file mode 100644
index 000000000..04aa228d1
--- /dev/null
+++ b/apps/tc/tests/importOrder/sameOrderCommand.v
@@ -0,0 +1,12 @@
+From elpi.apps Require Export tc.
+
+From elpi.apps.tc Extra Dependency "base.elpi" as base.
+From elpi.apps.tc.tests.importOrder Extra Dependency "tc_same_order.elpi" as tc_same_order.
+
+Elpi Command SameOrderImport.
+Elpi Accumulate Db tc.db.
+Elpi Accumulate File base.
+Elpi Accumulate File tc_same_order.
+Elpi Typecheck.
+
+Elpi Override TC TC.Solver All.
\ No newline at end of file
diff --git a/apps/tc/tests/importOrder/tc_same_order.elpi b/apps/tc/tests/importOrder/tc_same_order.elpi
new file mode 100644
index 000000000..4d4607123
--- /dev/null
+++ b/apps/tc/tests/importOrder/tc_same_order.elpi
@@ -0,0 +1,24 @@
+% [Typeclass, Coq Instances, Elpi Instances]
+% the instances of the given typeclass should be in the same order as Coq
+pred correct_instance_order_aux i:gref, i:(list tc-instance), i:(list gref).
+:name "tc-correct-instance-order-aux"
+correct_instance_order_aux _ [] [].
+correct_instance_order_aux TC [tc-instance I1 _ | TL1] [I1 | TL2] :-
+ correct_instance_order_aux TC TL1 TL2.
+
+% [Typeclasses of Coq, Elpi Instances]
+pred correct_instance_order i:(list gref), i:(list prop).
+:name "tc-correct-instance-order"
+correct_instance_order [] _.
+correct_instance_order [TC | TL] ElpiInst :-
+ coq.TC.db-for TC CoqInst,
+ std.map-filter ElpiInst (x\r\ sigma I\ x = instance _ I TC, r = I) ElpiInstTC,
+ if (correct_instance_order_aux TC CoqInst ElpiInstTC)
+ (correct_instance_order TL ElpiInst)
+ (coq.error "Error in import order\n"
+ "Expected :" CoqInst "\nFound :" ElpiInstTC).
+
+:name "tc-same-order-main"
+main _ :-
+ std.findall (instance _ _ _) ElpiInst,
+ correct_instance_order {coq.TC.db-tc} ElpiInst.
\ No newline at end of file
diff --git a/apps/tc/tests/indt_to_inst.v b/apps/tc/tests/indt_to_inst.v
new file mode 100644
index 000000000..a7fbd9eb4
--- /dev/null
+++ b/apps/tc/tests/indt_to_inst.v
@@ -0,0 +1,32 @@
+From Coq Require Export List.
+From elpi.apps Require Export tc.
+Global Generalizable All Variables.
+
+Elpi Override TC TC.Solver All.
+
+Class ElemOf A B := elem_of: A -> B -> Prop.
+Class Elements A C := elements: C -> list A.
+
+Inductive elem_of_list {A} : ElemOf A (list A) :=
+ | elem_of_list_here (x : A) l : elem_of x (x :: l)
+ | elem_of_list_further (x y : A) l : elem_of x l -> elem_of x (y :: l).
+Global Existing Instance elem_of_list.
+
+Inductive NoDup {A} : list A -> Prop :=
+ | NoDup_nil_2 : NoDup nil
+ | NoDup_cons_2 x l : not (elem_of x l) -> NoDup l -> NoDup (x :: l).
+
+Module A.
+ Class FinSet1 A C `{ElemOf A C,Elements A C} : Prop := {
+ NoDup_elements (X : C) : NoDup (elements X)
+ }.
+End A.
+
+Module B.
+
+ Class FinSet2 A C `{ElemOf A C, Elements A C} : Prop := {
+ elem_of_elements2 (X : C) x : iff (elem_of x (elements X)) (elem_of x X);
+ NoDup_elements2 (X : C) : NoDup (elements X)
+ }.
+
+End B.
\ No newline at end of file
diff --git a/apps/tc/tests/injTest.v b/apps/tc/tests/injTest.v
new file mode 100644
index 000000000..2cc47114d
--- /dev/null
+++ b/apps/tc/tests/injTest.v
@@ -0,0 +1,119 @@
+From elpi.apps Require Import tc.
+From Coq Require Import Morphisms RelationClasses List Bool Setoid Peano Utf8.
+
+Generalizable All Variables.
+Elpi Override TC TC.Solver All.
+
+Class Inj {A B} (R : relation A) (S : relation B) (f : A -> B) :=
+ inj x y : S (f x) (f y) -> R x y.
+
+Class Inj2 {A B C} (R1 : relation A) (R2 : relation B)
+ (S : relation C) (f : A → B → C) : Prop :=
+ inj2 x1 x2 y1 y2 : S (f x1 x2) (f y1 y2) → R1 x1 y1 ∧ R2 x2 y2.
+
+(* Elpi Override TC TC.Solver Only Inj Inj2. *)
+
+Definition gInj x := x + 1.
+Definition fInj x := x * 3.
+
+Axiom eq1 : relation nat.
+Axiom eq2 : relation nat.
+Axiom eq3 : relation nat.
+
+Local Instance isInjg : Inj eq3 eq1 gInj. Admitted.
+
+Local Instance isInjf : Inj eq1 eq3 fInj. Admitted.
+
+Local Instance isInjf_old : Inj eq1 eq2 fInj. Admitted.
+Local Instance isInjg_old : Inj eq2 eq3 gInj. Admitted.
+
+Local Instance isInjf_eq : Inj eq eq fInj. Admitted.
+Local Instance isInjg_eq : Inj eq eq gInj. Admitted.
+
+Local Instance id_inj {A} : Inj eq eq (@id A). Admitted.
+Local Instance inl_inj {A B} : Inj eq eq (@inl A B). Admitted.
+Local Instance inr_inj {A B} : Inj eq eq (@inr A B). Admitted.
+
+Definition compose {T1 T2 T3: Type} (g: T2 -> T3) (f : T1 -> T2) (x: T1) := g(f x).
+Local Instance compose_inj {A B C} R1 R2 R3 (f : A -> B) (g : B -> C) :
+ Inj R1 R2 f -> Inj R2 R3 g -> Inj R1 R3 (compose g f).
+Admitted.
+
+Goal exists A B, Inj A B (compose gInj fInj). Admitted.
+
+Goal forall (T1 T2 : Type) (f: T1 -> T2),
+ let r := Inj eq eq f in
+ let x := true in
+ (if x then r else r) -> Inj eq eq f.
+ intros ? ? f r x H.
+ unfold x, r in H.
+ apply _.
+Qed.
+
+Goal forall (T1 T2 : Type) (f: T1 -> T2),
+ let r := Inj eq eq f in
+ let b := true in
+ let cond := (match b with
+ | true => r
+ | false => f = f end) in
+ cond -> Inj eq eq f.
+ intros.
+ unfold cond in H.
+ simpl in H.
+ unfold r in H.
+ apply _.
+Qed.
+
+Elpi Override TC TC.Solver All.
+(* Elpi Print TC.Solver. *)
+Local Instance inj2_inj_1 `{Inj2 A B C R1 R2 R3 ff} y : Inj R1 R3 (λ x, ff x y).
+Admitted.
+
+Global Instance inj2_inj_2 `{Inj2 A B C R1 R2 R3 ff} x : Inj R2 R3 (ff x).
+Admitted.
+
+Goal Inj2 eq eq eq Nat.mul -> Inj eq eq (Nat.mul 0).
+ intros.
+ apply _.
+Qed.
+
+Goal Inj2 eq eq eq Nat.add -> Inj eq eq (fun x => Nat.add x 0).
+intros.
+apply _.
+Qed.
+
+Definition p (T : Type) := @pair T T.
+
+Goal Inj eq eq (compose fInj gInj).
+Proof.
+apply _.
+Qed.
+
+Elpi Print TC.Solver.
+Set Warnings "+elpi".
+
+
+Elpi Accumulate tc.db lp:{{
+ shorten tc-elpi.apps.tc.tests.injTest.{tc-Inj}.
+ % shorten tc-injTest.{tc-Inj}.
+ tc-Inj T1 T2 R1 R3 F S :-
+ F = (fun _ _ _),
+ G = {{ compose _ _ }},
+ coq.unify-eq G F ok,
+ tc-Inj T1 T2 R1 R3 G S.
+}}.
+
+Elpi Typecheck TC.Solver.
+
+Goal Inj eq eq (compose fInj gInj). apply _. Qed.
+Goal Inj eq eq (fun x => fInj (gInj x)). apply _. Qed.
+
+Goal forall (A: Type) (x: A -> A),
+ let y := Inj eq eq x in
+ let z := y in z ->
+ Inj eq eq (compose x x).
+Proof.
+ intros T x y z H.
+ unfold z, y in H.
+ apply _.
+Qed.
\ No newline at end of file
diff --git a/apps/tc/tests/nobacktrack.v b/apps/tc/tests/nobacktrack.v
new file mode 100644
index 000000000..207caafe8
--- /dev/null
+++ b/apps/tc/tests/nobacktrack.v
@@ -0,0 +1,42 @@
+From elpi.apps Require Import tc.
+
+Elpi Debug "simple-compiler".
+Set TC NameShortPath.
+
+Module A.
+
+ Class C (n : nat) := {}.
+ Elpi TC.Set_deterministic C.
+ Elpi TC.Get_class_info C.
+ Local Instance c_1 : C 1 | 10 := {}.
+ Local Instance c_2 : C 2 | 1 := {}.
+
+ Class D (n : nat) := {}.
+ Local Instance d_1 : D 1 := {}.
+
+ Class E (n : nat) := {}.
+ Local Instance foo {n} : C n -> D n -> E n := {}.
+
+ Elpi Override TC TC.Solver All.
+
+ Goal exists n, E n.
+ eexists.
+ Fail apply _.
+ Abort.
+
+End A.
+
+Module B.
+
+ Class A (T : Set) := f : T -> T.
+ Elpi TC.Set_deterministic A.
+
+ Global Instance A1 : A bool := {f x := x}.
+ Global Instance A2 `(A bool) : A (bool * bool) :=
+ {f x := x}.
+ Global Instance A3 `(A nat) : A (bool * bool) :=
+ {f x := x}.
+
+ Goal A (bool * bool). apply _. Qed.
+
+End B.
\ No newline at end of file
diff --git a/apps/tc/tests/patternFragment.v b/apps/tc/tests/patternFragment.v
new file mode 100644
index 000000000..9336f46f8
--- /dev/null
+++ b/apps/tc/tests/patternFragment.v
@@ -0,0 +1,76 @@
+From elpi.apps Require Import tc.
+Elpi Override TC TC.Solver All.
+Set TC NameShortPath.
+Set TC CompilerWithPatternFragment.
+
+Class Y (A: Type).
+Class Z (A: Type).
+Class Ex (P : Type -> Type) (A: Type).
+
+Module M4.
+Local Instance Inst2 A F: (forall (a : Type) (b c : nat), Y (F a b) -> Y (F a c)) -> Z A. Qed.
+Goal Z bool.
+
+Elpi Override TC TC.Solver None.
+ Fail apply _.
+Elpi Override TC TC.Solver All.
+ apply _.
+ Show Proof.
+ Unshelve. assumption. (* we keep a, the first arg of F *)
+ Show Proof. Qed.
+
+Local Instance Inst1: Y (bool * bool). Qed.
+
+Goal Z bool.
+
+Elpi Override TC TC.Solver None.
+ Succeed apply _.
+Elpi Override TC TC.Solver All.
+ apply _.
+
+ Show Proof.
+ Unshelve. apply bool.
+ Show Proof. Qed.
+
+End M4.
+
+Module M5.
+Local Instance Inst1: Y (bool * bool). Qed.
+Local Instance Inst2 A F (R: Type -> Type -> Type): forall x,
+ (forall (a : Type), Y (F a)) -> Ex (R x) A. Qed.
+Goal forall (A:Type) x (R: Type -> Type -> Type ->Type), Ex (R x x) A. apply _. Qed.
+End M5.
+
+Module M1.
+Local Instance Inst1: Y (bool * bool). Qed.
+Local Instance Inst2 A F: (forall (a : Type), Y (F a)) -> Z A. Qed.
+
+Goal forall (A:Type), Z A. apply _. Qed.
+End M1.
+
+Module M2.
+Local Instance Inst1: Y (bool * bool). Qed.
+Local Instance Inst2 A F: (forall (a: Type), Y (F a)) -> Z A. Qed.
+Goal Z bool. apply _. Qed.
+End M2.
+
+Module M3.
+Local Instance Inst1: Y (bool * bool). Qed.
+Local Instance Inst2 A F: (forall (a b c d: Type), Y (F b c d)) -> Z A. Qed.
+Goal Z bool. apply _. Qed.
+End M3.
+
+Module M6.
+Local Instance Inst1: Y (bool * bool). Qed.
+Local Instance Inst2 A F: (forall (a b c d e f g: Type), Y (F a b c d) -> Y (F e f g a)) -> Z A. Qed.
+Goal Z bool. apply _. Unshelve. apply nat. Qed.
+End M6.
+
+Module M1b.
+Local Instance Inst2 A F: (forall (a : Type), Y (F a)) -> Ex F A. Qed.
+Goal forall (A:Type) (f : Type -> Type), (forall x, Y (f x)) -> exists f, Ex f A. intros. eexists. apply _.
+ Unshelve.
+ apply A.
+Qed.
+End M1b.
+
diff --git a/apps/tc/tests/register/f1.v b/apps/tc/tests/register/f1.v
new file mode 100644
index 000000000..89a8006af
--- /dev/null
+++ b/apps/tc/tests/register/f1.v
@@ -0,0 +1,8 @@
+From elpi.apps Require Import tc.
+
+Elpi Override TC TC.Solver All.
+
+Class A (n : nat).
+Instance I1 : A 1. Qed.
+
+Goal A 1. apply _. Qed.
\ No newline at end of file
diff --git a/apps/tc/tests/register/f2.v b/apps/tc/tests/register/f2.v
new file mode 100644
index 000000000..5410ffea2
--- /dev/null
+++ b/apps/tc/tests/register/f2.v
@@ -0,0 +1,9 @@
+From elpi.apps.tc.tests.register Require Export f1.
+
+Goal A 1. apply _. Qed.
+
+Elpi TC Deactivate Observer TC.Compiler.
+
+Instance I2 : A 2. Qed.
+
+Goal A 2. Fail apply _. Abort.
\ No newline at end of file
diff --git a/apps/tc/tests/register/f3.v b/apps/tc/tests/register/f3.v
new file mode 100644
index 000000000..ad91b9b21
--- /dev/null
+++ b/apps/tc/tests/register/f3.v
@@ -0,0 +1,28 @@
+From elpi.apps.tc.tests.register Require Import f2.
+
+(*
+ Note that in f2, TC.Compiler has been deactivated,
+ therefore I3 should not be added
+*)
+
+Instance I3 : A 3. Qed.
+
+Goal A 3. Fail apply _. Abort.
+
+Elpi Command custom_observer.
+Elpi Accumulate lp:{{
+ main L :-
+ coq.say "Received the following event" L.
+}}.
+
+Elpi TC Activate Observer TC.Compiler.
+Elpi Register TC Compiler custom_observer.
+Elpi TC Activate Observer custom_observer.
+
+(* Here we have two active event listener for the instance creation:
+ custom observer which simply prints the received event and
+ TC.Compiler that adds I4 to the db
+*)
+Instance I4 : A 4. Qed.
+
+Goal A 4. apply _. Qed.
diff --git a/apps/tc/tests/section_in_out.v b/apps/tc/tests/section_in_out.v
new file mode 100644
index 000000000..45d11cff5
--- /dev/null
+++ b/apps/tc/tests/section_in_out.v
@@ -0,0 +1,56 @@
+From elpi.apps Require Import tc.
+From elpi.apps.tc Extra Dependency "base.elpi" as base.
+
+Elpi Accumulate tc.db lp:{{
+ pred origial_tc o:int.
+}}.
+
+Elpi Command len_test.
+Elpi Accumulate Db tc.db.
+Elpi Accumulate File base.
+Elpi Accumulate lp:{{
+ % contains the number of instances that are not
+ % imported from other files
+ main [int Len] :-
+ std.findall (instance _ _ _) Insts,
+ std.map Insts (x\r\ instance _ r _ = x) R,
+ WantedLength is {origial_tc} + Len,
+ std.assert! ({std.length R} = WantedLength)
+ "Unexpected number of instances",
+ std.forall R (x\ sigma L\
+ std.assert! (count R x L, L = 1) "Duplicates in instances").
+}}.
+
+Elpi Query TC.Solver lp:{{
+ std.findall (instance _ _ _) Rules,
+ std.length Rules Len,
+ coq.elpi.accumulate _ "tc.db" (clause _ _ (origial_tc Len)).
+}}.
+
+Class Eqb A:= eqb: A -> A -> bool.
+Global Instance eqA : Eqb unit := { eqb x y := true }.
+
+Elpi len_test 1.
+
+Section A.
+ Context (A : Type).
+ Global Instance eqB : Eqb bool := { eqb x y := if x then y else negb y }.
+ Elpi len_test 2.
+
+ Global Instance eqC : Eqb A := {eqb _ _ := true}.
+ Elpi len_test 3.
+
+ Section B.
+ Context (B : Type).
+ Global Instance eqD : Eqb B := {eqb _ _ := true}.
+ Elpi len_test 4.
+ End B.
+
+ Elpi len_test 4.
+
+End A.
+
+Elpi len_test 4.
+
+
+
diff --git a/apps/tc/tests/stdppInj.v b/apps/tc/tests/stdppInj.v
new file mode 100644
index 000000000..2bfc84e50
--- /dev/null
+++ b/apps/tc/tests/stdppInj.v
@@ -0,0 +1,266 @@
+(* Test inspired from https://gitlab.mpi-sws.org/iris/stdpp/-/blob/8c98553ad0ca2029b30cf18b58e321ec3a79172b/stdpp/base.v *)
+
+From Coq Require Export Morphisms RelationClasses List Bool Setoid Peano Utf8.
+From Coq Require Import Permutation.
+Export ListNotations.
+From Coq.Program Require Export Basics Syntax.
+
+From elpi.apps Require Import tc.
+Elpi Override TC TC.Solver All.
+Elpi TC.AddAllClasses.
+Elpi TC.AddAllInstances.
+Notation length := Datatypes.length.
+Global Generalizable All Variables.
+Global Unset Transparent Obligations.
+
+Definition tc_opaque {A} (x : A) : A := x.
+(* Typeclasses Opaque tc_opaque. *)
+
+Global Arguments tc_opaque {_} _ /.
+Declare Scope stdpp_scope.
+Delimit Scope stdpp_scope with stdpp.
+Global Open Scope stdpp_scope.
+Notation "(=)" := eq (only parsing) : stdpp_scope.
+Notation "( x =.)" := (eq x) (only parsing) : stdpp_scope.
+Notation "(.= x )" := (λ y, eq y x) (only parsing) : stdpp_scope.
+Notation "(≠)" := (λ x y, x ≠ y) (only parsing) : stdpp_scope.
+Notation "( x ≠.)" := (λ y, x ≠ y) (only parsing) : stdpp_scope.
+Notation "(.≠ x )" := (λ y, y ≠ x) (only parsing) : stdpp_scope.
+Infix "=@{ A }" := (@eq A)
+ (at level 70, only parsing, no associativity) : stdpp_scope.
+Notation "(=@{ A } )" := (@eq A) (only parsing) : stdpp_scope.
+Notation "(≠@{ A } )" := (λ X Y, ¬X =@{A} Y) (only parsing) : stdpp_scope.
+Notation "X ≠@{ A } Y":= (¬X =@{ A } Y)
+ (at level 70, only parsing, no associativity) : stdpp_scope.
+
+Global Hint Extern 0 (_ = _) => reflexivity : core.
+Global Hint Extern 100 (_ ≠ _) => discriminate : core.
+
+Global Instance: ∀ A, PreOrder (=@{A}).
+Proof. split; repeat intro; congruence. Qed.
+Class Equiv A := equiv: relation A.
+Global Instance equiv_rewrite_relation `{Equiv A} :
+ RewriteRelation (@equiv A _) | 150 := {}.
+
+Infix "≡" := equiv (at level 70, no associativity) : stdpp_scope.
+Infix "≡@{ A }" := (@equiv A _)
+ (at level 70, only parsing, no associativity) : stdpp_scope.
+
+Notation "(≡)" := equiv (only parsing) : stdpp_scope.
+Notation "( X ≡.)" := (equiv X) (only parsing) : stdpp_scope.
+Notation "(.≡ X )" := (λ Y, Y ≡ X) (only parsing) : stdpp_scope.
+Notation "(≢)" := (λ X Y, ¬X ≡ Y) (only parsing) : stdpp_scope.
+Notation "X ≢ Y":= (¬X ≡ Y) (at level 70, no associativity) : stdpp_scope.
+Notation "( X ≢.)" := (λ Y, X ≢ Y) (only parsing) : stdpp_scope.
+Notation "(.≢ X )" := (λ Y, Y ≢ X) (only parsing) : stdpp_scope.
+
+Notation "(≡@{ A } )" := (@equiv A _) (only parsing) : stdpp_scope.
+Notation "(≢@{ A } )" := (λ X Y, ¬X ≡@{A} Y) (only parsing) : stdpp_scope.
+Notation "X ≢@{ A } Y":= (¬X ≡@{ A } Y)
+ (at level 70, only parsing, no associativity) : stdpp_scope.
+Class LeibnizEquiv A `{Equiv A} :=
+ leibniz_equiv (x y : A) : x ≡ y → x = y.
+Global Hint Mode LeibnizEquiv ! - : typeclass_instances.
+
+Global Instance: Params (@equiv) 2 := {}.
+Global Instance equiv_default_relation `{Equiv A} :
+ DefaultRelation (≡@{A}) | 3 := {}.
+Global Hint Extern 0 (_ ≡ _) => reflexivity : core.
+Global Hint Extern 0 (_ ≡ _) => symmetry; assumption : core.
+
+
+Class Inj {A B} (R : relation A) (S : relation B) (f : A → B) : Prop :=
+ inj x y : S (f x) (f y) → R x y.
+
+Class Inj2 {A B C} (R1 : relation A) (R2 : relation B)
+ (S : relation C) (f : A → B → C) : Prop :=
+ inj2 x1 x2 y1 y2 : S (f x1 x2) (f y1 y2) → R1 x1 y1 ∧ R2 x2 y2.
+
+Global Arguments irreflexivity {_} _ {_} _ _ : assert.
+Global Arguments inj {_ _ _ _} _ {_} _ _ _ : assert.
+Global Arguments inj2 {_ _ _ _ _ _} _ {_} _ _ _ _ _: assert.
+
+Global Instance inj2_inj_1 `{Inj2 A B C R1 R2 R3 f} y : Inj R1 R3 (λ x, f x y).
+Proof. repeat intro; edestruct (inj2 f); eauto. Qed.
+Global Instance inj2_inj_2 `{Inj2 A B C R1 R2 R3 f} x : Inj R2 R3 (f x).
+Proof. repeat intro; edestruct (inj2 f); eauto. Qed.
+
+Notation "(∧)" := and (only parsing) : stdpp_scope.
+Notation "( A ∧.)" := (and A) (only parsing) : stdpp_scope.
+Notation "(.∧ B )" := (λ A, A ∧ B) (only parsing) : stdpp_scope.
+
+Notation "(∨)" := or (only parsing) : stdpp_scope.
+Notation "( A ∨.)" := (or A) (only parsing) : stdpp_scope.
+Notation "(.∨ B )" := (λ A, A ∨ B) (only parsing) : stdpp_scope.
+
+Notation "(↔)" := iff (only parsing) : stdpp_scope.
+Notation "( A ↔.)" := (iff A) (only parsing) : stdpp_scope.
+Notation "(.↔ B )" := (λ A, A ↔ B) (only parsing) : stdpp_scope.
+
+Global Hint Extern 0 (_ ↔ _) => reflexivity : core.
+Global Hint Extern 0 (_ ↔ _) => symmetry; assumption : core.
+
+Notation "(→)" := (λ A B, A → B) (only parsing) : stdpp_scope.
+Notation "( A →.)" := (λ B, A → B) (only parsing) : stdpp_scope.
+Notation "(.→ B )" := (λ A, A → B) (only parsing) : stdpp_scope.
+
+Notation "t $ r" := (t r)
+ (at level 65, right associativity, only parsing) : stdpp_scope.
+Notation "($)" := (λ f x, f x) (only parsing) : stdpp_scope.
+Notation "(.$ x )" := (λ f, f x) (only parsing) : stdpp_scope.
+
+Infix "∘" := compose : stdpp_scope.
+Notation "(∘)" := compose (only parsing) : stdpp_scope.
+Notation "( f ∘.)" := (compose f) (only parsing) : stdpp_scope.
+Notation "(.∘ f )" := (λ g, compose g f) (only parsing) : stdpp_scope.
+(** Ensure that [simpl] unfolds [id], [compose], and [flip] when fully
+applied. *)
+Global Arguments id _ _ / : assert.
+Global Arguments compose _ _ _ _ _ _ / : assert.
+Global Arguments flip _ _ _ _ _ _ / : assert.
+Global Arguments const _ _ _ _ / : assert.
+
+Definition fun_map {A A' B B'} (f: A' → A) (g: B → B') (h : A → B) : A' → B' :=
+ g ∘ h ∘ f.
+
+Global Instance id_inj {A} : Inj (=) (=) (@id A).
+Proof. intros ??; auto. Qed.
+Global Instance compose_inj {A B C} R1 R2 R3 (f : A → B) (g : B → C) :
+ Inj R1 R2 f → Inj R2 R3 g → Inj R1 R3 (g ∘ f).
+Proof. red; intuition. Qed.
+
+(** ** Products *)
+Notation "( x ,.)" := (pair x) (only parsing) : stdpp_scope.
+Notation "(., y )" := (λ x, (x,y)) (only parsing) : stdpp_scope.
+
+Notation "p .1" := (fst p) (at level 2, left associativity, format "p .1").
+Notation "p .2" := (snd p) (at level 2, left associativity, format "p .2").
+
+Definition prod_map {A A' B B'} (f: A → A') (g: B → B') (p : A * B) : A' * B' :=
+ (f (p.1), g (p.2)).
+Global Arguments prod_map {_ _ _ _} _ _ !_ / : assert.
+
+Global Instance pair_inj {A B} : Inj2 (=) (=) (=) (@pair A B).
+Proof. injection 1; auto. Qed.
+Global Instance prod_map_inj {A A' B B'} (f : A → A') (g : B → B') :
+ Inj (=) (=) f → Inj (=) (=) g → Inj (=) (=) (prod_map f g).
+Proof.
+ intros ?? [??] [??] ?; simpl in *; f_equal;
+ [apply (inj f)|apply (inj g)]; congruence.
+Qed.
+
+Definition prod_relation {A B} (R1 : relation A) (R2 : relation B) :
+ relation (A * B) := λ x y, R1 (x.1) (y.1) ∧ R2 (x.2) (y.2).
+
+Section prod_relation.
+ Context `{RA : relation A, RB : relation B}.
+ Global Instance pair_inj' : Inj2 RA RB (prod_relation RA RB) pair.
+ Proof. inversion_clear 1; eauto. Qed.
+End prod_relation.
+
+Global Instance prod_equiv `{Equiv A,Equiv B} : Equiv (A * B) :=
+ prod_relation (≡) (≡).
+
+Section prod_setoid.
+ Context `{Equiv A, Equiv B}.
+
+ Elpi Accumulate TC.Solver lp:{{
+ shorten tc-elpi.apps.tc.tests.stdppInj.{tc-Inj2}.
+ % shorten tc-stdppInj.{tc-Inj2}.
+ tc-Inj2 A B C RA RB RC F S :-
+ RC = app [global {coq.locate "equiv"} | _],
+ Res = {{prod_relation _ _}},
+ coq.unify-eq RC Res ok,
+ tc-Inj2 A B C RA RB Res F S.
+ }}.
+ Elpi Typecheck TC.Solver.
+
+ Global Instance pair_equiv_inj : Inj2 (≡) (≡) (≡@{A*B}) pair := _.
+End prod_setoid.
+
+(* Typeclasses Opaque prod_equiv. *)
+
+(** ** Sums *)
+Definition sum_map {A A' B B'} (f: A → A') (g: B → B') (xy : A + B) : A' + B' :=
+ match xy with inl x => inl (f x) | inr y => inr (g y) end.
+Global Arguments sum_map {_ _ _ _} _ _ !_ / : assert.
+
+Global Instance inl_inj {A B} : Inj (=) (=) (@inl A B).
+Proof. injection 1; auto. Qed.
+Global Instance inr_inj {A B} : Inj (=) (=) (@inr A B).
+Proof. injection 1; auto. Qed.
+
+Global Instance sum_map_inj {A A' B B'} (f : A → A') (g : B → B') :
+ Inj (=) (=) f → Inj (=) (=) g → Inj (=) (=) (sum_map f g).
+Proof. intros ?? [?|?] [?|?] [=]; f_equal; apply (inj _); auto. Qed.
+
+Inductive sum_relation {A B}
+ (RA : relation A) (RB : relation B) : relation (A + B) :=
+ | inl_related x1 x2 : RA x1 x2 → sum_relation RA RB (inl x1) (inl x2)
+ | inr_related y1 y2 : RB y1 y2 → sum_relation RA RB (inr y1) (inr y2).
+
+Section sum_relation.
+ Context `{RA : relation A, RB : relation B}.
+ Global Instance inl_inj' : Inj RA (sum_relation RA RB) inl.
+ Proof. inversion_clear 1; auto. Qed.
+ Global Instance inr_inj' : Inj RB (sum_relation RA RB) inr.
+ Proof. inversion_clear 1; auto. Qed.
+End sum_relation.
+
+Global Instance sum_equiv `{Equiv A, Equiv B} : Equiv (A + B) := sum_relation (≡) (≡).
+
+Elpi Accumulate TC.Solver lp:{{
+ shorten tc-elpi.apps.tc.tests.stdppInj.{tc-Inj}.
+ % shorten tc-stdppInj.{tc-Inj}.
+ tc-Inj A B RA {{@equiv (sum _ _) (@sum_equiv _ _ _ _)}} S C :-
+ tc-Inj A B RA {{sum_relation _ _}} S C.
+}}.
+Elpi Typecheck TC.Solver.
+
+Global Instance inl_equiv_inj `{Equiv A, Equiv B} : Inj (≡) (≡) (@inl A B) := _.
+Global Instance inr_equiv_inj `{Equiv A, Equiv B} : Inj (≡) (≡) (@inr A B) := _.
+
+Notation "` x" := (proj1_sig x) (at level 10, format "` x") : stdpp_scope.
+
+Elpi Accumulate TC.Solver lp:{{
+ shorten tc-elpi.apps.tc.tests.stdppInj.{tc-Inj}.
+ tc-Inj A B RA RB F X :-
+ F = fun _ _ _,
+ G = {{@compose _ _ _ _ _}},
+ coq.unify-eq G F ok,
+ tc-Inj A B RA RB G X.
+}}.
+Elpi Typecheck TC.Solver.
+
+Definition f := Nat.add 0.
+Global Instance h: Inj eq eq f.
+ unfold f. simpl. easy.
+Qed.
+
+Elpi Accumulate TC.Solver lp:{{
+ shorten tc-elpi.apps.tc.tests.stdppInj.{tc-Inj}.
+ :after "lastHook"
+ tc-Inj A B RA RB F S :-
+ F = (fun _ _ _), !,
+ G = {{ compose _ _ }},
+ coq.unify-eq G F ok,
+ tc-Inj A B RA RB G S.
+}}.
+Set Warnings "+elpi".
+
+Elpi Typecheck TC.Solver.
+Goal Inj eq eq (compose (@id nat) id).
+apply _.
+Qed.
+
+Goal Inj eq eq (compose (compose (@id nat) id) id).
+apply _.
+Qed.
+
+Goal Inj eq eq (fun (x:nat) => id (id x)).
+ apply _.
+Qed.
+
+Goal Inj eq eq (fun (x: nat) => (compose id id) (id x)).
+apply (compose_inj eq eq); apply _.
+Qed.
\ No newline at end of file
diff --git a/apps/tc/tests/stdppInjClassic.v b/apps/tc/tests/stdppInjClassic.v
new file mode 100644
index 000000000..eaea31c59
--- /dev/null
+++ b/apps/tc/tests/stdppInjClassic.v
@@ -0,0 +1,219 @@
+(* File inspired from https://gitlab.mpi-sws.org/iris/stdpp/-/blob/8c98553ad0ca2029b30cf18b58e321ec3a79172b/stdpp/base.v *)
+From Coq Require Export Morphisms RelationClasses List Bool Setoid Peano Utf8.
+From Coq Require Import Permutation.
+Export ListNotations.
+From Coq.Program Require Export Basics Syntax.
+
+Notation length := Datatypes.length.
+Global Generalizable All Variables.
+Global Unset Transparent Obligations.
+
+Definition tc_opaque {A} (x : A) : A := x.
+(* Typeclasses Opaque tc_opaque. *)
+
+Global Arguments tc_opaque {_} _ /.
+Declare Scope stdpp_scope.
+Delimit Scope stdpp_scope with stdpp.
+Global Open Scope stdpp_scope.
+Notation "(=)" := eq (only parsing) : stdpp_scope.
+Notation "( x =.)" := (eq x) (only parsing) : stdpp_scope.
+Notation "(.= x )" := (λ y, eq y x) (only parsing) : stdpp_scope.
+Notation "(≠)" := (λ x y, x ≠ y) (only parsing) : stdpp_scope.
+Notation "( x ≠.)" := (λ y, x ≠ y) (only parsing) : stdpp_scope.
+Notation "(.≠ x )" := (λ y, y ≠ x) (only parsing) : stdpp_scope.
+Infix "=@{ A }" := (@eq A)
+ (at level 70, only parsing, no associativity) : stdpp_scope.
+Notation "(=@{ A } )" := (@eq A) (only parsing) : stdpp_scope.
+Notation "(≠@{ A } )" := (λ X Y, ¬X =@{A} Y) (only parsing) : stdpp_scope.
+Notation "X ≠@{ A } Y":= (¬X =@{ A } Y)
+ (at level 70, only parsing, no associativity) : stdpp_scope.
+
+Global Hint Extern 0 (_ = _) => reflexivity : core.
+Global Hint Extern 100 (_ ≠ _) => discriminate : core.
+
+Global Instance: ∀ A, PreOrder (=@{A}).
+Proof. split; repeat intro; congruence. Qed.
+Class Equiv A := equiv: relation A.
+Global Instance equiv_rewrite_relation `{Equiv A} :
+ RewriteRelation (@equiv A _) | 150 := {}.
+
+Infix "≡" := equiv (at level 70, no associativity) : stdpp_scope.
+Infix "≡@{ A }" := (@equiv A _)
+ (at level 70, only parsing, no associativity) : stdpp_scope.
+
+Notation "(≡)" := equiv (only parsing) : stdpp_scope.
+Notation "( X ≡.)" := (equiv X) (only parsing) : stdpp_scope.
+Notation "(.≡ X )" := (λ Y, Y ≡ X) (only parsing) : stdpp_scope.
+Notation "(≢)" := (λ X Y, ¬X ≡ Y) (only parsing) : stdpp_scope.
+Notation "X ≢ Y":= (¬X ≡ Y) (at level 70, no associativity) : stdpp_scope.
+Notation "( X ≢.)" := (λ Y, X ≢ Y) (only parsing) : stdpp_scope.
+Notation "(.≢ X )" := (λ Y, Y ≢ X) (only parsing) : stdpp_scope.
+
+Notation "(≡@{ A } )" := (@equiv A _) (only parsing) : stdpp_scope.
+Notation "(≢@{ A } )" := (λ X Y, ¬X ≡@{A} Y) (only parsing) : stdpp_scope.
+Notation "X ≢@{ A } Y":= (¬X ≡@{ A } Y)
+ (at level 70, only parsing, no associativity) : stdpp_scope.
+Class LeibnizEquiv A `{Equiv A} :=
+ leibniz_equiv (x y : A) : x ≡ y → x = y.
+Global Hint Mode LeibnizEquiv ! - : typeclass_instances.
+
+Global Instance: Params (@equiv) 2 := {}.
+Global Instance equiv_default_relation `{Equiv A} :
+ DefaultRelation (≡@{A}) | 3 := {}.
+Global Hint Extern 0 (_ ≡ _) => reflexivity : core.
+Global Hint Extern 0 (_ ≡ _) => symmetry; assumption : core.
+
+
+Class Inj {A B} (R : relation A) (S : relation B) (f : A → B) : Prop :=
+ inj x y : S (f x) (f y) → R x y.
+
+Class Inj2 {A B C} (R1 : relation A) (R2 : relation B)
+ (S : relation C) (f : A → B → C) : Prop :=
+ inj2 x1 x2 y1 y2 : S (f x1 x2) (f y1 y2) → R1 x1 y1 ∧ R2 x2 y2.
+
+Global Arguments irreflexivity {_} _ {_} _ _ : assert.
+Global Arguments inj {_ _ _ _} _ {_} _ _ _ : assert.
+Global Arguments inj2 {_ _ _ _ _ _} _ {_} _ _ _ _ _: assert.
+
+Global Instance inj2_inj_1 `{Inj2 A B C R1 R2 R3 f} y : Inj R1 R3 (λ x, f x y).
+Proof. repeat intro; edestruct (inj2 f); eauto. Qed.
+Global Instance inj2_inj_2 `{Inj2 A B C R1 R2 R3 f} x : Inj R2 R3 (f x).
+Proof. repeat intro; edestruct (inj2 f); eauto. Qed.
+
+Notation "(∧)" := and (only parsing) : stdpp_scope.
+Notation "( A ∧.)" := (and A) (only parsing) : stdpp_scope.
+Notation "(.∧ B )" := (λ A, A ∧ B) (only parsing) : stdpp_scope.
+
+Notation "(∨)" := or (only parsing) : stdpp_scope.
+Notation "( A ∨.)" := (or A) (only parsing) : stdpp_scope.
+Notation "(.∨ B )" := (λ A, A ∨ B) (only parsing) : stdpp_scope.
+
+Notation "(↔)" := iff (only parsing) : stdpp_scope.
+Notation "( A ↔.)" := (iff A) (only parsing) : stdpp_scope.
+Notation "(.↔ B )" := (λ A, A ↔ B) (only parsing) : stdpp_scope.
+
+Global Hint Extern 0 (_ ↔ _) => reflexivity : core.
+Global Hint Extern 0 (_ ↔ _) => symmetry; assumption : core.
+
+Notation "(→)" := (λ A B, A → B) (only parsing) : stdpp_scope.
+Notation "( A →.)" := (λ B, A → B) (only parsing) : stdpp_scope.
+Notation "(.→ B )" := (λ A, A → B) (only parsing) : stdpp_scope.
+
+Notation "t $ r" := (t r)
+ (at level 65, right associativity, only parsing) : stdpp_scope.
+Notation "($)" := (λ f x, f x) (only parsing) : stdpp_scope.
+Notation "(.$ x )" := (λ f, f x) (only parsing) : stdpp_scope.
+
+Infix "∘" := compose : stdpp_scope.
+Notation "(∘)" := compose (only parsing) : stdpp_scope.
+Notation "( f ∘.)" := (compose f) (only parsing) : stdpp_scope.
+Notation "(.∘ f )" := (λ g, compose g f) (only parsing) : stdpp_scope.
+(** Ensure that [simpl] unfolds [id], [compose], and [flip] when fully
+applied. *)
+Global Arguments id _ _ / : assert.
+Global Arguments compose _ _ _ _ _ _ / : assert.
+Global Arguments flip _ _ _ _ _ _ / : assert.
+Global Arguments const _ _ _ _ / : assert.
+
+Definition fun_map {A A' B B'} (f: A' → A) (g: B → B') (h : A → B) : A' → B' :=
+ g ∘ h ∘ f.
+
+Global Instance id_inj {A} : Inj (=) (=) (@id A).
+Proof. intros ??; auto. Qed.
+Global Instance compose_inj {A B C} R1 R2 R3 (f : A → B) (g : B → C) :
+ Inj R1 R2 f → Inj R2 R3 g → Inj R1 R3 (g ∘ f).
+Proof. red; intuition. Qed.
+
+(** ** Products *)
+Notation "( x ,.)" := (pair x) (only parsing) : stdpp_scope.
+Notation "(., y )" := (λ x, (x,y)) (only parsing) : stdpp_scope.
+
+Notation "p .1" := (fst p) (at level 2, left associativity, format "p .1").
+Notation "p .2" := (snd p) (at level 2, left associativity, format "p .2").
+
+Definition prod_map {A A' B B'} (f: A → A') (g: B → B') (p : A * B) : A' * B' :=
+ (f (p.1), g (p.2)).
+Global Arguments prod_map {_ _ _ _} _ _ !_ / : assert.
+
+Global Instance pair_inj {A B} : Inj2 (=) (=) (=) (@pair A B).
+Proof. injection 1; auto. Qed.
+Global Instance prod_map_inj {A A' B B'} (f : A → A') (g : B → B') :
+ Inj (=) (=) f → Inj (=) (=) g → Inj (=) (=) (prod_map f g).
+Proof.
+ intros ?? [??] [??] ?; simpl in *; f_equal;
+ [apply (inj f)|apply (inj g)]; congruence.
+Qed.
+
+Definition prod_relation {A B} (R1 : relation A) (R2 : relation B) :
+ relation (A * B) := λ x y, R1 (x.1) (y.1) ∧ R2 (x.2) (y.2).
+
+Section prod_relation.
+ Context `{RA : relation A, RB : relation B}.
+ Global Instance pair_inj' : Inj2 RA RB (prod_relation RA RB) pair.
+ Proof. inversion_clear 1; eauto. Qed.
+End prod_relation.
+
+Global Instance prod_equiv `{Equiv A,Equiv B} : Equiv (A * B) :=
+ prod_relation (≡) (≡).
+
+Section prod_setoid.
+ Context `{Equiv A, Equiv B}.
+ Global Instance pair_equiv_inj : Inj2 (≡) (≡) (≡@{A*B}) pair := _.
+End prod_setoid.
+
+(* Typeclasses Opaque prod_equiv. *)
+
+(** ** Sums *)
+Definition sum_map {A A' B B'} (f: A → A') (g: B → B') (xy : A + B) : A' + B' :=
+ match xy with inl x => inl (f x) | inr y => inr (g y) end.
+Global Arguments sum_map {_ _ _ _} _ _ !_ / : assert.
+
+Global Instance inl_inj {A B} : Inj (=) (=) (@inl A B).
+Proof. injection 1; auto. Qed.
+Global Instance inr_inj {A B} : Inj (=) (=) (@inr A B).
+Proof. injection 1; auto. Qed.
+
+Global Instance sum_map_inj {A A' B B'} (f : A → A') (g : B → B') :
+ Inj (=) (=) f → Inj (=) (=) g → Inj (=) (=) (sum_map f g).
+Proof. intros ?? [?|?] [?|?] [=]; f_equal; apply (inj _); auto. Qed.
+
+Inductive sum_relation {A B}
+ (RA : relation A) (RB : relation B) : relation (A + B) :=
+ | inl_related x1 x2 : RA x1 x2 → sum_relation RA RB (inl x1) (inl x2)
+ | inr_related y1 y2 : RB y1 y2 → sum_relation RA RB (inr y1) (inr y2).
+
+Section sum_relation.
+ Context `{RA : relation A, RB : relation B}.
+ Global Instance inl_inj' : Inj RA (sum_relation RA RB) inl.
+ Proof. inversion_clear 1; auto. Qed.
+ Global Instance inr_inj' : Inj RB (sum_relation RA RB) inr.
+ Proof. inversion_clear 1; auto. Qed.
+End sum_relation.
+
+Global Instance sum_equiv `{Equiv A, Equiv B} : Equiv (A + B) := sum_relation (≡) (≡).
+
+Global Instance inl_equiv_inj `{Equiv A, Equiv B} : Inj (≡) (≡) (@inl A B) := _.
+Global Instance inr_equiv_inj `{Equiv A, Equiv B} : Inj (≡) (≡) (@inr A B) := _.
+
+Notation "` x" := (proj1_sig x) (at level 10, format "` x") : stdpp_scope.
+
+Definition f := Nat.add 0.
+Global Instance h: Inj eq eq f.
+ unfold f. simpl. easy.
+Qed.
+
+Goal Inj eq eq (compose (@id nat) id).
+apply _.
+Qed.
+
+Goal Inj eq eq (compose (compose (@id nat) id) id).
+apply _.
+Qed.
+
+(* Goal Inj eq eq (fun (x:nat) => id (id x)).
+apply _.
+Qed. *)
+
+Goal Inj eq eq (fun (x: nat) => (compose id id) (id x)).
+apply (compose_inj eq eq); apply _.
+Qed.
\ No newline at end of file
diff --git a/apps/tc/tests/test.v b/apps/tc/tests/test.v
new file mode 100644
index 000000000..8f25cef5f
--- /dev/null
+++ b/apps/tc/tests/test.v
@@ -0,0 +1,21 @@
+From elpi.apps.tc.tests Require Import stdppInj.
+Elpi TC.Solver. Set TC TimeRefine. Set TC ResolutionTime. Set Debug "elpitime".
+Elpi Accumulate TC.Solver lp:{{
+ shorten tc-elpi.apps.tc.tests.stdppInj.{tc-Inj}.
+ :after "firstHook"
+ tc-Inj A B RA RB {{@compose lp:A lp:A lp:A lp:FL lp:FL}} Sol :- !,
+ tc-Inj A B RA RB FL Sol1,
+ coq.typecheck A TA ok,
+ coq.typecheck RA TRA ok,
+ coq.typecheck FL TFL ok,
+ coq.typecheck Sol1 TSol1 ok,
+ Sol = {{
+ let a : lp:TA := lp:A in
+ let sol : lp:TSol1 := lp:Sol1 in
+ let ra : lp:TRA := lp:RA in
+ let fl : lp:TFL := lp:FL in
+ @compose_inj a a a ra ra ra fl fl sol sol}}.
+}}.
+Elpi Typecheck TC.Solver.
+
+Goal Inj eq eq((compose (compose (compose f f )(compose f f ))(compose (compose f f )(compose f f )))). Time apply _. Qed.
diff --git a/apps/tc/tests/test_commands_API.v b/apps/tc/tests/test_commands_API.v
new file mode 100644
index 000000000..f45d8d289
--- /dev/null
+++ b/apps/tc/tests/test_commands_API.v
@@ -0,0 +1,58 @@
+From elpi.apps Require Import tc.
+From elpi.apps.tc.tests Require Import eqSimplDef.
+
+Elpi Command len_test.
+Elpi Accumulate Db tc.db.
+Elpi Accumulate lp:{{
+ pred count i:gref, i:int.
+ count GR Len :-
+ if (const _ = GR)
+ (std.findall (instance _ _ GR) Cl,
+ std.assert! ({std.length Cl} = Len)
+ "Unexpected number of instances")
+ true.
+
+ main [str E, int Len] :-
+ coq.locate E GR,
+ count GR Len.
+}}.
+Elpi Typecheck.
+
+Elpi AddClasses Eqb.
+
+Module test1.
+ Elpi AddInstances Eqb ignoreInstances eqP.
+ Elpi len_test Eqb 2.
+End test1.
+Reset test1.
+
+Module test2.
+ Elpi len_test Eqb 0.
+End test2.
+Reset test2.
+
+Module test3.
+ Elpi AddInstances Eqb.
+ Elpi len_test Eqb 3.
+End test3.
+Reset test3.
+
+
+(* About RewriteRelation.
+
+About RelationClasses.RewriteRelation.
+
+
+Elpi Query TC.Solver lp:{{
+ coq.gref->id {{:gref RelationClasses.RewriteRelation}} L.
+}}. *)
+
+Module test4.
+ Elpi AddAllClasses.
+ Elpi AddAllInstances eqU.
+
+ Elpi Query TC.Solver lp:{{
+ EqP = {{:gref eqU}},
+ std.assert! (not (instance _ EqP _)) "EqP should not be in the DB".
+ }}.
+End test4.
\ No newline at end of file
diff --git a/apps/tc/tests/test_tc.v b/apps/tc/tests/test_tc.v
new file mode 100644
index 000000000..8b4970ee3
--- /dev/null
+++ b/apps/tc/tests/test_tc.v
@@ -0,0 +1,12 @@
+From elpi.apps Require Import tc.
+
+Elpi Override TC TC.Solver All.
+
+Class a (N: nat).
+Instance b : a 3. Qed.
+Instance c : a 4. Qed.
+
+Elpi AddAllClasses.
+Elpi AddAllInstances.
+
+Goal a 4. apply _. Qed.
diff --git a/apps/tc/theories/add_commands.v b/apps/tc/theories/add_commands.v
new file mode 100644
index 000000000..6e4457582
--- /dev/null
+++ b/apps/tc/theories/add_commands.v
@@ -0,0 +1,102 @@
+(* license: GNU Lesser General Public License Version 2.1 or later *)
+(* ------------------------------------------------------------------------- *)
+
+From elpi.apps Require Import db.
+
+From elpi.apps.tc Extra Dependency "base.elpi" as base.
+From elpi.apps.tc Extra Dependency "compiler.elpi" as compiler.
+From elpi.apps.tc Extra Dependency "parser_addInstances.elpi" as parser_addInstances.
+From elpi.apps.tc Extra Dependency "solver.elpi" as solver.
+From elpi.apps.tc Extra Dependency "tc_aux.elpi" as tc_aux.
+From elpi.apps.tc Extra Dependency "create_tc_predicate.elpi" as create_tc_predicate.
+
+Elpi Command TC.AddAllInstances.
+Elpi Accumulate Db tc.db.
+Elpi Accumulate Db tc_options.db.
+Elpi Accumulate File base.
+Elpi Accumulate File tc_aux.
+Elpi Accumulate File compiler.
+Elpi Accumulate lp:{{
+ main L :-
+ args->str-list L L1,
+ std.forall {coq.TC.db-tc} (x\ add-tc-or-inst-gr [] L1 [x]).
+}}.
+Elpi Typecheck.
+
+Elpi Command TC.AddInstances.
+Elpi Accumulate Db tc.db.
+Elpi Accumulate Db tc_options.db.
+Elpi Accumulate File base.
+Elpi Accumulate File tc_aux.
+Elpi Accumulate File compiler.
+Elpi Accumulate File parser_addInstances.
+Elpi Accumulate lp:{{
+ main Arguments :-
+ parse Arguments Res, run-command Res.
+}}.
+Elpi Typecheck.
+
+Elpi Command TC.AddAllClasses.
+Elpi Accumulate Db tc.db.
+Elpi Accumulate Db tc_options.db.
+Elpi Accumulate File base.
+Elpi Accumulate File tc_aux.
+Elpi Accumulate File create_tc_predicate.
+Elpi Accumulate lp:{{
+ main _ :-
+ coq.TC.db-tc TC,
+ std.forall TC (add-class-gr classic).
+}}.
+Elpi Typecheck.
+
+Elpi Command TC.AddClasses.
+Elpi Accumulate Db tc.db.
+Elpi Accumulate Db tc_options.db.
+Elpi Accumulate File base.
+Elpi Accumulate File tc_aux.
+Elpi Accumulate File create_tc_predicate.
+Elpi Accumulate lp:{{
+ main L :-
+ std.mem {attributes} (attribute "deterministic" _),
+ std.forall {args->str-list L} (add-class-str deterministic).
+ main L :- std.forall {args->str-list L} (add-class-str classic).
+ main _ :- coq.error "This commands accepts: [classic|deterministic]? TC-names*".
+}}.
+Elpi Typecheck.
+
+Elpi Command TC.AddHook.
+Elpi Accumulate Db tc.db.
+Elpi Accumulate Db tc_options.db.
+Elpi Accumulate File base.
+Elpi Accumulate File tc_aux.
+Elpi Accumulate lp:{{
+ pred addHook i:grafting, i:string.
+ addHook Grafting NewName :-
+ @global! => add-tc-db NewName Grafting (hook NewName).
+
+ main [str "before", str OldHook, str NewHook] :-
+ addHook (before OldHook) NewHook.
+
+ main [str "after", str OldHook, str NewHook] :-
+ addHook (after OldHook) NewHook.
+
+ main [Graft, int OldHook, NewHook] :-
+ main [Graft, str {calc (int_to_string OldHook)}, NewHook].
+
+ main [Graft, OldHook, int NewHook] :-
+ main [Graft, OldHook, str {calc (int_to_string NewHook)}].
+
+ main _ :-
+ coq.error "Invalid call to command AddHook. A valid call looks like"
+ "[ElpiAddHook Pos OldName NewName] where:"
+ " - Pos is either after or before"
+ " - OldName is the name of an existing hook"
+ " - NewName is the name of the new hook".
+}}.
+Elpi Typecheck.
+
+Elpi Export TC.AddAllClasses.
+Elpi Export TC.AddAllInstances.
+Elpi Export TC.AddClasses.
+Elpi Export TC.AddInstances.
+Elpi Export TC.AddHook.
\ No newline at end of file
diff --git a/apps/tc/theories/db.v b/apps/tc/theories/db.v
new file mode 100644
index 000000000..2e76b2ef3
--- /dev/null
+++ b/apps/tc/theories/db.v
@@ -0,0 +1,64 @@
+(* license: GNU Lesser General Public License Version 2.1 or later *)
+(* ------------------------------------------------------------------------- *)
+
+From elpi Require Import elpi.
+
+(*
+ tc_option.db contains the set of options used by the solver of tc.
+ all the options are set to false by default
+*)
+Elpi Db tc_options.db lp:{{
+ pred oTC-ignore-eta-reduction o:list string.
+ oTC-ignore-eta-reduction ["TC", "IgnoreEtaReduction"].
+
+ pred oTC-resolution-time o:list string.
+ oTC-resolution-time ["TC", "ResolutionTime"].
+
+ pred oTC-clauseNameShortName o:list string.
+ oTC-clauseNameShortName ["TC", "NameShortPath"].
+
+ pred oTC-time-refine o:list string.
+ oTC-time-refine ["TC", "TimeRefine"].
+
+ pred oTC-debug o:list string.
+ oTC-debug ["TC", "Debug"].
+
+ pred oTC-addModes o:list string.
+ oTC-addModes ["TC", "AddModes"].
+
+ pred oTC-use-pattern-fragment-compiler o:list string.
+ oTC-use-pattern-fragment-compiler ["TC", "CompilerWithPatternFragment"].
+
+ pred is-option-active i:list string.
+ is-option-active Opt :-
+ coq.option.get Opt (coq.option.bool tt).
+}}.
+
+Elpi Db tc.db lp:{{
+ % the type of search for a typeclass
+ % deterministic :- no backtrack after having found a solution/fail
+ % classic :- the classic search, if a path is failing, we backtrack
+ kind search-mode type.
+ type deterministic search-mode.
+ type classic search-mode.
+
+ % [instance Path InstGR ClassGR], ClassGR is the class implemented by InstGR
+ pred instance o:list string, o:gref, o:gref.
+
+ % [class ClassGR PredName SearchMode], for each class GR, it contains
+ % the name of its predicate and its SearchMode
+ pred class o:gref, o:string, o:search-mode.
+
+ % pred on which we graft instances in the database
+ pred hook o:string.
+ :name "firstHook" hook "firstHook".
+ :name "lastHook" hook "lastHook".
+
+ % the set of instances that we are not yet able to compile,
+ % in majority they use universe polimorphism
+ pred banned o:gref.
+
+ % [tc-signature TC Modes], returns for each Typeclass TC
+ % its Modes
+ pred tc-mode i:gref, o:list (pair argument_mode string).
+}}.
\ No newline at end of file
diff --git a/apps/tc/theories/tc.v b/apps/tc/theories/tc.v
new file mode 100644
index 000000000..94f98e0f4
--- /dev/null
+++ b/apps/tc/theories/tc.v
@@ -0,0 +1,127 @@
+(* license: GNU Lesser General Public License Version 2.1 or later *)
+(* ------------------------------------------------------------------------- *)
+
+Declare ML Module "coq-elpi-tc.plugin".
+
+From elpi.apps.tc Extra Dependency "base.elpi" as base.
+From elpi.apps.tc Extra Dependency "compiler.elpi" as compiler.
+From elpi.apps.tc Extra Dependency "parser_addInstances.elpi" as parser_addInstances.
+From elpi.apps.tc Extra Dependency "solver.elpi" as solver.
+From elpi.apps.tc Extra Dependency "tc_aux.elpi" as tc_aux.
+From elpi.apps.tc Extra Dependency "create_tc_predicate.elpi" as create_tc_predicate.
+
+From elpi.apps Require Import db.
+From elpi.apps Require Export add_commands.
+
+Elpi Command TC.Print_instances.
+Elpi Accumulate Db tc.db.
+Elpi Accumulate lp:{{
+ pred list-printer i:gref, i:list prop.
+ list-printer _ [].
+ list-printer ClassGR Instances :-
+ std.map Instances (x\r\ x = instance _ r _) InstancesGR,
+ coq.say "Instances list for" ClassGR "is:",
+ std.forall InstancesGR (x\ coq.say " " x).
+
+ main [str Class] :-
+ std.assert! (coq.locate Class ClassGR) "The entered TC not exists",
+ std.findall (instance _ _ ClassGR) Rules,
+ list-printer ClassGR Rules.
+ main [] :-
+ std.forall {coq.TC.db-tc} (ClassGR\ sigma Rules\
+ std.findall (instance _ _ ClassGR) Rules,
+ list-printer ClassGR Rules
+ ).
+}}.
+Elpi Typecheck.
+
+Elpi Tactic TC.Solver.
+Elpi Accumulate Db tc.db.
+Elpi Accumulate Db tc_options.db.
+Elpi Accumulate File base.
+Elpi Accumulate File tc_aux.
+Elpi Accumulate File compiler.
+Elpi Accumulate File create_tc_predicate.
+Elpi Accumulate File solver.
+Elpi Query lp:{{
+ sigma Options\
+ Options = [oTC-ignore-eta-reduction, oTC-resolution-time,
+ oTC-clauseNameShortName, oTC-time-refine, oTC-debug, oTC-addModes,
+ oTC-use-pattern-fragment-compiler],
+ std.forall Options (x\ sigma Args\ x Args,
+ coq.option.add Args (coq.option.bool ff) ff).
+}}.
+Elpi Typecheck.
+
+Elpi Query lp:{{
+ sigma Nums\
+ std.iota 1001 Nums,
+ std.forall Nums (x\ sigma NumStr\
+ NumStr is int_to_string x,
+ @global! => add-tc-db NumStr (before "lastHook") (hook NumStr)
+ )
+}}.
+
+Elpi Command TC.Compiler.
+Elpi Accumulate Db tc.db.
+Elpi Accumulate Db tc_options.db.
+Elpi Accumulate File base.
+Elpi Accumulate File tc_aux.
+Elpi Accumulate File create_tc_predicate.
+Elpi Accumulate File compiler.
+Elpi Accumulate lp:{{
+ main [str Inst, str Cl, str Locality, int Prio] :- !,
+ % coq.safe-dest-app Inst (global GRInst) _,
+ % coq.safe-dest-app Cl (global GRCl) _,
+ coq.locate Cl GRCl,
+ coq.locate Inst GRInst,
+ add-inst GRInst GRCl Locality Prio.
+
+ main [str Cl] :- !,
+ % coq.safe-dest-app Cl (global GR) _,
+ coq.locate Cl GR,
+ add-class-gr classic GR.
+
+ main A :- coq.error "Fail in TC.Compiler: not a valid input entry" A.
+}}.
+Elpi Typecheck.
+
+(* Command allowing to set if a TC is deterministic. *)
+Elpi Command TC.Set_deterministic.
+Elpi Accumulate Db tc.db.
+Elpi Accumulate Db tc_options.db.
+Elpi Accumulate File base.
+Elpi Accumulate File tc_aux.
+Elpi Accumulate lp:{{
+ main [str ClStr] :-
+ coq.locate ClStr Gr,
+ std.assert! (coq.TC.class? Gr) "Should pass the name of a type class",
+ std.assert! (class Gr PredName _) "Cannot find `class GR _ _` in the db",
+ add-tc-db _ (after "0") (class Gr PredName deterministic :- !).
+}}.
+Elpi Typecheck.
+
+Elpi Command TC.Get_class_info.
+Elpi Accumulate Db tc.db.
+Elpi Accumulate lp:{{
+ main [str ClassStr] :-
+ coq.locate ClassStr ClassGR,
+ class ClassGR PredName SearchMode,
+ coq.say "The predicate of" ClassGR "is" PredName "and search mode is" SearchMode.
+ main [str C] :- coq.error C "is not found in elpi db".
+ main [A] :- std.assert! (str _ = A) true "first argument should be a str".
+ main [_|_] :- coq.error "get_class_info accepts only one argument of type str".
+ main L :- coq.error "Uncaught error on input" L.
+}}.
+Elpi Override TC TC.Solver All.
+
+Elpi Register TC Compiler TC.Compiler.
+
+Elpi Export TC.Print_instances.
+Elpi Export TC.Solver.
+Elpi Export TC.Compiler.
+Elpi Export TC.Get_class_info.
+Elpi Export TC.Set_deterministic.
+
+Elpi TC.AddAllClasses.
+Elpi TC.AddAllInstances.
\ No newline at end of file
diff --git a/apps/tc/theories/wip.v b/apps/tc/theories/wip.v
new file mode 100644
index 000000000..a676988a6
--- /dev/null
+++ b/apps/tc/theories/wip.v
@@ -0,0 +1,77 @@
+(* license: GNU Lesser General Public License Version 2.1 or later *)
+(* --------------------------------------------------------------------------*)
+
+Declare ML Module "coq-elpi-tc.plugin".
+From elpi Require Import elpi.
+
+From elpi.apps.tc Extra Dependency "base.elpi" as base.
+From elpi.apps.tc Extra Dependency "compiler.elpi" as compiler.
+From elpi.apps.tc Extra Dependency "parser_addInstances.elpi" as parser_addInstances.
+From elpi.apps.tc Extra Dependency "alias.elpi" as alias.
+From elpi.apps.tc Extra Dependency "solver.elpi" as solver.
+From elpi.apps.tc Extra Dependency "rewrite_forward.elpi" as rforward.
+From elpi.apps.tc Extra Dependency "tc_aux.elpi" as tc_aux.
+From elpi.apps.tc Extra Dependency "create_tc_predicate.elpi" as create_tc_predicate.
+
+From elpi.apps Require Import tc.
+
+Elpi Command AddForwardRewriting.
+Elpi Accumulate Db tc.db.
+Elpi Accumulate Db tc_options.db.
+Elpi Accumulate File base.
+Elpi Accumulate File tc_aux.
+Elpi Accumulate File compiler.
+Elpi Accumulate File create_tc_predicate.
+Elpi Accumulate File solver.
+Elpi Accumulate File tc_aux.
+Elpi Accumulate File rforward.
+Elpi Accumulate lp:{{
+ :before "build-context-clauses"
+ build-context-clauses Ctx Clauses :- !,
+ std.map {coq.env.section}
+ (x\r\ sigma F\ coq.env.typeof (const x) F,
+ r = (decl (global (const x)) _ F)) SectionCtx,
+ std.append Ctx SectionCtx CtxAndSection,
+ compile-ctx {rewrite-dep CtxAndSection} Clauses.
+
+ main L :-
+ std.forall {args->str-list L} add-lemma->forward.
+}}.
+Elpi Typecheck.
+
+Elpi Command AddAlias.
+Elpi Accumulate Db tc.db.
+Elpi Accumulate Db tc_options.db.
+Elpi Accumulate File base.
+Elpi Accumulate File tc_aux.
+Elpi Accumulate File alias.
+Elpi Accumulate lp:{{
+
+ main [trm New, trm Old] :-
+ add-tc-db _ _ (alias New Old).
+}}.
+Elpi Typecheck.
+
+
+(*
+Elpi Command TC.declare.
+Elpi Accumulate Db tc.db.
+Elpi Accumulate Db tc_options.db.
+Elpi Accumulate File base.
+Elpi Accumulate File tc_aux.
+Elpi Accumulate File create_tc_predicate.
+Elpi Accumulate lp:{{
+ main [indt-decl D] :-
+ attributes A,
+ coq.say A,
+ Opts =>
+ get-option "modes" [tt,ff,tt],
+ coq.env.add-indt D I,
+ coq.say I.
+}}.
+Elpi Typecheck.
+Elpi Export TC.declare.
+
+#[mode(i,i,o)] TC.declare
+ Class foo (A : Type) .
+*)
diff --git a/coq-builtin.elpi b/coq-builtin.elpi
index f0fd40a23..9787d4f50 100644
--- a/coq-builtin.elpi
+++ b/coq-builtin.elpi
@@ -1125,9 +1125,18 @@ external pred coq.CS.db-for i:gref, i:cs-pattern, o:list cs-instance.
% [coq.TC.declare-class GR] Declare GR as a type class
external pred coq.TC.declare-class i:gref.
+% [coq.elpi.toposort Graph Nodes in toposort order] takes a graph and
+% returns the nodes in topological order
+external pred coq.elpi.toposort i:list (pair A (list A)), o:list A.
+
+% Type class instance priority
+kind tc-priority type.
+type tc-priority-given int -> tc-priority. % User given priority
+type tc-priority-computed int -> tc-priority. % Coq computed priority
+
% Type class instance with priority
kind tc-instance type.
-type tc-instance gref -> int -> tc-instance.
+type tc-instance gref -> tc-priority -> tc-instance.
% [coq.TC.declare-instance GR Priority] Declare GR as a Global type class
% instance with Priority.
@@ -1141,7 +1150,8 @@ external pred coq.TC.db o:list tc-instance.
% [coq.TC.db-tc TypeClasses] reads all type classes
external pred coq.TC.db-tc o:list gref.
-% [coq.TC.db-for GR Db] reads all instances of the given class GR
+% [coq.TC.db-for GR InstanceList] reads all instances of the given class GR.
+% Instances are in their precedence order.
external pred coq.TC.db-for i:gref, o:list tc-instance.
% [coq.TC.class? GR] checks if GR is a class
diff --git a/src/coq_elpi_builtins.ml b/src/coq_elpi_builtins.ml
index 28a45a10b..d09bb7931 100644
--- a/src/coq_elpi_builtins.ml
+++ b/src/coq_elpi_builtins.ml
@@ -442,17 +442,95 @@ let cs_instance = let open Conv in let open API.AlgebraicData in let open Struct
]
} |> CConv.(!<)
-let tc_instance = let open Conv in let open API.AlgebraicData in let open Typeclasses in declare {
+
+type tc_priority = Computed of int | UserGiven of int
+
+let tc_priority = let open Conv in let open API.AlgebraicData in declare {
+ ty = TyName "tc-priority";
+ doc = "Type class instance priority";
+ pp = (fun fmt _ -> Format.fprintf fmt "");
+ constructors = [
+ K("tc-priority-given","User given priority",A(int,N),
+ B (fun i -> UserGiven i),
+ M (fun ~ok ~ko -> function UserGiven i -> ok i | _ -> ko ()));
+ K("tc-priority-computed","Coq computed priority", A(int,N),
+ B (fun i -> Computed i),
+ M (fun ~ok ~ko -> function Computed i -> ok i | _ -> ko ()));
+]} |> CConv.(!<)
+
+type type_class_instance = {
+ implementation : GlobRef.t;
+ priority : tc_priority;
+}
+
+let tc_instance = let open Conv in let open API.AlgebraicData in declare {
ty = TyName "tc-instance";
doc = "Type class instance with priority";
pp = (fun fmt _ -> Format.fprintf fmt "");
constructors = [
- K("tc-instance","",A(gref,A(int,N)),
- B (fun g p -> nYI "lp2instance"),
- M (fun ~ok ~ko i ->
- ok (instance_impl i) (Option.default 0 (hint_priority i))));
+ K("tc-instance","",A(gref,A(tc_priority,N)),
+ B (fun implementation priority -> { implementation; priority }),
+ M (fun ~ok ~ko { implementation; priority } -> ok implementation priority));
]} |> CConv.(!<)
+let get_instance_prio gr env sigma (info : 'a Typeclasses.hint_info_gen) : tc_priority =
+ match info.hint_priority with
+ | Some p -> UserGiven p
+ | None ->
+ let rec nb_hyp sigma c = match EConstr.kind sigma c with
+ | Prod(_,_,c2) -> if EConstr.Vars.noccurn sigma 1 c2 then 1+(nb_hyp sigma c2) else nb_hyp sigma c2
+ | _ -> 0 in
+ let merge_context_set_opt sigma ctx =
+ match ctx with
+ | None -> sigma
+ | Some ctx -> Evd.merge_context_set Evd.univ_flexible sigma ctx
+ in
+ let fresh_global_or_constr env sigma =
+ 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) in
+ let c, ctx = fresh_global_or_constr env sigma in
+ let cty = Retyping.get_type_of env sigma c in
+ let cty = Reductionops.nf_betaiota env sigma cty in
+ let sigma' = merge_context_set_opt sigma ctx in
+ let ce = Clenv.mk_clenv_from env sigma' (c,cty) in
+ let miss = Clenv.clenv_missing ce in
+ let nmiss = List.length miss in
+ let hyps = nb_hyp sigma' cty in
+ Computed (hyps + nmiss)
+
+let get_instances (env: Environ.env) (emap: Evd.evar_map) tc : type_class_instance list =
+ let hint_db = Hints.searchtable_map "typeclass_instances" in
+ let secvars : Names.Id.Pred.t = Names.Id.Pred.full in
+ let full_hints = Hints.Hint_db.map_all ~secvars:secvars tc hint_db in
+ let hint_asts = List.map Hints.FullHint.repr full_hints in
+ let hints = List.filter_map (function
+ | Hints.Res_pf a -> Some a
+ | ERes_pf a -> Some a
+ | Extern (a, b) -> None
+ | Give_exact a -> Some a
+ | Res_pf_THEN_trivial_fail e -> Some e
+ | Unfold_nth e -> None) hint_asts in
+ let sigma, _ =
+ let env = Global.env () in Evd.(from_env env, env) in
+ let constrs = List.map (fun a -> Hints.hint_as_term a |> snd) hints in
+ (* Printer.pr_global tc |> Pp.string_of_ppcmds |> Printf.printf "%s\n"; *)
+ let instances_grefs = List.filter_map (fun e ->
+ match EConstr.kind sigma e with
+ | Constr.Ind (a, _) -> Some (Names.GlobRef.IndRef a)
+ | Constr.Const (a, _) -> Some (Names.GlobRef.ConstRef a)
+ | Constr.Construct (a, _) -> Some (Names.GlobRef.ConstructRef a)
+ | _ -> None) constrs in
+ let inst_of_tc =
+ Typeclasses.instances_exn env emap tc |>
+ List.fold_left (fun m i -> GlobRef.Map.add i.Typeclasses.is_impl i m) GlobRef.Map.empty in
+ let instances_grefs2istance x =
+ let open Typeclasses in
+ let inst = GlobRef.Map.find x inst_of_tc in
+ let priority = get_instance_prio x env sigma inst.is_info in
+ { implementation = x; priority } in
+ List.map instances_grefs2istance instances_grefs
+
type scope = ExecutionSite | CurrentModule | Library
let scope = let open Conv in let open API.AlgebraicData in declare {
@@ -1235,8 +1313,6 @@ let eta_contract env sigma t =
map env t
-
-
(*****************************************************************************)
(*****************************************************************************)
(*****************************************************************************)
@@ -2688,6 +2764,18 @@ Supported attributes:
state, (), []))),
DocAbove);
+ MLCode(Pred("coq.elpi.toposort",
+ In(B.list (pair (B.poly "A") (B.list (B.poly "A"))), "Graph",
+ Out(B.list (B.poly "A"), "Nodes in toposort order",
+ Read(global,"takes a graph and returns the nodes in topological order"))),
+ (fun graph _ ~depth { options } _ _ ->
+ let graph = Coq_elpi_graph.Graph.build graph in
+ let topo_sort = Coq_elpi_graph.Graph.topo_sort graph in
+ (* Coq_elpi_graph.Graph.print string_of_int graph; *)
+ !: topo_sort)),
+ DocAbove);
+
+ MLData tc_priority;
MLData tc_instance;
MLCode(Pred("coq.TC.declare-instance",
@@ -2706,8 +2794,12 @@ Supported attributes:
MLCode(Pred("coq.TC.db",
Out(list tc_instance, "Instances",
- Easy "reads all type class instances"),
- (fun _ ~depth -> !: (Typeclasses.all_instances ()))),
+ Read(global, "reads all type class instances")),
+ (fun _ ~depth { env } _ state ->
+ let sigma = get_sigma state in
+ let x = Typeclasses.typeclasses () in
+ let classes = List.map (fun x -> x.Typeclasses.cl_impl) x in
+ !: (classes |> List.map (get_instances env sigma) |> List.concat))),
DocAbove);
MLCode(Pred("coq.TC.db-tc",
@@ -2719,12 +2811,11 @@ Supported attributes:
l))),
DocAbove);
- MLCode(Pred("coq.TC.db-for",
+ MLCode(Pred("coq.TC.db-for",
In(gref, "GR",
- Out(list tc_instance, "Db",
- Read(global,"reads all instances of the given class GR"))),
- (fun gr _ ~depth { env } _ state ->
- !: (Typeclasses.instances_exn env (get_sigma state) gr))),
+ Out(list tc_instance, "InstanceList",
+ Read (global, "reads all instances of the given class GR. Instances are in their precedence order."))),
+ (fun gr _ ~depth { env } _ state -> !: (get_instances env (get_sigma state) gr))),
DocAbove);
MLCode(Pred("coq.TC.class?",
diff --git a/src/coq_elpi_graph.ml b/src/coq_elpi_graph.ml
new file mode 100644
index 000000000..8ce0b0270
--- /dev/null
+++ b/src/coq_elpi_graph.ml
@@ -0,0 +1,97 @@
+module Node = struct
+ type 'a t = {
+ mutable pred : 'a t list;
+ name : 'a;
+ mutable succ : 'a t list;
+ }
+
+ let init name = { pred = []; name; succ = [] }
+
+ let remove_succ rem_node n =
+ n.succ <- List.filter (fun succ -> succ.name <> rem_node.name) n.succ
+
+ let add_succ current succ =
+ current.succ <- succ :: current.succ;
+ succ.pred <- current :: succ.pred
+
+ let remove_pred rem_node n =
+ n.pred <- List.filter (fun pred -> pred.name <> rem_node.name) n.pred
+
+ let clear node = node.pred <- []; node.succ <- []
+
+ let remove current =
+ List.iter (fun succ -> remove_pred current succ) current.succ;
+ List.iter (fun pred -> remove_succ current pred) current.pred;
+ clear current
+
+ let print pf n =
+ let pf e = Printf.sprintf "%s " (pf e.name) in
+ let pf_fold e = List.fold_left (fun acc e -> Printf.sprintf "%s%s, " acc (pf e)) "" e in
+ Printf.printf "%s : [ succ: %s ;; pred : %s ]\n%!"
+ (pf n) (pf_fold n.succ) (pf_fold n.pred);
+end
+
+module Graph = struct
+
+ type 'a graph = { nodes : ('a, 'a Node.t) Hashtbl.t }
+
+ exception Invalid_graph of string
+
+ let rec queue_to_list q =
+ if Queue.is_empty q then []
+ else
+ let elt = Queue.pop q in
+ elt :: queue_to_list q
+
+ let add_node graph node_name =
+ if Hashtbl.mem graph.nodes node_name then
+ raise (Invalid_graph "The nodes of the graph should be unique")
+ else
+ let node = Node.init node_name in
+ Hashtbl.add graph.nodes node_name node;
+ node
+
+ (*
+ We can build the graph from a list of type (A, B) : ('a * 'a list)
+ where A is a node and B is the list of its successors
+ *)
+ let build l : 'a graph =
+ let graph = { nodes = Hashtbl.create (List.length l) } in
+ List.iter (fun (node, _) -> add_node graph node |> ignore) l;
+ List.iter
+ (fun (current_name, succ_names) ->
+ let current = Hashtbl.find graph.nodes current_name in
+ List.iter
+ (fun succ_name ->
+ let succ =
+ try Hashtbl.find graph.nodes succ_name
+ with Not_found -> add_node graph succ_name in
+ Node.add_succ current succ
+ )
+ succ_names)
+ l;
+ graph
+
+ let topo_sort graph : 'a list =
+ let res = Queue.create () in
+ let to_treat = Queue.create () in
+ Hashtbl.iter
+ (fun _ (n: 'a Node.t) -> if List.length n.pred = 0 then Queue.add n to_treat)
+ graph.nodes;
+ while Queue.is_empty to_treat |> not do
+ let current_node = Queue.pop to_treat in
+ Queue.push current_node.name res;
+ let succ = current_node.succ in
+ Node.remove current_node;
+ List.iter
+ (fun (succ: 'a Node.t) -> if List.length succ.pred = 0 then Queue.push succ to_treat)
+ succ
+ done;
+ if Queue.length res <> Hashtbl.length graph.nodes then
+ raise (Invalid_graph "Cannot do topological sort on cyclic graph")
+ else queue_to_list res
+
+ let print pf g =
+ Hashtbl.iter (fun _ n -> Node.print pf n)
+ g.nodes
+end
\ No newline at end of file
diff --git a/src/coq_elpi_graph.mli b/src/coq_elpi_graph.mli
new file mode 100644
index 000000000..98c265aed
--- /dev/null
+++ b/src/coq_elpi_graph.mli
@@ -0,0 +1,8 @@
+module Graph :
+ sig
+ type 'a graph
+ exception Invalid_graph of string
+ val build : ('a * 'a list) list -> 'a graph
+ val topo_sort : 'a graph -> 'a list
+ val print : ('a -> string) -> 'a graph -> unit
+ end
diff --git a/src/elpi_plugin.mlpack b/src/elpi_plugin.mlpack
index 03435ace6..7c8692070 100644
--- a/src/elpi_plugin.mlpack
+++ b/src/elpi_plugin.mlpack
@@ -1,5 +1,6 @@
Coq_elpi_config
Coq_elpi_utils
+Coq_elpi_graph
Coq_elpi_HOAS
Coq_elpi_glob_quotation
Coq_elpi_name_quotation
diff --git a/tests/test_toposort.v b/tests/test_toposort.v
new file mode 100644
index 000000000..d983fedb3
--- /dev/null
+++ b/tests/test_toposort.v
@@ -0,0 +1,8 @@
+From elpi Require Import elpi.
+
+Elpi Command GraphToposort.
+
+Elpi Query lp:{{
+ coq.elpi.toposort [pr "a" ["b"], pr "c" ["a"]] ["c", "a", "b"],
+ coq.elpi.toposort [pr 1 [2], pr 3 [1]] [3, 1, 2].
+}}.