From 1b585bc9577b61eb0398ec4bdaf8c61e38a3adf7 Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Tue, 10 Mar 2026 19:49:10 +0100 Subject: [PATCH 01/62] fix bug in term decompilation --- apps/tc/elpi/ho_compile.elpi | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/apps/tc/elpi/ho_compile.elpi b/apps/tc/elpi/ho_compile.elpi index 00b02f9c8..11091275a 100644 --- a/apps/tc/elpi/ho_compile.elpi +++ b/apps/tc/elpi/ho_compile.elpi @@ -62,13 +62,13 @@ namespace tc { decompile-term-aux (fun Name Ty Bo) (pr XS L) (fun Name Ty' Bo') (pr XS2 L3) :- !, (pi x\ is-name x => decompile-term-aux (Bo x) (pr XS []) (Bo' x) (pr XS1 (L1x x))), - close-term-no-prune-ty L1x Ty L1, + close-term-no-prune-ty L1x {clean-term Ty} L1, decompile-term-aux Ty (pr XS1 L) Ty' (pr XS2 L2), std.append L1 L2 L3. decompile-term-aux (prod Name Ty Bo) (pr XS L) (prod Name Ty' Bo') (pr XS2 L3) :- !, (pi x\ is-name x => decompile-term-aux (Bo x) (pr XS []) (Bo' x) (pr XS1 (L1x x))), - close-term-no-prune-ty L1x Ty L1, + close-term-no-prune-ty L1x {clean-term Ty} L1, decompile-term-aux Ty (pr XS1 L) Ty' (pr XS2 L2), std.append L1 L2 L3. From 9dd46c2aafe99576f453287b4f00dc476fcebd6b Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Wed, 11 Mar 2026 15:28:09 +0100 Subject: [PATCH 02/62] class mode attribute --- apps/tc/tests/test_pending_mode.v | 38 ++++--------------------------- 1 file changed, 5 insertions(+), 33 deletions(-) diff --git a/apps/tc/tests/test_pending_mode.v b/apps/tc/tests/test_pending_mode.v index 623f5b143..053e57191 100644 --- a/apps/tc/tests/test_pending_mode.v +++ b/apps/tc/tests/test_pending_mode.v @@ -2,23 +2,10 @@ From elpi Require Import tc. Elpi Accumulate TC.Compiler lp:{{ :before "0" - tc.add-class-gr _ A SM :- + tc.add-class-gr _ A :- coq.say "Adding predicate for" A, - coq.say "with mode" SM, fail, !. - - func old-version string, int, int, int ->. - old-version _ 9 0 _. - old-version _ 9 1 _. - old-version _ 9 2 _. - - pred get-old-mode o:string. - - :after "0" - main [str "new_class", str Cl, str _] :- old-version {coq.version}, get-old-mode Modes, not (var Modes), !, - tc.time-it tc.oTC-time-compile-class ( - coq.locate Cl GR, tc.add-class-gr tc.classic GR {rex.split " " Modes} - ) "Compiler for Class". - + coq.hints.modes A "typeclass_instances" C, + coq.say "with mode" C, fail, !. }}. Module ES3. @@ -37,23 +24,8 @@ Proof. eexists; now apply _. Qed. End ES3. -Module ES3'. - -#[mode = "-"]Class Add (I: nat). - -Instance addNat: Add 0. Qed. - -(* No problem in apply _ since the evar can be unified with the pattern 0 *) -Goal exists x, (Add x). -Proof. eexists; now apply _. Qed. - -End ES3'. - Module ES4. -Section S. -Elpi Accumulate TC.Compiler lp:{{ - get-old-mode "+". -}}. + (* Plus is mapped to the elpi input mode, i.e. the type of the predicate for add is `pred term -> term`. *) @@ -64,7 +36,7 @@ Instance addNat: Add 0. Qed. (* Failure in apply _ since the evar does not match the pattern 0 *) Goal exists x, (Add x). Proof. eexists. Fail apply _. Abort. -End S. + End ES4. From 7b903cba4f188a4a0b18999116a552049228c893 Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Wed, 11 Mar 2026 15:28:09 +0100 Subject: [PATCH 03/62] class mode attribute --- apps/tc/src/rocq_elpi_tc_register.ml | 17 +++++++++++++++-- apps/tc/tests/test_pending_mode.v | 5 ++--- 2 files changed, 17 insertions(+), 5 deletions(-) diff --git a/apps/tc/src/rocq_elpi_tc_register.ml b/apps/tc/src/rocq_elpi_tc_register.ml index 07764aeab..8143b1467 100644 --- a/apps/tc/src/rocq_elpi_tc_register.ml +++ b/apps/tc/src/rocq_elpi_tc_register.ml @@ -16,6 +16,14 @@ let gref2elpi_term (gref: GlobRef.t) : Cmd.raw = Cmd.String (gref_2_string gref) +let mode2str = function + | None | Some [] -> "" + | Some (x::xs) -> + let pp_mode = Hints.string_of_mode in + List.fold_left (fun acc e -> acc ^ " " ^ pp_mode e) (pp_mode x) xs + + + let mode2str = function | None | Some [] -> "" | Some (x::xs) -> @@ -26,6 +34,8 @@ let mode2str = function (* Returns the elpi term representing the type class received in argument *) let observer_class m (x : Typeclasses.typeclass) : Rocq_elpi_arg_HOAS.Cmd.raw list = [Cmd.String "new_class"; gref2elpi_term x.cl_impl; Cmd.String (mode2str m)] +let observer_class m (x : Typeclasses.typeclass) : Rocq_elpi_arg_HOAS.Cmd.raw list = + [Cmd.String "new_class"; gref2elpi_term x.cl_impl; Cmd.String (mode2str m)] let observer_default_instance (x : Typeclasses.typeclass) : Rocq_elpi_arg_HOAS.Cmd.raw list = [Cmd.String "default_instance";gref2elpi_term x.cl_impl] @@ -62,10 +72,12 @@ let observer_instance ({locality; instance; info; class_name} : instance) : Rocq prio2elpi_int info ] +let class_runner f m cl = let class_runner f m cl = let actions = [ observer_coercion false; observer_class m; + observer_class m; observer_coercion true; (* observer_default_instance *) ] in @@ -74,6 +86,7 @@ let class_runner f m cl = let observer_class = Libobject.declare_object @@ Libobject.local_object "TC_HACK_OBSERVER_CLASSES" + ~cache:(fun (run,m,cl) -> class_runner run m cl) ~cache:(fun (run,m,cl) -> class_runner run m cl) ~discharge:(fun x -> Some x) @@ -93,8 +106,8 @@ let observer_evt ((loc, name, atts) : loc_name_atts) (x : Event.t) = let open Rocq_elpi_vernacular in let run_program e = Interp.run_program ~loc name ~syndata:None ~atts e in match x with - | Event.NewClass cl -> Lib.add_leaf (observer_class_disp run_program cl) - | Event.NewInstance inst -> Lib.add_leaf (observer_instance (run_program,inst)) + | Event.NewClass (omode, cl) -> Lib.add_leaf (inObservation (run_program,omode,cl)) + | Event.NewInstance inst -> Lib.add_leaf (inObservation1 (run_program,inst)) module StringMap = Map.Make(String) diff --git a/apps/tc/tests/test_pending_mode.v b/apps/tc/tests/test_pending_mode.v index 053e57191..494e031be 100644 --- a/apps/tc/tests/test_pending_mode.v +++ b/apps/tc/tests/test_pending_mode.v @@ -2,10 +2,9 @@ From elpi Require Import tc. Elpi Accumulate TC.Compiler lp:{{ :before "0" - tc.add-class-gr _ A :- + tc.add-class-gr _ A SM :- coq.say "Adding predicate for" A, - coq.hints.modes A "typeclass_instances" C, - coq.say "with mode" C, fail, !. + coq.say "with mode" SM, fail, !. }}. Module ES3. From 8eebf5e615b9a61458ec359998749660c9e3a2ce Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Thu, 12 Mar 2026 15:08:03 +0100 Subject: [PATCH 04/62] add comment to ho_compile --- apps/tc/elpi/ho_compile.elpi | 38 ++++++++++++++++++------------------ 1 file changed, 19 insertions(+), 19 deletions(-) diff --git a/apps/tc/elpi/ho_compile.elpi b/apps/tc/elpi/ho_compile.elpi index 11091275a..d2d94ffc3 100644 --- a/apps/tc/elpi/ho_compile.elpi +++ b/apps/tc/elpi/ho_compile.elpi @@ -211,16 +211,16 @@ namespace tc { :functional pred compile-premise - i:list term, - o:list term, - i:term, - i:term, - i:term, - i:bool, - i:term, - i:list term, - i:list prop, - o:prop. + i:list term, % L : a list of pi-quantified variables (used as elpi unification variables when building links) + o:list term, % L' : a suffix of L containing the still unused variables + i:term, % P : the premise of an instance whose applicative head is a class + i:term, % Pt : the type of P + i:term, % I : the instance at toplevel that triggered the instance compilation + i:bool, % B : tells if the premise P is in positive or negative position + i:term, % It : the type of I that has not yet been explored + i:list term, % Ag : the arguments of I that will be part of the proof + i:list prop, % Pr : the premises of the rule + o:prop. % C : the final clause corresponding to the compilation of I compile-premise L L2 P PTy ProofHd IsPositive ITy ProofTlR PremR Clause :- ((pi a b c\ tc.get-TC-of-inst-type (tc.prod-range a c) b :- !, tc.get-TC-of-inst-type a b) => tc.get-TC-of-inst-type PTy TC), !, @@ -233,15 +233,15 @@ namespace tc { compile-ty L L1 ProofHd IsPositive ITy ProofTlR PremR Clause. :index (_ _ _ _ 1) - func compile-ty - list term, - list term, - term, - bool, - term, - list term, - list prop - -> prop. + func compile-ty + list term, % L : a list of pi-quantified variables (used as elpi unification variables when building links) + list term, % L' : a suffix of L containing the still unused variables + term, % I : the premise of an instance whose applicative head is a class + bool, % B : tells if the premise P is in positive or negative position + term, % It : the type of I that has not yet been explored + list term, % Ag : the arguments of I that will be part of the proof + list prop % Pr : the premises of the rule + -> prop. % C : the final clause corresponding to the compilation of I compile-ty L L1 ProofHd IsPositive (tc.prod-range (prod N Ty Bo) Arity) ProofTlR PremR Clause :- !, std.do![ if (IsPositive = tt) From d3c7645cfe1f1dcfc0a875e2819e9f87d2a487c0 Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Thu, 19 Mar 2026 17:05:48 +0100 Subject: [PATCH 05/62] fix bench.py --- apps/tc/tests-stdlib/bench/bench_inj.py | 60 ++++++++++++++++++------- 1 file changed, 45 insertions(+), 15 deletions(-) diff --git a/apps/tc/tests-stdlib/bench/bench_inj.py b/apps/tc/tests-stdlib/bench/bench_inj.py index 9a44376ab..fcb90ee33 100644 --- a/apps/tc/tests-stdlib/bench/bench_inj.py +++ b/apps/tc/tests-stdlib/bench/bench_inj.py @@ -3,6 +3,7 @@ import sys import os import re +import random """ About this file: @@ -45,28 +46,41 @@ def findFloats(s): def filterLines(lines): #print(lines) - validStarts = ["Finished", "Refine", "Elpi:", "Instance search", "Time build query"] + validStarts = ["Finished", "refine", "Elpi: query-compilation", "Time of instance search", "Time of build query"] + r = {} for line in lines.split("\n"): for start in validStarts: if start in line: - yield line - + fl = findFloats(line) + if start in r: + r[start] = [r[start], fl] + else: + r[start] = fl + continue + return r def parseFile(s): - lines = [findFloats(x) for x in filterLines(s)] + with open("xxx.txt", "w") as f: + f.write(s) + lines = filterLines(s) #print(lines) - base = 0 - coqT = lines[base][0] - buildQuery = lines[base + 1][0] - tcSearch = lines[base + 2][0] - refineT = lines[base + 3][0] - elpiStats = lines[base + 4] + with open("www.txt", "w") as f: + f.write(str(lines)) + + # base = 0 + coqT = lines["Finished"][0][0] + elpiT = lines["Finished"][1][0] + buildQuery = lines["Time of build query"][0] + tcSearch = lines["Time of instance search"][0] + refineT = lines["refine"][0] + elpiStats = lines["Elpi: query-compilation"] compilT, runtimeT = elpiStats[0], elpiStats[-1] - elpiT = lines[base + 5][0] res = buildDict() for key in KEYS: res[key].append(eval(key)) #print(res) + with open("zzz.txt", "w") as f: + f.write(str(res)) return res @@ -87,10 +101,23 @@ def buildTree(len): }}. """ +refine_no_check = """ +Elpi Accumulate TC.Solver lp:{{ + :after "0" + tc.refine-proof Proof G GL :- !, + + /*********** CHECK IF THE PROOF TYPECHECKS ***********/ + tc.time-it tc.oTC-time-refine (@no-tc! => refine.no_check Proof G GL) "refine.typecheck", + + if-true tc.print-solution (coq.say "[TC] The proof typechecks"). +}}. +""" + def writeFile(fileName: str, composeLen: int, isCoq: bool): - PREAMBLE = f"""\ + PREAMBLE = f""" +(* {random.random()} *) From elpi_apps_tc_tests_stdlib Require Import {"stdppInjClassic" if isCoq else "stdppInj"}. -{"" if isCoq else 'Elpi TC.Solver. Set TC Time Refine. Set TC Time Instance Search. Set TC Time Build Query. Set Debug "elpitime".'} +{"" if isCoq else (refine_no_check + 'Elpi TC.Solver. Set TC Time Refine. Set TC Time Instance Search. Set TC Time Compile Query. Set Debug "elpitime".')} """ GOAL = buildTree(composeLen) with open(fileName + ".v", "w") as fd: @@ -102,7 +129,10 @@ def runCoqMake(fileName): fileName = fileName + ".vo" if (os.path.exists(file_name)): subprocess.run(["rm", fileName]) - return subprocess.check_output(["make", fileName]).decode() + r = subprocess.run(["dune" , "build", fileName], capture_output=True, text=True) + out = r.stdout + err = r.stderr + return f"{out}\n---\n f{err}" def run(file_name, height): @@ -126,7 +156,7 @@ def loopTreeDepth(file_name: str, maxHeight: int, makeCoq=True, onlyOne=False): if __name__ == "__main__": print(os.curdir) - file_name = "tests/bench/bench_inj" + file_name = "tests-stdlib/bench/bench_inj" height = int(sys.argv[1]) loopTreeDepth(file_name, height, makeCoq=not ( "-nocoq" in sys.argv), onlyOne=("-onlyOne" in sys.argv)) From 8016d0edd1a90e01eb256879b13eb0ce9a3d90eb Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Mon, 23 Mar 2026 10:32:50 +0100 Subject: [PATCH 06/62] bench all --- apps/tc/tests-stdlib/bench/bench_inj.py | 102 ++++++++++++------------ 1 file changed, 51 insertions(+), 51 deletions(-) diff --git a/apps/tc/tests-stdlib/bench/bench_inj.py b/apps/tc/tests-stdlib/bench/bench_inj.py index fcb90ee33..5a92f0611 100644 --- a/apps/tc/tests-stdlib/bench/bench_inj.py +++ b/apps/tc/tests-stdlib/bench/bench_inj.py @@ -20,23 +20,32 @@ """ INJ_BASE_FUN = "f" -KEYS = "coqT, elpiT, tcSearch, refineT, compilT, runtimeT, buildQuery".split(", ") +TOT_COQ_TIME = "coqT" +TOT_ELPI_TIME = "elpiT" +TOT_NORMALIZE = "normalize" +TOT_COMPILE_CTX = "compile context" +TOT_BUILD_QUERY = "build query" +TOT_INSTANCE_SEARCH = "instance search" +TOT_FULL_INSTANCE_SEARCH = "full instance search" +TOT_REFINE = "refine" +MSOLVE = "msolve" -def buildDict(): - res = dict() - for key in KEYS: - res[key] = [] - return res +COMPILT = "compilT" +RUNTIMET = "runtimeT" + +KEYL = [TOT_COQ_TIME, TOT_ELPI_TIME, TOT_NORMALIZE, TOT_COMPILE_CTX, TOT_BUILD_QUERY, TOT_INSTANCE_SEARCH, TOT_FULL_INSTANCE_SEARCH, TOT_REFINE, MSOLVE, COMPILT, RUNTIMET] +HEADER = re.sub(r'\s+', ' ', "Height, Coq, Elpi, normalize, ctx, BuildQuery, TC search, TC Search Full, Refine, msolve, ElpiCompil, ElpiRuntime, Ratio(Coq/Elpi), Ratio(Elpi/Coq)") def printDict(d): - for key in KEYS: - d[key] = sum(d[key])/len(d[key]) - L = [d[k] for k in KEYS] - L.append(d["elpiT"] - d["refineT"] - d["buildQuery"]) - L.append(d["coqT"] / d["elpiT"]) - L.append(d["elpiT"] / d["coqT"] if d["coqT"] > 0 else 100) + # for key in KEYS: + # d[key] = sum(d[key])/len(d[key]) + # L = [d[k] for k in KEYS] + L = [] + for k in KEYL: L.append(d[k]) + L.append(d[TOT_COQ_TIME] / d[TOT_ELPI_TIME]) + L.append(d[TOT_ELPI_TIME] / d[TOT_COQ_TIME] if d[TOT_COQ_TIME] > 0 else 100) print(", ".join(map(lambda x: str(round(x, 5)), L))) @@ -45,44 +54,32 @@ def findFloats(s): def filterLines(lines): - #print(lines) - validStarts = ["Finished", "refine", "Elpi: query-compilation", "Time of instance search", "Time of build query"] + with open("xxx.txt", "w") as f: + f.write(lines) + DEBUG_STR = "Debug: [TC] - Time of " r = {} for line in lines.split("\n"): - for start in validStarts: - if start in line: - fl = findFloats(line) - if start in r: - r[start] = [r[start], fl] - else: - r[start] = fl - continue - return r - -def parseFile(s): - with open("xxx.txt", "w") as f: - f.write(s) - lines = filterLines(s) - #print(lines) - with open("www.txt", "w") as f: - f.write(str(lines)) - - # base = 0 - coqT = lines["Finished"][0][0] - elpiT = lines["Finished"][1][0] - buildQuery = lines["Time of build query"][0] - tcSearch = lines["Time of instance search"][0] - refineT = lines["refine"][0] - elpiStats = lines["Elpi: query-compilation"] - compilT, runtimeT = elpiStats[0], elpiStats[-1] - res = buildDict() - for key in KEYS: - res[key].append(eval(key)) - #print(res) + fl = findFloats(line) + if line.startswith("Finished transaction"): + if TOT_COQ_TIME in r: r[TOT_ELPI_TIME] = fl[0] + else: r[TOT_COQ_TIME] = fl[0] + elif line.strip().startswith("Elpi: query-compilation"): + r[COMPILT] = fl[0] + r[RUNTIMET] = fl[-1] + elif line.startswith(DEBUG_STR): + def check_(n): return line.startswith(DEBUG_STR + n) + def set_(n): r[n] = fl[0] + if check_(TOT_NORMALIZE): set_(TOT_NORMALIZE) + elif check_(TOT_COMPILE_CTX): set_(TOT_COMPILE_CTX) + elif check_(TOT_BUILD_QUERY): set_(TOT_BUILD_QUERY) + elif check_(TOT_INSTANCE_SEARCH): set_(TOT_INSTANCE_SEARCH) + elif check_(TOT_FULL_INSTANCE_SEARCH): set_(TOT_FULL_INSTANCE_SEARCH) + elif check_(TOT_REFINE): set_(TOT_REFINE) + elif check_(MSOLVE): set_(MSOLVE) + else: raise "Not found" + line with open("zzz.txt", "w") as f: - f.write(str(res)) - return res - + f.write(str(r)) + return r def buildTree(len): if len == 0: @@ -111,13 +108,13 @@ def buildTree(len): if-true tc.print-solution (coq.say "[TC] The proof typechecks"). }}. -""" +""" if True else "" def writeFile(fileName: str, composeLen: int, isCoq: bool): PREAMBLE = f""" (* {random.random()} *) From elpi_apps_tc_tests_stdlib Require Import {"stdppInjClassic" if isCoq else "stdppInj"}. -{"" if isCoq else (refine_no_check + 'Elpi TC.Solver. Set TC Time Refine. Set TC Time Instance Search. Set TC Time Compile Query. Set Debug "elpitime".')} +{"" if isCoq else (refine_no_check + 'Elpi TC.Solver. Set Time TC Bench. Set Debug "elpitime".')} """ GOAL = buildTree(composeLen) with open(fileName + ".v", "w") as fd: @@ -142,15 +139,18 @@ def partialFun(isCoq: bool): return partialFun +# def plot_dict(d): +# L = + def loopTreeDepth(file_name: str, maxHeight: int, makeCoq=True, onlyOne=False): - print("Height, Coq, Elpi, TC search, Refine, ElpiCompil, ElpiRuntime, BuildQuery, ElpiNoRefine, Ratio(Coq/Elpi), Ratio(Elpi/Coq)") + print(HEADER) for i in range(1 if not onlyOne else maxHeight, maxHeight+1): FUN = run(file_name, i) x = FUN(True) if makeCoq else "Finished 0.0" y = FUN(False) print(i, ", ", end="", sep="") # print("The xx result is " , x) - dic = parseFile(x + y) + dic = filterLines(x + y) printDict(dic) From 08597ba641a910a2bedf4de95fd1c493b779593f Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Mon, 23 Mar 2026 14:03:06 +0100 Subject: [PATCH 07/62] bench --- apps/tc/tests-stdlib/bench/bench_inj.py | 32 +++++++++++++++---------- 1 file changed, 20 insertions(+), 12 deletions(-) diff --git a/apps/tc/tests-stdlib/bench/bench_inj.py b/apps/tc/tests-stdlib/bench/bench_inj.py index 5a92f0611..3a0499383 100644 --- a/apps/tc/tests-stdlib/bench/bench_inj.py +++ b/apps/tc/tests-stdlib/bench/bench_inj.py @@ -35,7 +35,7 @@ RUNTIMET = "runtimeT" KEYL = [TOT_COQ_TIME, TOT_ELPI_TIME, TOT_NORMALIZE, TOT_COMPILE_CTX, TOT_BUILD_QUERY, TOT_INSTANCE_SEARCH, TOT_FULL_INSTANCE_SEARCH, TOT_REFINE, MSOLVE, COMPILT, RUNTIMET] -HEADER = re.sub(r'\s+', ' ', "Height, Coq, Elpi, normalize, ctx, BuildQuery, TC search, TC Search Full, Refine, msolve, ElpiCompil, ElpiRuntime, Ratio(Coq/Elpi), Ratio(Elpi/Coq)") +HEADER = re.sub(r'\s+', ' ', "Height, Coq, Elpi, normalize, ctx, BuildQuery, TC search, TC Search Full, Refine, msolve, ElpiCompil, ElpiRuntime, DIFF, Ratio(Coq/Elpi), Ratio(Elpi/Coq)") def printDict(d): @@ -44,6 +44,7 @@ def printDict(d): # L = [d[k] for k in KEYS] L = [] for k in KEYL: L.append(d[k]) + L.append(d[TOT_ELPI_TIME] / d[MSOLVE]) L.append(d[TOT_COQ_TIME] / d[TOT_ELPI_TIME]) L.append(d[TOT_ELPI_TIME] / d[TOT_COQ_TIME] if d[TOT_COQ_TIME] > 0 else 100) print(", ".join(map(lambda x: str(round(x, 5)), L))) @@ -108,19 +109,26 @@ def buildTree(len): if-true tc.print-solution (coq.say "[TC] The proof typechecks"). }}. -""" if True else "" +""" if False else "" def writeFile(fileName: str, composeLen: int, isCoq: bool): - PREAMBLE = f""" -(* {random.random()} *) -From elpi_apps_tc_tests_stdlib Require Import {"stdppInjClassic" if isCoq else "stdppInj"}. -{"" if isCoq else (refine_no_check + 'Elpi TC.Solver. Set Time TC Bench. Set Debug "elpitime".')} -""" + TXT = f"(* {random.random()} *)\n" GOAL = buildTree(composeLen) + if isCoq: + TXT += "From elpi_apps_tc_tests_stdlib Require Import stdppInjClassic.\n" + TXT += f"Goal Inj eq eq({GOAL}). Time apply _. Qed.\n" + else: + TXT += "From elpi_apps_tc_tests_stdlib Require Import stdppInj.\n" + TXT += refine_no_check # (Un)Comment this for using refine or refine.no_check + TXT += "Elpi TC.Solver.\n" + TXT += f"Goal Inj eq eq({GOAL}).\n" + # TXT += "Elpi Command time_it. Elpi Accumulate lp:{{ main _ :- coq.say {gettimeofday}. }}. Elpi time_it.\n" + TXT += 'Set Time TC Bench. Set Debug "elpitime".\n' + TXT += "Time apply _.\n" + # TXT += "Unset Time TC Bench. Set Debug \"-elpitime\". Elpi time_it.\n" + TXT += "Qed.\n" with open(fileName + ".v", "w") as fd: - fd.write(PREAMBLE) - fd.write(f"Goal Inj eq eq({GOAL}). Time apply _. Qed.\n") - + fd.write(TXT) def runCoqMake(fileName): fileName = fileName + ".vo" @@ -146,9 +154,9 @@ def loopTreeDepth(file_name: str, maxHeight: int, makeCoq=True, onlyOne=False): print(HEADER) for i in range(1 if not onlyOne else maxHeight, maxHeight+1): FUN = run(file_name, i) - x = FUN(True) if makeCoq else "Finished 0.0" + x = FUN(True) if makeCoq else "Finished transaction in 0.0" y = FUN(False) - print(i, ", ", end="", sep="") + print(2**i, ", ", end="", sep="") # print("The xx result is " , x) dic = filterLines(x + y) printDict(dic) From b46f2026546580a5832de5e43b864fad2f3793bd Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Mon, 23 Mar 2026 14:40:41 +0100 Subject: [PATCH 08/62] plot elpi stats --- apps/tc/tests-stdlib/bench/bench_inj.py | 30 ++++++++++++++++++++----- 1 file changed, 24 insertions(+), 6 deletions(-) diff --git a/apps/tc/tests-stdlib/bench/bench_inj.py b/apps/tc/tests-stdlib/bench/bench_inj.py index 3a0499383..6ebf4cc32 100644 --- a/apps/tc/tests-stdlib/bench/bench_inj.py +++ b/apps/tc/tests-stdlib/bench/bench_inj.py @@ -44,7 +44,7 @@ def printDict(d): # L = [d[k] for k in KEYS] L = [] for k in KEYL: L.append(d[k]) - L.append(d[TOT_ELPI_TIME] / d[MSOLVE]) + L.append(d[TOT_ELPI_TIME] - d[MSOLVE]) L.append(d[TOT_COQ_TIME] / d[TOT_ELPI_TIME]) L.append(d[TOT_ELPI_TIME] / d[TOT_COQ_TIME] if d[TOT_COQ_TIME] > 0 else 100) print(", ".join(map(lambda x: str(round(x, 5)), L))) @@ -132,7 +132,7 @@ def writeFile(fileName: str, composeLen: int, isCoq: bool): def runCoqMake(fileName): fileName = fileName + ".vo" - if (os.path.exists(file_name)): + if (os.path.exists(fileName)): subprocess.run(["rm", fileName]) r = subprocess.run(["dune" , "build", fileName], capture_output=True, text=True) out = r.stdout @@ -147,10 +147,22 @@ def partialFun(isCoq: bool): return partialFun -# def plot_dict(d): -# L = +def plot_dict(i, d): + L = [2**i, d[TOT_INSTANCE_SEARCH]] + L.append(L[-1] + d[TOT_INSTANCE_SEARCH] + d[TOT_BUILD_QUERY] + d[TOT_COMPILE_CTX] + d[TOT_NORMALIZE]) + L.append(L[-1] + d[TOT_REFINE]) + L.append(d[TOT_ELPI_TIME]) + L.append(d[TOT_COQ_TIME]) + return L + +def print_plot(pl): + l = "" + for i in pl: + l += ",".join(map(lambda x: str(round(x, 5)), i)) + "\n" + return l def loopTreeDepth(file_name: str, maxHeight: int, makeCoq=True, onlyOne=False): + plot = [] print(HEADER) for i in range(1 if not onlyOne else maxHeight, maxHeight+1): FUN = run(file_name, i) @@ -159,13 +171,19 @@ def loopTreeDepth(file_name: str, maxHeight: int, makeCoq=True, onlyOne=False): print(2**i, ", ", end="", sep="") # print("The xx result is " , x) dic = filterLines(x + y) + plot.append(plot_dict(i, dic)) printDict(dic) - + return plot if __name__ == "__main__": print(os.curdir) file_name = "tests-stdlib/bench/bench_inj" height = int(sys.argv[1]) - loopTreeDepth(file_name, height, makeCoq=not ( + pl = loopTreeDepth(file_name, height, makeCoq=not ( "-nocoq" in sys.argv), onlyOne=("-onlyOne" in sys.argv)) + + print("\n\n ELPI STATS") + print("HEIGHT, TC, BUILD, REFINE, COQ") + + print(print_plot((pl))) #writeFile(file_name, 1, False) From d247bac2d472319111b78d049c33f098934aa262 Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Mon, 8 Jun 2026 09:50:35 +0200 Subject: [PATCH 09/62] fix rebase --- apps/tc/src/rocq_elpi_tc_register.ml | 19 +++------------ apps/tc/tests/test_pending_mode.v | 35 +++++++++++++++++++++++++--- 2 files changed, 35 insertions(+), 19 deletions(-) diff --git a/apps/tc/src/rocq_elpi_tc_register.ml b/apps/tc/src/rocq_elpi_tc_register.ml index 8143b1467..97f97fc88 100644 --- a/apps/tc/src/rocq_elpi_tc_register.ml +++ b/apps/tc/src/rocq_elpi_tc_register.ml @@ -16,14 +16,6 @@ let gref2elpi_term (gref: GlobRef.t) : Cmd.raw = Cmd.String (gref_2_string gref) -let mode2str = function - | None | Some [] -> "" - | Some (x::xs) -> - let pp_mode = Hints.string_of_mode in - List.fold_left (fun acc e -> acc ^ " " ^ pp_mode e) (pp_mode x) xs - - - let mode2str = function | None | Some [] -> "" | Some (x::xs) -> @@ -34,8 +26,6 @@ let mode2str = function (* Returns the elpi term representing the type class received in argument *) let observer_class m (x : Typeclasses.typeclass) : Rocq_elpi_arg_HOAS.Cmd.raw list = [Cmd.String "new_class"; gref2elpi_term x.cl_impl; Cmd.String (mode2str m)] -let observer_class m (x : Typeclasses.typeclass) : Rocq_elpi_arg_HOAS.Cmd.raw list = - [Cmd.String "new_class"; gref2elpi_term x.cl_impl; Cmd.String (mode2str m)] let observer_default_instance (x : Typeclasses.typeclass) : Rocq_elpi_arg_HOAS.Cmd.raw list = [Cmd.String "default_instance";gref2elpi_term x.cl_impl] @@ -72,12 +62,10 @@ let observer_instance ({locality; instance; info; class_name} : instance) : Rocq prio2elpi_int info ] -let class_runner f m cl = let class_runner f m cl = let actions = [ observer_coercion false; observer_class m; - observer_class m; observer_coercion true; (* observer_default_instance *) ] in @@ -86,7 +74,6 @@ let class_runner f m cl = let observer_class = Libobject.declare_object @@ Libobject.local_object "TC_HACK_OBSERVER_CLASSES" - ~cache:(fun (run,m,cl) -> class_runner run m cl) ~cache:(fun (run,m,cl) -> class_runner run m cl) ~discharge:(fun x -> Some x) @@ -106,8 +93,8 @@ let observer_evt ((loc, name, atts) : loc_name_atts) (x : Event.t) = let open Rocq_elpi_vernacular in let run_program e = Interp.run_program ~loc name ~syndata:None ~atts e in match x with - | Event.NewClass (omode, cl) -> Lib.add_leaf (inObservation (run_program,omode,cl)) - | Event.NewInstance inst -> Lib.add_leaf (inObservation1 (run_program,inst)) + | Event.NewClass cl -> Lib.add_leaf (observer_class_disp run_program cl) + | Event.NewInstance inst -> Lib.add_leaf (observer_instance (run_program,inst)) module StringMap = Map.Make(String) @@ -158,4 +145,4 @@ let activate_observer (observer : qualified_name) = Lib.add_leaf (inTakeover (Activate observer)) let deactivate_observer (observer : qualified_name) = - Lib.add_leaf (inTakeover (Deactivate observer)) + Lib.add_leaf (inTakeover (Deactivate observer)) \ No newline at end of file diff --git a/apps/tc/tests/test_pending_mode.v b/apps/tc/tests/test_pending_mode.v index 494e031be..0bce4b271 100644 --- a/apps/tc/tests/test_pending_mode.v +++ b/apps/tc/tests/test_pending_mode.v @@ -5,6 +5,20 @@ Elpi Accumulate TC.Compiler lp:{{ tc.add-class-gr _ A SM :- coq.say "Adding predicate for" A, coq.say "with mode" SM, fail, !. + + func old-version string, int, int, int ->. + old-version _ 9 0 _. + old-version _ 9 1 _. + old-version _ 9 2 _. + + pred get-old-mode o:string. + + :after "0" + main [str "new_class", str Cl, str _] :- old-version {coq.version}, get-old-mode Modes, not (var Modes), !, + tc.time-it tc.oTC-time-compile-class ( + coq.locate Cl GR, tc.add-class-gr tc.classic GR {rex.split " " Modes} + ) "Compiler for Class". + }}. Module ES3. @@ -23,8 +37,23 @@ Proof. eexists; now apply _. Qed. End ES3. -Module ES4. +Module ES3'. +#[mode = "-"]Class Add (I: nat). + +Instance addNat: Add 0. Qed. + +(* No problem in apply _ since the evar can be unified with the pattern 0 *) +Goal exists x, (Add x). +Proof. eexists; now apply _. Qed. + +End ES3'. + +Module ES4. +Section S. +Elpi Accumulate TC.Compiler lp:{{ + get-old-mode "+". +}}. (* Plus is mapped to the elpi input mode, i.e. the type of the predicate for add is `pred term -> term`. *) @@ -35,7 +64,7 @@ Instance addNat: Add 0. Qed. (* Failure in apply _ since the evar does not match the pattern 0 *) Goal exists x, (Add x). Proof. eexists. Fail apply _. Abort. - +End S. End ES4. @@ -245,4 +274,4 @@ Module force_input_link_HO_var3. Fail Timeout 1 apply _. Abort. -End force_input_link_HO_var3. +End force_input_link_HO_var3. \ No newline at end of file From 87db2fe6fe93f25f2fab43af449d702063c159f7 Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Mon, 8 Jun 2026 20:32:33 +0200 Subject: [PATCH 10/62] links for cs --- apps/tc/elpi/ho_compile.elpi | 8 ++++++++ apps/tc/elpi/ho_link.elpi | 16 ++++++++++++++++ apps/tc/elpi/ho_precompile.elpi | 9 +++++++++ apps/tc/elpi/tc_aux.elpi | 5 +++++ apps/tc/tests/test_proj.v | 12 ++++++++++++ apps/tc/theories/db.v | 1 + 6 files changed, 51 insertions(+) create mode 100644 apps/tc/tests/test_proj.v diff --git a/apps/tc/elpi/ho_compile.elpi b/apps/tc/elpi/ho_compile.elpi index d2d94ffc3..eabb63da9 100644 --- a/apps/tc/elpi/ho_compile.elpi +++ b/apps/tc/elpi/ho_compile.elpi @@ -23,6 +23,9 @@ namespace tc { decompile-term-aux (uvar as X) L X L :- !. decompile-term-aux (primitive _ as P) L P L :- !. + decompile-term-aux (tc.maybe-proj T S) (pr [X|XS] L1) X (pr XS [NL|L1]) :- !, + name Y X S, NL = tc.link.proj T X. + decompile-term-aux (tc.maybe-eta-tm T S) (pr [X|XS] L1) Y (pr XS' [NL | L2]) :- !, name Y X S, decompile-term-aux T (pr XS L1) T' (pr XS' L2), @@ -119,6 +122,7 @@ namespace tc { % TODO: also replace (sort (typ X)) and (pglobal _ X) with holes in the place of X func clean-term term -> term. clean-term A B :- + (pi t s r \ copy (tc.maybe-proj t s) t :- !) => (pi t s r \ copy (tc.maybe-eta-tm t s) r :- !, copy t r, !) => (pi t s r \ copy (tc.prod-range t s) r :- !, copy t r, !) => (pi t s r \ copy (tc.maybe-llam-tm t s) r :- !, copy t r, !) => @@ -349,6 +353,10 @@ namespace tc { decompile-problematic-term (tc.maybe-eta-tm T S) L V [tc.link.eta V T' | L2] :- prune V S, !, fold-map T L T' L2. + decompile-problematic-term (tc.maybe-proj A S) L X [NL|L] :- !, + prune X S, + NL = link.proj A X. + decompile-problematic-term (tc.prod-range T _) A T' A' :- !, fold-map T A T' A'. diff --git a/apps/tc/elpi/ho_link.elpi b/apps/tc/elpi/ho_link.elpi index 7541330d6..8ee2b9a26 100644 --- a/apps/tc/elpi/ho_link.elpi +++ b/apps/tc/elpi/ho_link.elpi @@ -133,6 +133,15 @@ namespace tc { } } + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + % Projection LINK % + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + namespace proj { + func proj term, term ->. + proj T (uvar as V) :- !, declare_constraint (proj T V) [_,V]. + proj T R :- coq.unify-eq T R ok. + } + namespace unif-eq { func unif-eq term, term. unif-eq T1 (uvar as T2) :- !, declare_constraint (unif-eq T1 T2) [_,T2]. @@ -154,5 +163,12 @@ namespace tc { func solve-llam. solve-llam :- declare_constraint solve-llam [_]. + + func proj term, term ->. + proj A B :- proj.proj A B. + + func solve-proj. + solve-proj :- declare_constraint solve-proj [_]. + } } \ No newline at end of file diff --git a/apps/tc/elpi/ho_precompile.elpi b/apps/tc/elpi/ho_precompile.elpi index 70fce53ed..533d87d79 100644 --- a/apps/tc/elpi/ho_precompile.elpi +++ b/apps/tc/elpi/ho_precompile.elpi @@ -9,6 +9,13 @@ namespace tc { % Tells if the current name stands for a uvar pred is-uvar o:term. + func maybe-projection-aux i:term. + maybe-projection-aux (primitive _). + maybe-projection-aux (global (const H)) :- coq.env.projection? H _. + + func maybe-projection i:term. + maybe-projection T :- coq.safe-dest-app T H _, maybe-projection-aux H. + :index (_ _ 1) func may-contract-to list term, term, term ->. may-contract-to _ N N :- !. @@ -113,6 +120,7 @@ namespace tc { precompile-aux _ (global _ as C) A C A :- !. precompile-aux _ (pglobal _ _ as C) A C A :- !. precompile-aux _ (sort _ as C) A C A :- !. + precompile-aux _ T A (tc.maybe-proj T X) (s A) :- maybe-projection T, !, free-var X. % Detect maybe-eta term % TODO: should I precompile also the type of the fun and put it in the output term @@ -240,6 +248,7 @@ namespace tc { precompile-aux (global _ as C) A C A :- !. precompile-aux (pglobal _ _ as C) A C A :- !. precompile-aux (sort _ as C) A C A :- !. + precompile-aux T A (tc.maybe-proj T S) A :- maybe-projection T, !, names S. % Detect maybe-eta term precompile-aux (fun Name Ty B as T) N (tc.maybe-eta-tm (fun Name Ty' B') Scope) M :- diff --git a/apps/tc/elpi/tc_aux.elpi b/apps/tc/elpi/tc_aux.elpi index d723e7c57..1275771ed 100644 --- a/apps/tc/elpi/tc_aux.elpi +++ b/apps/tc/elpi/tc_aux.elpi @@ -224,4 +224,9 @@ namespace tc { term -> % The current precompiled subterm: shape is app[app[X,PF],NPF] list term -> % The eta-expanded version of X, from X^{len(PF)} to X^{len(PF)+len(NPF)} term. + + type maybe-proj + term -> % The current precompiled subterm + list term -> % The list of FV in the precomp subterm + term. } diff --git a/apps/tc/tests/test_proj.v b/apps/tc/tests/test_proj.v new file mode 100644 index 000000000..aa62803cb --- /dev/null +++ b/apps/tc/tests/test_proj.v @@ -0,0 +1,12 @@ +From elpi Require Import tc. + +Record r := mkr {car : Type; rf : car -> car}. + +Canonical Structure c := mkr nat (fun x => x). + +Class C (T : Type) := {f : T -> T}. + +Instance inst c: C (car c). now constructor. Qed. + +Goal C nat. apply _. Qed. + diff --git a/apps/tc/theories/db.v b/apps/tc/theories/db.v index 26ece59d5..e0ce8ebd0 100644 --- a/apps/tc/theories/db.v +++ b/apps/tc/theories/db.v @@ -100,6 +100,7 @@ Elpi Db tc.db lp:{{ func link.eta term, term ->. func link.llam term, term ->. func link.unif-eq term, term ->. + func link.proj term, term ->. } }}. From 5b3abcf8a84962de5421d3a8d460858026cb4cf2 Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Tue, 9 Jun 2026 11:12:57 +0200 Subject: [PATCH 11/62] more on projections --- apps/tc/elpi/ho_compile.elpi | 2 +- apps/tc/elpi/ho_link.elpi | 8 ++++- apps/tc/elpi/ho_precompile.elpi | 61 ++++++++++++++++++++++++++++----- apps/tc/elpi/solver.elpi | 3 +- apps/tc/elpi/tc_aux.elpi | 1 + apps/tc/tests/test_proj.v | 56 +++++++++++++++++++++++++++--- 6 files changed, 115 insertions(+), 16 deletions(-) diff --git a/apps/tc/elpi/ho_compile.elpi b/apps/tc/elpi/ho_compile.elpi index eabb63da9..b13ff048e 100644 --- a/apps/tc/elpi/ho_compile.elpi +++ b/apps/tc/elpi/ho_compile.elpi @@ -355,7 +355,7 @@ namespace tc { decompile-problematic-term (tc.maybe-proj A S) L X [NL|L] :- !, prune X S, - NL = link.proj A X. + NL = tc.link.proj A X. decompile-problematic-term (tc.prod-range T _) A T' A' :- !, fold-map T A T' A'. diff --git a/apps/tc/elpi/ho_link.elpi b/apps/tc/elpi/ho_link.elpi index 8ee2b9a26..2b16f7cf7 100644 --- a/apps/tc/elpi/ho_link.elpi +++ b/apps/tc/elpi/ho_link.elpi @@ -138,8 +138,14 @@ namespace tc { %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% namespace proj { func proj term, term ->. - proj T (uvar as V) :- !, declare_constraint (proj T V) [_,V]. + proj T (uvar as V) :- !, get-vars B Vars, declare_constraint (proj T V) [_,V|Vars]. + :name "proj-unif" proj T R :- coq.unify-eq T R ok. + + constraint solve-proj proj { + rule solve-proj \ (proj A B) <=> (coq.unify-eq A B ok). + rule \ solve-proj. + } } namespace unif-eq { diff --git a/apps/tc/elpi/ho_precompile.elpi b/apps/tc/elpi/ho_precompile.elpi index 533d87d79..a53bc259c 100644 --- a/apps/tc/elpi/ho_precompile.elpi +++ b/apps/tc/elpi/ho_precompile.elpi @@ -2,6 +2,38 @@ namespace tc { shorten tc.{r-ar, range-arity}. namespace precomp { + func maybe-projection i:term. + maybe-projection (app [primitive _ | _]). + maybe-projection (app [global (const H) | _]) :- coq.env.projection? H _. + + func reducers coq.redflag, coq.redflag -> coq.redflags. + reducers R1 R2 R :- + coq.redflags.add coq.redflags.nored [R1, R2, coq.redflags.fix, coq.redflags.beta, coq.redflags.match] R. + + func reducerPC projection, constant -> coq.redflags. + reducerPC P C R :- + reducers (coq.redflags.proj P) (coq.redflags.const C) R. + + func reducerCC constant, constant -> coq.redflags. + reducerCC C1 C2 R :- + reducers (coq.redflags.const C1) (coq.redflags.const C2) R. + + func proj-reducer-help coq.redflags, term -> term. + proj-reducer-help R T T' :- + (@redflags! R => coq.reduction.cbv.norm T T'), + not (same_term T T'). + + % tries to reduce the term wrt to its head-projection + % here we take into account a projector applied to a single argument + % the argument should be a constant + func proj-reducer term -> term. + proj-reducer (app [primitive (proj P _N), global (const C)] as T) T' :- + reducerPC P C R, proj-reducer-help R T T'. + proj-reducer (app [global (const C1), global (const C2)] as T) T' :- + % before reducing, we check that C1 is a projection + coq.env.projection? C1 _, + reducerCC C1 C2 R, proj-reducer-help R T T'. + namespace instance { % Tells if the current name is a bound variables @@ -9,13 +41,6 @@ namespace tc { % Tells if the current name stands for a uvar pred is-uvar o:term. - func maybe-projection-aux i:term. - maybe-projection-aux (primitive _). - maybe-projection-aux (global (const H)) :- coq.env.projection? H _. - - func maybe-projection i:term. - maybe-projection T :- coq.safe-dest-app T H _, maybe-projection-aux H. - :index (_ _ 1) func may-contract-to list term, term, term ->. may-contract-to _ N N :- !. @@ -120,7 +145,16 @@ namespace tc { precompile-aux _ (global _ as C) A C A :- !. precompile-aux _ (pglobal _ _ as C) A C A :- !. precompile-aux _ (sort _ as C) A C A :- !. - precompile-aux _ T A (tc.maybe-proj T X) (s A) :- maybe-projection T, !, free-var X. + :name "precomp-proj-inst" + precompile-aux _ T A T' A' :- + maybe-projection T, !, + % try to reduce the projection, if the reduction suceeds, then we return the + % reduced term + if (proj-reducer T T') + (A' = A) + % otherwise we tag the problematic subterm + (free-var X, T' = (tc.maybe-proj T X), A' = s A) + . % Detect maybe-eta term % TODO: should I precompile also the type of the fun and put it in the output term @@ -248,7 +282,16 @@ namespace tc { precompile-aux (global _ as C) A C A :- !. precompile-aux (pglobal _ _ as C) A C A :- !. precompile-aux (sort _ as C) A C A :- !. - precompile-aux T A (tc.maybe-proj T S) A :- maybe-projection T, !, names S. + :name "precomp-proj-goal" + precompile-aux T A T' A :- + maybe-projection T, !, + % try to reduce the projection, if the reduction suceeds, then we return the + % reduced term + if (proj-reducer T T') + true + % otherwise we tag the problematic subterm + (names X, T' = (tc.maybe-proj T X)). + % Detect maybe-eta term precompile-aux (fun Name Ty B as T) N (tc.maybe-eta-tm (fun Name Ty' B') Scope) M :- diff --git a/apps/tc/elpi/solver.elpi b/apps/tc/elpi/solver.elpi index fb77502ff..ebbcaf815 100644 --- a/apps/tc/elpi/solver.elpi +++ b/apps/tc/elpi/solver.elpi @@ -33,7 +33,8 @@ namespace tc { tc.time-it tc.oTC-time-instance-search ( do PostProcess, Q, tc.link.solve-eta, % Trigger eta links - tc.link.solve-llam % Trigger llam links + tc.link.solve-llam, % Trigger llam links + tc.link.solve-proj % Trigger proj links ) "instance search". pred solve-aux i:goal, o:list sealed-goal. diff --git a/apps/tc/elpi/tc_aux.elpi b/apps/tc/elpi/tc_aux.elpi index 1275771ed..0fa9363d3 100644 --- a/apps/tc/elpi/tc_aux.elpi +++ b/apps/tc/elpi/tc_aux.elpi @@ -78,6 +78,7 @@ namespace tc { % adds a clause to the tc.db DB at the passed grafting func add-tc-db id, grafting, prop ->. + :name "tc-adder" add-tc-db _ _ Clause :- not (ground_term Clause), coq.error "[TC] anomaly: open rule:" Clause, !. add-tc-db ClauseName Graft Clause :- coq.elpi.accumulate _ "tc.db" (clause ClauseName Graft Clause), !. add-tc-db _ _ Clause :- coq.error "cannot add " PR " to tc.db". diff --git a/apps/tc/tests/test_proj.v b/apps/tc/tests/test_proj.v index aa62803cb..0287cdad9 100644 --- a/apps/tc/tests/test_proj.v +++ b/apps/tc/tests/test_proj.v @@ -1,12 +1,60 @@ From elpi Require Import tc. -Record r := mkr {car : Type; rf : car -> car}. +Set TC NameShortPath. +Class C (T : Type) := {f : T -> T}. +Record r := mkr {car : Type; rf : car -> car}. Canonical Structure c := mkr nat (fun x => x). -Class C (T : Type) := {f : T -> T}. +Elpi Accumulate TC.Compiler lp:{{ + % the goal is to check instances for C are correctly compiled + func is-class-C prop ->. + is-class-C (pi x\ X x) :- !, pi x\ is-class-C (X x). + is-class-C (tc-C _ _ :- _ as C) :- !, coq.say "Checking"C, if (expected-rule C) true (coq.error "Wrong compilation of" C). + is-class-C (tc-C _ _ as C) :- !, coq.say "Checking"C, if (expected-rule C) true (coq.error "Wrong compilation of" C). + is-class-C _. + + + func expected-rule -> prop. + pred dummy. + :name "x" dummy. + :before "tc-adder" + tc.add-tc-db _I _G C :- % coq.say "Compiled term is" C, + std.spy(is-class-C C), fail, !. +}}. + +Module m1. + Elpi Accumulate TC.Compiler lp:{{ + :after "x" expected-rule (tc-C {{nat}} _). + }}. + + (* reducing the projection statically *) + Instance inst_red: C (car c). now constructor. Qed. + + Elpi Accumulate TC.Compiler lp:{{ + % removing the previous expected (best should be that the previous rule is local to the module) + :after "x" expected-rule _ :- !, fail. + }}. + (* Elpi Print TC.Compiler "elpi.apps.derive.tests/xxx". *) + + Goal C nat. apply _. Qed. + Goal C (car c). apply _. Qed. +End m1. -Instance inst c: C (car c). now constructor. Qed. +Module m2. + (* Mh, why this fails? *) + (* Elpi Accumulate TC.Compiler lp:{{ + :after "x" expected-rule X :- !, coq.say "CIAO"X, std.spy(X = (tc-C Y _ :- [tc.link.proj _ _])), !. + }}. *) + Elpi Accumulate TC.Compiler lp:{{ + % TODO: here I am doing to weak check, should make the previous Accumulate succeeds + :after "x" expected-rule X :- !, X = (tc-C Y _ :- [K_]), !. + }}. -Goal C nat. apply _. Qed. + (* cannot reduce the projection: c is quantified *) + Instance inst c: C (car c). now constructor. Qed. + (* need to use the chr *) + Goal C nat. apply _. Qed. + Goal C (car c). apply _. Qed. +End m2. From 44ee00cfb60b57508444684aea8890899ed60308 Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Tue, 9 Jun 2026 13:12:21 +0200 Subject: [PATCH 12/62] add comment to code --- apps/tc/elpi/ho_compile.elpi | 1 + 1 file changed, 1 insertion(+) diff --git a/apps/tc/elpi/ho_compile.elpi b/apps/tc/elpi/ho_compile.elpi index b13ff048e..d8bb50f66 100644 --- a/apps/tc/elpi/ho_compile.elpi +++ b/apps/tc/elpi/ho_compile.elpi @@ -292,6 +292,7 @@ namespace tc { func context goal-ctx -> list prop. context [] []. + % if the hyp is for a TC we compile before its insertion in the context context [X | Xs] [Clause | ResTl] :- (decl Var _ Ty = X; def Var _ Ty _ = X), tc.is-instance-term Ty, !, From badd8b5b4d0d7b8543e55a246662c3b761561a35 Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Tue, 9 Jun 2026 13:38:03 +0200 Subject: [PATCH 13/62] externalize get-vars --- apps/tc/elpi/ho_link.elpi | 5 +---- apps/tc/elpi/tc_aux.elpi | 5 +++++ 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/apps/tc/elpi/ho_link.elpi b/apps/tc/elpi/ho_link.elpi index 2b16f7cf7..69979ec13 100644 --- a/apps/tc/elpi/ho_link.elpi +++ b/apps/tc/elpi/ho_link.elpi @@ -1,9 +1,6 @@ namespace tc { namespace link { - func get-vars term -> list term. - get-vars T R :- - (pi X H L Ign\ fold-map X L X [H|L] :- var X H Ign, !) => - fold-map T [] _ R. + shorten tc.{get-vars}. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % ETA LINK % diff --git a/apps/tc/elpi/tc_aux.elpi b/apps/tc/elpi/tc_aux.elpi index 0fa9363d3..7953ef72e 100644 --- a/apps/tc/elpi/tc_aux.elpi +++ b/apps/tc/elpi/tc_aux.elpi @@ -3,6 +3,11 @@ namespace tc { + func get-vars term -> list term. + get-vars T R :- + (pi X H L Ign\ fold-map X L X [H|L] :- var X H Ign, !) => + fold-map T [] _ R. + namespace lettify { func replace-args term, list term, list term, (func term -> term) -> term. replace-args Hd [] L K R :- std.rev L L1, K (app [Hd|L1]) R. From 990359d548a261f0425dd77c9138864f4188e6c8 Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Tue, 9 Jun 2026 15:41:59 +0200 Subject: [PATCH 14/62] some fixes --- apps/tc/elpi/ho_link.elpi | 15 ++++++++++++--- apps/tc/tests/test_proj.v | 21 +++++++++++++++++++-- 2 files changed, 31 insertions(+), 5 deletions(-) diff --git a/apps/tc/elpi/ho_link.elpi b/apps/tc/elpi/ho_link.elpi index 69979ec13..a1fc55208 100644 --- a/apps/tc/elpi/ho_link.elpi +++ b/apps/tc/elpi/ho_link.elpi @@ -135,12 +135,21 @@ namespace tc { %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% namespace proj { func proj term, term ->. - proj T (uvar as V) :- !, get-vars B Vars, declare_constraint (proj T V) [_,V|Vars]. + proj T V :- var V, !, get-vars T Vars, declare_constraint (proj T V) [_,V|Vars]. :name "proj-unif" proj T R :- coq.unify-eq T R ok. - constraint solve-proj proj { - rule solve-proj \ (proj A B) <=> (coq.unify-eq A B ok). + func force-unify list prop, term, term ->. + :name "force-proj" + % If B is a variale we launch elpi unification + force-unify _ A B :- var B, !, A = B. + force-unify Ctx A B :- Ctx => coq.unify-eq A B ok. + + + constraint decl def ?- solve-proj proj { + % TODO: should add a dedup constraint + rule solve-proj \ (Ctx ?- proj A B) <=> (force-unify Ctx A B). + % rule solve-proj \ (Ctx ?- proj A B) <=> (A = B). rule \ solve-proj. } } diff --git a/apps/tc/tests/test_proj.v b/apps/tc/tests/test_proj.v index 0287cdad9..325438e0e 100644 --- a/apps/tc/tests/test_proj.v +++ b/apps/tc/tests/test_proj.v @@ -29,7 +29,7 @@ Module m1. }}. (* reducing the projection statically *) - Instance inst_red: C (car c). now constructor. Qed. + Local Instance inst_red: C (car c). now constructor. Qed. Elpi Accumulate TC.Compiler lp:{{ % removing the previous expected (best should be that the previous rule is local to the module) @@ -52,9 +52,26 @@ Module m2. }}. (* cannot reduce the projection: c is quantified *) - Instance inst c: C (car c). now constructor. Qed. + Local Instance inst c: C (car c). now constructor. Qed. (* need to use the chr *) Goal C nat. apply _. Qed. Goal C (car c). apply _. Qed. End m2. + + +Module m3. + Elpi Accumulate TC.Compiler lp:{{ + % TODO: here I am doing to weak check, should make the previous Accumulate succeeds + :after "x" expected-rule (tc-C X _) :- !, name X. + }}. + + (* cannot reduce the projection: c is quantified *) + Instance inst X: C X. now constructor. Qed. + + (* need to use the chr *) + Goal C nat. apply _. Qed. + Goal C (car c). apply _. Qed. + (* with local instance for c *) + Goal forall x, C (car x). apply _. Qed. +End m3. From db26cdce876fd102dce538b828deeeb698d09b29 Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Tue, 9 Jun 2026 19:41:22 +0200 Subject: [PATCH 15/62] fix variable scoping in compiled rule --- apps/tc/elpi/ho_compile.elpi | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/apps/tc/elpi/ho_compile.elpi b/apps/tc/elpi/ho_compile.elpi index d8bb50f66..5b1bed3a8 100644 --- a/apps/tc/elpi/ho_compile.elpi +++ b/apps/tc/elpi/ho_compile.elpi @@ -23,8 +23,9 @@ namespace tc { decompile-term-aux (uvar as X) L X L :- !. decompile-term-aux (primitive _ as P) L P L :- !. - decompile-term-aux (tc.maybe-proj T S) (pr [X|XS] L1) X (pr XS [NL|L1]) :- !, - name Y X S, NL = tc.link.proj T X. + :name "decompile-inst-maybe-proj" + decompile-term-aux (tc.maybe-proj T S) (pr [X|XS] L1) Y (pr XS [NL|L1]) :- !, + name Y X S, NL = tc.link.proj T Y. decompile-term-aux (tc.maybe-eta-tm T S) (pr [X|XS] L1) Y (pr XS' [NL | L2]) :- !, name Y X S, From eb1eda10ced07f91619e855a18cd3822c7699700 Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Tue, 9 Jun 2026 23:09:04 +0200 Subject: [PATCH 16/62] do notcle link-proj opaque constants + coq.env.const-body instead of coq.reduction.cbv.norm --- apps/tc/elpi/ho_precompile.elpi | 53 +++++++++++++-------------------- 1 file changed, 20 insertions(+), 33 deletions(-) diff --git a/apps/tc/elpi/ho_precompile.elpi b/apps/tc/elpi/ho_precompile.elpi index a53bc259c..cc83acb6a 100644 --- a/apps/tc/elpi/ho_precompile.elpi +++ b/apps/tc/elpi/ho_precompile.elpi @@ -6,33 +6,19 @@ namespace tc { maybe-projection (app [primitive _ | _]). maybe-projection (app [global (const H) | _]) :- coq.env.projection? H _. - func reducers coq.redflag, coq.redflag -> coq.redflags. - reducers R1 R2 R :- - coq.redflags.add coq.redflags.nored [R1, R2, coq.redflags.fix, coq.redflags.beta, coq.redflags.match] R. - - func reducerPC projection, constant -> coq.redflags. - reducerPC P C R :- - reducers (coq.redflags.proj P) (coq.redflags.const C) R. - - func reducerCC constant, constant -> coq.redflags. - reducerCC C1 C2 R :- - reducers (coq.redflags.const C1) (coq.redflags.const C2) R. - - func proj-reducer-help coq.redflags, term -> term. - proj-reducer-help R T T' :- - (@redflags! R => coq.reduction.cbv.norm T T'), - not (same_term T T'). + func const-args constant -> list term. + const-args C L :- coq.env.const-body C (some (app[_|L])). % tries to reduce the term wrt to its head-projection % here we take into account a projector applied to a single argument % the argument should be a constant func proj-reducer term -> term. - proj-reducer (app [primitive (proj P _N), global (const C)] as T) T' :- - reducerPC P C R, proj-reducer-help R T T'. - proj-reducer (app [global (const C1), global (const C2)] as T) T' :- - % before reducing, we check that C1 is a projection - coq.env.projection? C1 _, - reducerCC C1 C2 R, proj-reducer-help R T T'. + proj-reducer (app [primitive (proj P N), global (const C)] as T) T' :- + const-args C L, !, std.nth N L T'. + proj-reducer (app [global (const P), global (const C)] as T) T' :- + coq.env.projection? P N, const-args C L, !, + std.nth N L T'. + proj-reducer T T. namespace instance { @@ -139,6 +125,11 @@ namespace tc { get-range-arity _ Ty _ (r-ar z N) :- tc.get-TC-of-inst-type Ty _, !, count-prod Ty N. get-range-arity B _ T N :- !, get-range-arity-aux B T N. + func work-proj term, nat -> term, nat. + work-proj (app[H, V] as T) A T' A' :- is-uvar V, !, + free-var X, T' = tc.maybe-proj T X, A' = s A. + work-proj T A T' A :- proj-reducer T T'. + :index (_ 1) func precompile-aux positivity, term, nat -> term, nat. precompile-aux _ X A Y A :- name X, !, X = Y, !. % avoid loading "precompile-aux x A x A" at binders @@ -148,13 +139,7 @@ namespace tc { :name "precomp-proj-inst" precompile-aux _ T A T' A' :- maybe-projection T, !, - % try to reduce the projection, if the reduction suceeds, then we return the - % reduced term - if (proj-reducer T T') - (A' = A) - % otherwise we tag the problematic subterm - (free-var X, T' = (tc.maybe-proj T X), A' = s A) - . + work-proj T A T' A'. % Detect maybe-eta term % TODO: should I precompile also the type of the fun and put it in the output term @@ -277,6 +262,11 @@ namespace tc { split-pf [X|Xs] Old [X|Ys] L :- name X, not (std.mem! Old X), !, split-pf Xs [X|Old] Ys L. split-pf Xs _ [] Xs. + func work-proj term -> term. + work-proj (app[H, (uvar as V)] as T) T' :- !, + free-var X, T' = tc.maybe-proj T X. + work-proj T T' :- proj-reducer T T'. + func precompile-aux term, list term -> term, list term. precompile-aux X A Y A :- name X, !, X = Y, !. % avoid loading "precompile-aux x A x A" at binders precompile-aux (global _ as C) A C A :- !. @@ -287,10 +277,7 @@ namespace tc { maybe-projection T, !, % try to reduce the projection, if the reduction suceeds, then we return the % reduced term - if (proj-reducer T T') - true - % otherwise we tag the problematic subterm - (names X, T' = (tc.maybe-proj T X)). + work-proj T T'. % Detect maybe-eta term From decf0305c53f592676bb7eb53b561d854f5701b0 Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Tue, 9 Jun 2026 23:09:11 +0200 Subject: [PATCH 17/62] refactor code --- apps/tc/elpi/ho_precompile.elpi | 53 +++++++++++++++++---------------- 1 file changed, 27 insertions(+), 26 deletions(-) diff --git a/apps/tc/elpi/ho_precompile.elpi b/apps/tc/elpi/ho_precompile.elpi index cc83acb6a..fc89df8bc 100644 --- a/apps/tc/elpi/ho_precompile.elpi +++ b/apps/tc/elpi/ho_precompile.elpi @@ -2,23 +2,23 @@ namespace tc { shorten tc.{r-ar, range-arity}. namespace precomp { - func maybe-projection i:term. - maybe-projection (app [primitive _ | _]). - maybe-projection (app [global (const H) | _]) :- coq.env.projection? H _. - - func const-args constant -> list term. - const-args C L :- coq.env.const-body C (some (app[_|L])). + % check if the term's head is a projector + % returns a term where prim-proj are replaced with + % the compatibility constant, the projector number, + % the argument + func maybe-projection term -> constant, int, term. + maybe-projection (app [primitive (proj P N), A]) C N A :- + coq.env.primitive-projection? P C _. + maybe-projection (app [global (const P), A]) P N A :- + coq.env.projection? P N. % tries to reduce the term wrt to its head-projection % here we take into account a projector applied to a single argument % the argument should be a constant - func proj-reducer term -> term. - proj-reducer (app [primitive (proj P N), global (const C)] as T) T' :- - const-args C L, !, std.nth N L T'. - proj-reducer (app [global (const P), global (const C)] as T) T' :- - coq.env.projection? P N, const-args C L, !, - std.nth N L T'. - proj-reducer T T. + func proj-reducer constant, int, term -> term. + proj-reducer P N (global (const C)) T :- + coq.env.const-body C (some (app[_|L])), !, std.nth N L T. + proj-reducer P _ A (app[global (const P), A]). namespace instance { @@ -125,10 +125,11 @@ namespace tc { get-range-arity _ Ty _ (r-ar z N) :- tc.get-TC-of-inst-type Ty _, !, count-prod Ty N. get-range-arity B _ T N :- !, get-range-arity-aux B T N. - func work-proj term, nat -> term, nat. - work-proj (app[H, V] as T) A T' A' :- is-uvar V, !, - free-var X, T' = tc.maybe-proj T X, A' = s A. - work-proj T A T' A :- proj-reducer T T'. + % receives the compatibility constant of a projection, its number, the argument of the proj + func work-proj constant, int, term, nat -> term, nat. + work-proj P _ A N (tc.maybe-proj (app[global (const P), A]) X) (s N) :- is-uvar A, !, + free-var X. + work-proj P PN A N T' N :- proj-reducer P PN A T'. :index (_ 1) func precompile-aux positivity, term, nat -> term, nat. @@ -137,9 +138,9 @@ namespace tc { precompile-aux _ (pglobal _ _ as C) A C A :- !. precompile-aux _ (sort _ as C) A C A :- !. :name "precomp-proj-inst" - precompile-aux _ T A T' A' :- - maybe-projection T, !, - work-proj T A T' A'. + precompile-aux _ T N T' N' :- + maybe-projection T P PN Ag, !, + work-proj P PN Ag N T' N'. % Detect maybe-eta term % TODO: should I precompile also the type of the fun and put it in the output term @@ -262,10 +263,10 @@ namespace tc { split-pf [X|Xs] Old [X|Ys] L :- name X, not (std.mem! Old X), !, split-pf Xs [X|Old] Ys L. split-pf Xs _ [] Xs. - func work-proj term -> term. - work-proj (app[H, (uvar as V)] as T) T' :- !, - free-var X, T' = tc.maybe-proj T X. - work-proj T T' :- proj-reducer T T'. + func work-proj constant, int, term -> term. + work-proj P _ (uvar as A) (tc.maybe-proj (app[global (const P), A]) X) :- !, + free-var X. + work-proj P PN A T' :- proj-reducer P PN A T'. func precompile-aux term, list term -> term, list term. precompile-aux X A Y A :- name X, !, X = Y, !. % avoid loading "precompile-aux x A x A" at binders @@ -274,10 +275,10 @@ namespace tc { precompile-aux (sort _ as C) A C A :- !. :name "precomp-proj-goal" precompile-aux T A T' A :- - maybe-projection T, !, + maybe-projection T P N Ag, !, % try to reduce the projection, if the reduction suceeds, then we return the % reduced term - work-proj T T'. + work-proj P N Ag T'. % Detect maybe-eta term From 956130b3c5ffb9a6b31ead6a26e2a5289ae23c38 Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Wed, 10 Jun 2026 15:08:54 +0200 Subject: [PATCH 18/62] fix proj number (with get-proj-nb) --- apps/tc/elpi/ho_precompile.elpi | 147 +++++++++++++++++++++++--------- apps/tc/tests/test_proj.v | 106 +++++++++++++++++++---- 2 files changed, 196 insertions(+), 57 deletions(-) diff --git a/apps/tc/elpi/ho_precompile.elpi b/apps/tc/elpi/ho_precompile.elpi index fc89df8bc..e343adca3 100644 --- a/apps/tc/elpi/ho_precompile.elpi +++ b/apps/tc/elpi/ho_precompile.elpi @@ -1,24 +1,80 @@ namespace tc { shorten tc.{r-ar, range-arity}. + func split-last list A -> list A, A. + split-last [X] [] X :- !. + split-last [X|Xs] [X|Y] Z :- split-last Xs Y Z. + + func list.pos list A, A -> int. + list.pos [A|_] A 0 :- !. + list.pos [_|L] A N :- list.pos L A N', N is N' + 1. + namespace precomp { - % check if the term's head is a projector - % returns a term where prim-proj are replaced with - % the compatibility constant, the projector number, - % the argument - func maybe-projection term -> constant, int, term. - maybe-projection (app [primitive (proj P N), A]) C N A :- - coq.env.primitive-projection? P C _. - maybe-projection (app [global (const P), A]) P N A :- - coq.env.projection? P N. - - % tries to reduce the term wrt to its head-projection - % here we take into account a projector applied to a single argument - % the argument should be a constant - func proj-reducer constant, int, term -> term. - proj-reducer P N (global (const C)) T :- - coq.env.const-body C (some (app[_|L])), !, std.nth N L T. - proj-reducer P _ A (app[global (const P), A]). + func get-record int, term -> inductive. + get-record 0 (prod _ (app [global (indt I) | _]) _) I :- !. + get-record 0 (prod _ (global (indt I)) _) I :- !. + get-record N (prod _ _ Bo) T :- N > 0, N' is N - 1, + pi x\ get-record N' (Bo x) T, !. + + func get-proj-nb constant -> int. + get-proj-nb C N :- + coq.env.projection? C Nx, + coq.env.const C _ Ty, + get-record Nx Ty I, + coq.env.projections I P, + list.pos P (some C) M, + N is M + Nx. + + % [maybe-projection T C N A R] + % check if the head of T is the application of a projection + % for example T = app[P, ARGS..., R] + % where P is the projector, ARGS are the parameter of the projector + % R is the record to project + % C is the compatibily constant of the projector P + % N is the number position of C + % A is the list of argument applied to the projection (except for the record itself) + % R is the record + func maybe-projection term -> constant, int, list term, term. + :name "maybe-projection" + maybe-projection (app [primitive (proj P N), R]) C N A R :- + coq.env.primitive-projection? P C _, + std.assert-ok!(coq.typecheck R Ty) "err", + coq.safe-dest-app Ty _ A. + % TODO: should check that C is fully applied + maybe-projection (app [global (const C) | Args]) C N A R :- + coq.env.projection? C _, !, + get-proj-nb C N, std.assert!(split-last Args A R) "err: empty list". + + func build-proj-term constant, list term, term -> term. + build-proj-term P Ag C (app[global (const P) | Ag']) :- + std.append Ag [C] Ag'. + + % [proj-reducer-aux R P N O L T] + % R is the record constant + % P is the compatibility constant of the projector + % N is the projection number + % O is the optional body of the projected constant + % L are the arguments of the projection + % T is the projected terms + :index(_ _ _ 1) + func proj-reducer-aux constant, constant, int, option term, list term -> term. + :name "proj-reducer-aux" + proj-reducer-aux _ _ N (some (app [_|L])) _ T :- std.nth N L T. + proj-reducer-aux R P _ none Ag T :- build-proj-term P Ag (global (const R)) T. + + % [proj-reducer P N Ag R T] + % P is the projector constant + % N is the number of P + % Ag is the arguments applied to the projector (except for the record) + % R is the record + % T is the reduced term + func proj-reducer constant, int, list term, term -> term. + :name "proj-reducer" + proj-reducer P N _ (global (const R)) T :- !, + coq.env.const R O Ty, + coq.safe-dest-app Ty _ TyAg, + proj-reducer-aux R P N O TyAg T. + % proj-reducer P _ Ag R T :- build-proj-term P Ag R T. namespace instance { @@ -125,12 +181,20 @@ namespace tc { get-range-arity _ Ty _ (r-ar z N) :- tc.get-TC-of-inst-type Ty _, !, count-prod Ty N. get-range-arity B _ T N :- !, get-range-arity-aux B T N. - % receives the compatibility constant of a projection, its number, the argument of the proj - func work-proj constant, int, term, nat -> term, nat. - work-proj P _ A N (tc.maybe-proj (app[global (const P), A]) X) (s N) :- is-uvar A, !, - free-var X. - work-proj P PN A N T' N :- proj-reducer P PN A T'. - + % [work-proj P PN Ag R N T N'] + % P, PN are the constant and the proj number + % Ag are the argument of the projector (except for the record) + % R is the record + % N is the hole counter + % T is the new term + % N' is the updated counter + func work-proj constant, int, list term, term, nat -> term, nat. + work-proj P _ Ag R N (tc.maybe-proj (app[global (const P) | Ag']) X) (s N) :- is-uvar R, !, + std.append Ag [R] Ag', free-var X. + work-proj P PN Ag R N T' N :- proj-reducer P PN Ag R T', !. + work-proj P _ Ag R N (tc.maybe-proj (app[global (const P) | Ag']) X) (s N) :- !, + std.append Ag [R] Ag', free-var X. +% :index (_ 1) func precompile-aux positivity, term, nat -> term, nat. precompile-aux _ X A Y A :- name X, !, X = Y, !. % avoid loading "precompile-aux x A x A" at binders @@ -139,8 +203,8 @@ namespace tc { precompile-aux _ (sort _ as C) A C A :- !. :name "precomp-proj-inst" precompile-aux _ T N T' N' :- - maybe-projection T P PN Ag, !, - work-proj P PN Ag N T' N'. + maybe-projection T P PN Ag R, !, + work-proj P PN Ag R N T' N'. % Detect maybe-eta term % TODO: should I precompile also the type of the fun and put it in the output term @@ -148,7 +212,7 @@ namespace tc { maybe-eta T, !, free-var Scope, precompile-aux is_neg_fix Ty N _ N', - (pi x\ is-name x => precompile-aux is_neg_fix (B x) N' (B' x) M). + (pi x\ is-name x => decl x Name Ty => precompile-aux is_neg_fix (B x) N' (B' x) M). precompile-aux _ (app [X|XS]) N (tc.maybe-llam-tm (app [app[X | PF] | NPF1]) Scope) (s M) :- if (is-uvar X) (Sc = []) (var X _ Sc), split-pf XS Sc PF NPF, @@ -161,12 +225,12 @@ namespace tc { precompile-aux IsP (prod Name Ty B) N (tc.prod-range (prod Name Ty' B') MaxAr) P :- !, std.assert! (pi x\ get-range-arity x Ty (B x) MaxAr) "[TC] get-range-arity should not fail", if (IsP = is_pos) (C = x\ is-uvar x) (C = x\ is-name x), - std.assert! (pi x\ C x => precompile-aux IsP (B x) N (B' x) M) "[TC] should not fail", + std.assert! (pi x\ C x => decl x Name Ty => precompile-aux IsP (B x) N (B' x) M) "[TC] should not fail", precompile-aux {neg IsP} Ty M Ty' P. % Working with fun precompile-aux _ (fun N T F) A (fun N T1 F1) A2 :- !, - precompile-aux is_neg_fix T A T1 A1, pi x\ is-name x => precompile-aux is_neg_fix (F x) A1 (F1 x) A2. + precompile-aux is_neg_fix T A T1 A1, pi x\ is-name x => decl x N T => precompile-aux is_neg_fix (F x) A1 (F1 x) A2. precompile-aux _ (app L) A (app L1) A1 :- !, std.fold-map L A (precompile-aux is_neg_fix) L1 A1. precompile-aux _ X A X A :- var X, !. @@ -174,7 +238,7 @@ namespace tc { precompile-aux _ (let N T Ty Bo) A (let N T' Ty' Bo') A3 :- !, precompile-aux is_neg_fix T A T' A1, precompile-aux is_neg_fix Ty A1 Ty' A2, - pi x\ is-name x => precompile-aux is_neg_fix (Bo x) A2 (Bo' x) A3. + pi x\ is-name x => def x N T Ty => precompile-aux is_neg_fix (Bo x) A2 (Bo' x) A3. % TODO: what about the following constructors? @@ -263,10 +327,12 @@ namespace tc { split-pf [X|Xs] Old [X|Ys] L :- name X, not (std.mem! Old X), !, split-pf Xs [X|Old] Ys L. split-pf Xs _ [] Xs. - func work-proj constant, int, term -> term. - work-proj P _ (uvar as A) (tc.maybe-proj (app[global (const P), A]) X) :- !, - free-var X. - work-proj P PN A T' :- proj-reducer P PN A T'. + func work-proj constant, int, list term, term -> term. + work-proj P _ Ag (uvar as R) (tc.maybe-proj (app[global (const P) | Ag']) X) :- !, + std.append Ag [R] Ag', names X. + work-proj P PN Ag R T' :- proj-reducer P PN Ag R T', !. + work-proj P _ Ag R (tc.maybe-proj (app[global (const P) | Ag']) X) :- + std.append Ag [R] Ag', names X. func precompile-aux term, list term -> term, list term. precompile-aux X A Y A :- name X, !, X = Y, !. % avoid loading "precompile-aux x A x A" at binders @@ -275,17 +341,14 @@ namespace tc { precompile-aux (sort _ as C) A C A :- !. :name "precomp-proj-goal" precompile-aux T A T' A :- - maybe-projection T P N Ag, !, - % try to reduce the projection, if the reduction suceeds, then we return the - % reduced term - work-proj P N Ag T'. - + maybe-projection T P PN Ag R, !, + work-proj P PN Ag R T'. % Detect maybe-eta term precompile-aux (fun Name Ty B as T) N (tc.maybe-eta-tm (fun Name Ty' B') Scope) M :- maybe-eta T, !, names Scope, - (pi x\ precompile-aux (B x) N (B' x) M'), + (pi x\ decl x Name Ty => precompile-aux (B x) N (B' x) M'), precompile-aux Ty M' Ty' M. % Detect maybe-beta term @@ -298,16 +361,16 @@ namespace tc { % In the goal there are precompile-aux (prod Name Ty B) N (tc.prod-range (prod Name Ty' B') (r-ar z MaxAr)) P :- !, count-prod Ty MaxAr, - std.assert! (pi x\ precompile-aux (B x) N (B' x) M) "[TC] should not fail", + std.assert! (pi x\ decl x Name Ty => precompile-aux (B x) N (B' x) M) "[TC] should not fail", precompile-aux Ty M Ty' P. % Working with fun precompile-aux (fun N T F) A (fun N T F1) A2 :- !, A = A1, - /*precompile-aux IsP T A T1 A1,*/ pi x\ precompile-aux (F x) A1 (F1 x) A2. + /*precompile-aux IsP T A T1 A1,*/ pi x\ decl x N Ty => precompile-aux (F x) A1 (F1 x) A2. precompile-aux (app L) A (app L1) A1 :- !, std.fold-map L A precompile-aux L1 A1. precompile-aux (let N T B F) A (let N T1 B1 F1) A3 :- !, - precompile-aux T A T1 A1, precompile-aux B A1 B1 A2, pi x\ precompile-aux (F x) A2 (F1 x) A3. + precompile-aux T A T1 A1, precompile-aux B A1 B1 A2, pi x\ def x N T1 B1 => precompile-aux (F x) A2 (F1 x) A3. precompile-aux (fix N Rno Ty F) A (fix N Rno Ty1 F1) A2 :- !, precompile-aux Ty A Ty1 A1, pi x\ precompile-aux (F x) A1 (F1 x) A2. precompile-aux (match T Rty B) A (match T1 Rty1 B1) A3 :- !, diff --git a/apps/tc/tests/test_proj.v b/apps/tc/tests/test_proj.v index 325438e0e..abca7856e 100644 --- a/apps/tc/tests/test_proj.v +++ b/apps/tc/tests/test_proj.v @@ -3,6 +3,8 @@ From elpi Require Import tc. Set TC NameShortPath. Class C (T : Type) := {f : T -> T}. +Class D (T : nat -> nat) := {g : unit}. +Class E (T : nat) := {ge : unit}. Record r := mkr {car : Type; rf : car -> car}. Canonical Structure c := mkr nat (fun x => x). @@ -10,22 +12,23 @@ Elpi Accumulate TC.Compiler lp:{{ % the goal is to check instances for C are correctly compiled func is-class-C prop ->. is-class-C (pi x\ X x) :- !, pi x\ is-class-C (X x). - is-class-C (tc-C _ _ :- _ as C) :- !, coq.say "Checking"C, if (expected-rule C) true (coq.error "Wrong compilation of" C). - is-class-C (tc-C _ _ as C) :- !, coq.say "Checking"C, if (expected-rule C) true (coq.error "Wrong compilation of" C). - is-class-C _. + :name "is-class-C" + is-class-C (tc.instance _ _ _ _) :- !. + % :name "XX" + % is-class-C (tc-C _ _ :- _ as C) :- !, + % coq.say "Checking"C, if (expected-rule C) true (coq.error "Wrong compilation of" C). + % is-class-C (tc-C _ _ as C) :- !, + % coq.say "Checking"C, if (expected-rule C) true (coq.error "Wrong compilation of" C). + is-class-C C :- coq.error "FAIL" C. - - func expected-rule -> prop. - pred dummy. - :name "x" dummy. :before "tc-adder" tc.add-tc-db _I _G C :- % coq.say "Compiled term is" C, - std.spy(is-class-C C), fail, !. + is-class-C C, fail, !. }}. Module m1. Elpi Accumulate TC.Compiler lp:{{ - :after "x" expected-rule (tc-C {{nat}} _). + :after "is-class-C" is-class-C (tc-C {{nat}} _) :- !. }}. (* reducing the projection statically *) @@ -33,7 +36,7 @@ Module m1. Elpi Accumulate TC.Compiler lp:{{ % removing the previous expected (best should be that the previous rule is local to the module) - :after "x" expected-rule _ :- !, fail. + :after "is-class-C" is-class-C C :- coq.error "FAIL" C, !. }}. (* Elpi Print TC.Compiler "elpi.apps.derive.tests/xxx". *) @@ -41,6 +44,31 @@ Module m1. Goal C (car c). apply _. Qed. End m1. +Module m1'. + Elpi Accumulate TC.Compiler lp:{{ + :after "is-class-C" is-class-C (tc-D {{fun x => x}} _) :- !. + }}. + + Local Instance inst_red: D (rf c). now constructor. Qed. + + Elpi Accumulate TC.Compiler lp:{{ :after "is-class-C" is-class-C C :- coq.error "FAIL" C, !. }}. + Goal D (fun x => x). apply _. Qed. +End m1'. + +Module m1''. + Elpi Accumulate TC.Compiler lp:{{ + :after "is-class-C" is-class-C (tc-E X _ :- [K_]) :- !, name X. + }}. + + (* TODO: the current compiler is too permessive: it replaces rf c 3 *) + (* which contains 1. record reduction 2. beta reduction *) + (* two solutions 1. avid to define a class like that one 2. correctly reduce *) + Local Instance inst_red: E (rf c 3). now constructor. Qed. + Elpi Accumulate TC.Compiler lp:{{ :after "is-class-C" is-class-C C :- coq.error "FAIL" C, !. }}. + + Goal E 3. apply _. Qed. +End m1''. + Module m2. (* Mh, why this fails? *) (* Elpi Accumulate TC.Compiler lp:{{ @@ -48,11 +76,12 @@ Module m2. }}. *) Elpi Accumulate TC.Compiler lp:{{ % TODO: here I am doing to weak check, should make the previous Accumulate succeeds - :after "x" expected-rule X :- !, X = (tc-C Y _ :- [K_]), !. + :after "is-class-C" is-class-C (tc-C X _ :- [K_]) :- !, name X, coq.say K_. }}. (* cannot reduce the projection: c is quantified *) Local Instance inst c: C (car c). now constructor. Qed. + Elpi Accumulate TC.Compiler lp:{{ :after "is-class-C" is-class-C C :- coq.error "FAIL" C, !. }}. (* need to use the chr *) Goal C nat. apply _. Qed. @@ -62,16 +91,63 @@ End m2. Module m3. Elpi Accumulate TC.Compiler lp:{{ - % TODO: here I am doing to weak check, should make the previous Accumulate succeeds - :after "x" expected-rule (tc-C X _) :- !, name X. + :after "is-class-C" is-class-C (tc-C X _) :- !, name X, coq.say K_. }}. (* cannot reduce the projection: c is quantified *) - Instance inst X: C X. now constructor. Qed. + Local Instance inst X: C X. now constructor. Qed. + Elpi Accumulate TC.Compiler lp:{{ :after "is-class-C" is-class-C C :- coq.error "FAIL" C, !. }}. (* need to use the chr *) Goal C nat. apply _. Qed. Goal C (car c). apply _. Qed. (* with local instance for c *) - Goal forall x, C (car x). apply _. Qed. + Elpi Trace Browser. + Goal forall x, C (car x). intros. apply _. Qed. End m3. + +Module m4. + (* test using primitive projection and parametrized record *) + Set Primitive Projections. + Record ofe (SI : Type) := Ofe { + ofe_car1 :> Type; + ofe_car2 :> Type -> Type; + }. + + Definition p := Ofe nat bool (fun x => x). + + Check (eq_refl : (p.(ofe_car1 _)) = bool). + + Elpi Query TC.Solver lp:{{ + % destruct application with primitive projection + % and retrieving the projector number and the record constant + app[primitive (proj P N), (global (const X))] = {{p.(ofe_car1 _)}}, + % get the body of the constant + coq.env.const X (some (app[H | Args])) XTy, + coq.safe-dest-app XTy _ XTyAg, + % getting the projection of the constant + std.assert! (std.nth N Args {{bool}}) "Invalid proj", + % creating a rocq-term in elpi equivalent to the original one + % but using its canonical projection + coq.env.primitive-projection? P C _, + std.append ([global (const C) | XTyAg]) [global (const X)] RR, + std.assert-ok!(coq.typecheck (app RR) _) "error", + true. + }}. + + (* Elpi Accumulate TC.Compiler lp:{{ + :after "x" expected-rule (tc-C N (app[_, N])) :- !, name N. + }}. *) + + Local Instance inst2 c: C c. now constructor. Qed. + + Goal forall x y, C (@ofe_car1 x y). + intros x y. apply _. Qed. + + Goal forall x y, C (@ofe_car2 x y x). + intros x y. apply _. Qed. +End m4. + + + + From e846e61274b1aaa28fa537bb11a0cb29d858d24f Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Wed, 10 Jun 2026 15:43:08 +0200 Subject: [PATCH 19/62] proj-reducer for names --- apps/tc/elpi/ho_precompile.elpi | 2 ++ 1 file changed, 2 insertions(+) diff --git a/apps/tc/elpi/ho_precompile.elpi b/apps/tc/elpi/ho_precompile.elpi index e343adca3..afb8c7859 100644 --- a/apps/tc/elpi/ho_precompile.elpi +++ b/apps/tc/elpi/ho_precompile.elpi @@ -74,6 +74,8 @@ namespace tc { coq.env.const R O Ty, coq.safe-dest-app Ty _ TyAg, proj-reducer-aux R P N O TyAg T. + proj-reducer P _ Ag X T :- name X, !, build-proj-term P Ag X T. + % proj-reducer P _ Ag R T :- build-proj-term P Ag R T. From cf9f7c2ad8330e5c4498acc8d336febb9b13917f Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Tue, 16 Jun 2026 10:43:19 +0200 Subject: [PATCH 20/62] wip cs.elpi --- apps/tc/elpi/compiler1.elpi | 2 +- apps/tc/elpi/create_tc_predicate.elpi | 6 +- apps/tc/elpi/cs.elpi | 178 ++++++++++++++++++++++++++ apps/tc/elpi/ho_precompile.elpi | 84 +----------- apps/tc/elpi/solver.elpi | 2 +- apps/tc/elpi/tc_aux.elpi | 96 ++++++++++++-- apps/tc/tests/test_proj.v | 30 ++++- apps/tc/theories/tc.v | 6 + 8 files changed, 310 insertions(+), 94 deletions(-) create mode 100644 apps/tc/elpi/cs.elpi diff --git a/apps/tc/elpi/compiler1.elpi b/apps/tc/elpi/compiler1.elpi index 2075f1f56..f33b4deb1 100644 --- a/apps/tc/elpi/compiler1.elpi +++ b/apps/tc/elpi/compiler1.elpi @@ -94,7 +94,7 @@ namespace tc { remove-inst InstGR :- tc.get-full-path InstGR ClauseName, std.once(tc.instance _ InstGR ClassGR Locality), - tc.gref->pred-name ClassGR PredName, + tc.gref->pred-name "tc" ClassGR PredName, coq.env.typeof ClassGR ClassTy, coq.elpi.predicate PredName {build-args ClassTy} Clause, tc.remove-clause ClauseName Clause Locality. diff --git a/apps/tc/elpi/create_tc_predicate.elpi b/apps/tc/elpi/create_tc_predicate.elpi index 6f204f353..68fa86989 100644 --- a/apps/tc/elpi/create_tc_predicate.elpi +++ b/apps/tc/elpi/create_tc_predicate.elpi @@ -21,7 +21,7 @@ add-class-gr SearchMode ClassGR SMR :- tc.get-elpi-mode ClassGR SMR EM SM, if (std.forall EM (m\ sigma a s\ m = pr a s, a = out)) (true) ( std.fold EM "" (m\s\r\ sigma a s'\ m = pr a s', if (a = in) (calc (s ^ " 10") r) (calc (s ^ " _") r)) Indexing), - tc.gref->pred-name ClassGR PredName, + tc.gref->pred-name "tc" ClassGR PredName, get-class-locality Locality, Locality => ( coq.elpi.add-predicate "tc.db" Indexing PredName EM, @@ -64,7 +64,7 @@ declare-class-in-coq ClassGR :- % CAVEAT: this triggers the observer coq.TC.declare-class ClassGR, attr->search-mode SearchMode, - tc.gref->pred-name ClassGR PredName, + tc.gref->pred-name "tc" ClassGR PredName, % HACK: we override the clauses added by the observer, since it does not know % the SearchMode. get-class-locality Locality, @@ -106,7 +106,7 @@ namespace eta-reduction-aux { compile ClassGR (sort _) tt L (pi sol new-term\ Cl new-term sol) :- pi solution new-term\ sigma Args Args' Q Q'\ std.do![ - tc.gref->pred-name ClassGR PredName, + tc.gref->pred-name "tc" ClassGR PredName, std.rev [solution | L] Args, replace Args new-term Args' T, coq.elpi.predicate PredName Args Q, diff --git a/apps/tc/elpi/cs.elpi b/apps/tc/elpi/cs.elpi new file mode 100644 index 000000000..4f57a34e3 --- /dev/null +++ b/apps/tc/elpi/cs.elpi @@ -0,0 +1,178 @@ +namespace cs { + namespace compiler { + func omap' option A, (func A ->). + omap' (some A) F :- F A. + omap' none _. + + namespace record { + func proj-to-pname constant -> string. + proj-to-pname P S :- + tc.gref->pred-name "canstr" (const P) S. + + func proj-to-args constant -> list (pair argument_mode string). + proj-to-args _ [MT, MT] :- MT = pr out "term". + % coq.env.projection? C N, + % std.list.init N (x\y\ y = MT) L, + % std.append L [MT, MT] R. + + % [make-pred-sig C Db] + % C the projection's constant + % Db the name of the database in which adding the predicate + func make-pred-sig string, constant ->. + make-pred-sig Db C :- + proj-to-pname C S, + proj-to-args C A, + coq.elpi.add-predicate Db _ S A. + + func create-cs-pred i:term. + create-cs-pred (global (indt R)) :- + coq.env.projections R P, + std.forall P (x\ omap' x (make-pred-sig "tc.db")). + } + namespace cs { + func map-filter2 list A, list B, (func A, B -> C) -> list C. + map-filter2 [] [_|_] _ _ :- std.fatal-error "map2 on lists of different length". + map-filter2 [_|_] [] _ _ :- std.fatal-error "map2 on lists of different length". + map-filter2 [] [] _ []. + map-filter2 [X|XS] [Y|YS] F [Z|ZS] :- F X Y Z, !, map-filter2 XS YS F ZS. + map-filter2 [_|XS] [_|YS] F ZS :- !, map-filter2 XS YS F ZS. + + :index (_ 1) + func get-projn int, list (option constant) -> list (pair int constant). + get-projn _ [] []. + get-projn M [some X|Xs] [pr M X|Ys] :- N is M + 1, get-projn N Xs Ys. + get-projn M [none|Xs] Ys :- N is M + 1, get-projn N Xs Ys. + + + + func get-proj term -> list (pair int constant). + get-proj (prod _ _ B) Pg :- !, pi x\ get-proj (B x) Pg. + get-proj (global (indt R)) Pg :- + coq.env.indt R _ N _ _ _ _, + coq.env.projections R P, get-projn N P Pg. + + func is-uvar term ->. + + % [compile C P Ag T R] + % P = projection + % Ag = args list of the can struct + % I = carrier + % CS = canonical structure + % R = the compiled rule for the cs + func compile constant, term, term -> prop. + compile P I CS R :- + record.proj-to-pname P PN, + coq.elpi.predicate PN [I, CS] R. + + func mk-rule bool, prop, list prop -> prop. + mk-rule _ P [] P :- !. + mk-rule tt P R (P :- R). + mk-rule ff P R (R => P). + + func work-proj constant, int, list term, term, nat -> term, nat. + work-proj P _ Ag R N (tc.maybe-proj (app[global (const P) | Ag']) []) (s N) :- is-uvar R, !, + std.append Ag [R] Ag'. + work-proj P PN Ag R N T' N :- tc.proj-reducer P PN Ag R T', !. + work-proj P _ Ag R N (tc.maybe-proj (app[global (const P) | Ag']) []) (s N) :- !, + std.append Ag [R] Ag'. + + func precompile term, nat -> term, nat. + :name "cs-precompile" + precompile T N T' N' :- + tc.maybe-projection T P PN Ag R, !, + work-proj P PN Ag R N T' N'. + + precompile X A Y A :- name X, !, X = Y, !. % avoid loading "precompile x A x A" at binders + precompile (global _ as C) A C A :- !. + precompile (pglobal _ _ as C) A C A :- !. + precompile (sort _ as C) A C A :- !. + precompile (fun N T F) A (fun N T1 F1) A2 :- !, + precompile T A T1 A1, pi x\ precompile (F x) A1 (F1 x) A2. + precompile (let N T B F) A (let N T1 B1 F1) A3 :- !, + precompile T A T1 A1, precompile B A1 B1 A2, pi x\ precompile (F x) A2 (F1 x) A3. + precompile (prod N T F) A (prod N T1 F1) A2 :- !, + precompile T A T1 A1, (pi x\ precompile (F x) A1 (F1 x) A2). + precompile (app L) A (app L1) A1 :- !, std.fold-map L A precompile L1 A1. + precompile (fix N Rno Ty F) A (fix N Rno Ty1 F1) A2 :- !, + precompile Ty A Ty1 A1, pi x\ precompile (F x) A1 (F1 x) A2. + precompile (match T Rty B) A (match T1 Rty1 B1) A3 :- !, + precompile T A T1 A1, precompile Rty A1 Rty1 A2, std.fold-map B A2 precompile B1 A3. + precompile (primitive _ as C) A C A :- !. + precompile (uvar M L as X) A W A1 :- var X, !, std.fold-map L A precompile L1 A1, coq.mk-app-uvar M L1 W. + % when used in CHR rules + precompile (uvar X L) A (uvar X L1) A1 :- std.fold-map L A precompile L1 A1. + + + func decompile term, pair (list term) (list prop) -> term, pair (list term) (list prop). + :name "cs-decompile" + decompile (tc.maybe-proj (app[global (const C) | Ag']) S) (pr [X|XS] L1) Y (pr XS [NL|L1]) :- !, + name Y X S, + record.proj-to-pname C PN, + coq.elpi.predicate PN [{std.last Ag'}, Y] NL. + + decompile X A Y A :- name X, !, X = Y, !. % avoid loading "decompile x A x A" at binders + decompile (global _ as C) A C A :- !. + decompile (pglobal _ _ as C) A C A :- !. + decompile (sort _ as C) A C A :- !. + decompile (fun N T F) A (fun N T1 F1) A2 :- !, + decompile T A T1 A1, pi x\ decompile (F x) A1 (F1 x) A2. + decompile (let N T B F) A (let N T1 B1 F1) A3 :- !, + decompile T A T1 A1, decompile B A1 B1 A2, pi x\ decompile (F x) A2 (F1 x) A3. + decompile (prod N T F) A (prod N T1 F1) A2 :- !, + decompile T A T1 A1, (pi x\ decompile (F x) A1 (F1 x) A2). + decompile (app L) A (app L1) A1 :- !, std.fold-map L A decompile L1 A1. + decompile (fix N Rno Ty F) A (fix N Rno Ty1 F1) A2 :- !, + decompile Ty A Ty1 A1, pi x\ decompile (F x) A1 (F1 x) A2. + decompile (match T Rty B) A (match T1 Rty1 B1) A3 :- !, + decompile T A T1 A1, decompile Rty A1 Rty1 A2, std.fold-map B A2 decompile B1 A3. + decompile (primitive _ as C) A C A :- !. + decompile (uvar M L as X) A W A1 :- var X, !, std.fold-map L A decompile L1 A1, coq.mk-app-uvar M L1 W. + % when used in CHR rules + decompile (uvar X L) A (uvar X L1) A1 :- std.fold-map L A decompile L1 A1. + + % [load-nestedp N B S T P L C] + % N is the number of pi to load + % B is the pos/neg position of the term being compiled + % S is the name of the predicate + % T is the argument (with N problematic subterms) + % P is the instance of the record to be used + % L is the list of pi accumulated terms + % C is the created clause + func load-nestedp nat, bool, string, term, term, list term -> prop. + load-nestedp z B S T P L C :- + decompile T (pr L []) T' (pr _ Pm), + coq.elpi.predicate S [T', P] Hd, + mk-rule B Hd {std.rev Pm} C. + load-nestedp (s N) B S T P L (pi x\ C x) :- pi x\ load-nestedp N B S T P [x|L] (C x). + + % [compiler B IC CS Ag P L C] + % B is the pos/neg position of the term + % IC is the projection being compiled together with its number + % CS is the instance of the structure + % Ag is the term being consumed for compilation (i.e. the implementation of CS) + % P is the list of premises (TODO: should be removed?) + % L is the list of abstractions: the arguments of CS + % C is the final rule + func compiler bool, (pair int constant), term, term, list prop, list term -> prop. + compiler B (pr N P) CS (app[_|Ag]) L A Rs :- !, + coq.mk-app CS {std.rev A} CS', + record.proj-to-pname P PN, + std.nth N Ag I, + precompile I z I' NPb, + load-nestedp NPb B PN I' CS' [] Rs. + compiler B P CS (fun N Ty Bo') L A (pi x\ R x) :- + @pi-decl N Ty x\ (is-uvar x :- !) => + compiler B P CS (Bo' x) L [x|A] (R x). + + func main term ->. + main (global (const C) as T) :- + coq.env.const C (some Bo) Ty, + get-proj Ty P, + std.forall P (x\ sigma R\ compiler tt x T Bo [] [] R, tc.add-tc-db _ _ R). + } + } + + namespace solver { + + } +} \ No newline at end of file diff --git a/apps/tc/elpi/ho_precompile.elpi b/apps/tc/elpi/ho_precompile.elpi index afb8c7859..356ceb48e 100644 --- a/apps/tc/elpi/ho_precompile.elpi +++ b/apps/tc/elpi/ho_precompile.elpi @@ -1,83 +1,7 @@ namespace tc { shorten tc.{r-ar, range-arity}. - func split-last list A -> list A, A. - split-last [X] [] X :- !. - split-last [X|Xs] [X|Y] Z :- split-last Xs Y Z. - - func list.pos list A, A -> int. - list.pos [A|_] A 0 :- !. - list.pos [_|L] A N :- list.pos L A N', N is N' + 1. - namespace precomp { - func get-record int, term -> inductive. - get-record 0 (prod _ (app [global (indt I) | _]) _) I :- !. - get-record 0 (prod _ (global (indt I)) _) I :- !. - get-record N (prod _ _ Bo) T :- N > 0, N' is N - 1, - pi x\ get-record N' (Bo x) T, !. - - func get-proj-nb constant -> int. - get-proj-nb C N :- - coq.env.projection? C Nx, - coq.env.const C _ Ty, - get-record Nx Ty I, - coq.env.projections I P, - list.pos P (some C) M, - N is M + Nx. - - % [maybe-projection T C N A R] - % check if the head of T is the application of a projection - % for example T = app[P, ARGS..., R] - % where P is the projector, ARGS are the parameter of the projector - % R is the record to project - % C is the compatibily constant of the projector P - % N is the number position of C - % A is the list of argument applied to the projection (except for the record itself) - % R is the record - func maybe-projection term -> constant, int, list term, term. - :name "maybe-projection" - maybe-projection (app [primitive (proj P N), R]) C N A R :- - coq.env.primitive-projection? P C _, - std.assert-ok!(coq.typecheck R Ty) "err", - coq.safe-dest-app Ty _ A. - % TODO: should check that C is fully applied - maybe-projection (app [global (const C) | Args]) C N A R :- - coq.env.projection? C _, !, - get-proj-nb C N, std.assert!(split-last Args A R) "err: empty list". - - func build-proj-term constant, list term, term -> term. - build-proj-term P Ag C (app[global (const P) | Ag']) :- - std.append Ag [C] Ag'. - - % [proj-reducer-aux R P N O L T] - % R is the record constant - % P is the compatibility constant of the projector - % N is the projection number - % O is the optional body of the projected constant - % L are the arguments of the projection - % T is the projected terms - :index(_ _ _ 1) - func proj-reducer-aux constant, constant, int, option term, list term -> term. - :name "proj-reducer-aux" - proj-reducer-aux _ _ N (some (app [_|L])) _ T :- std.nth N L T. - proj-reducer-aux R P _ none Ag T :- build-proj-term P Ag (global (const R)) T. - - % [proj-reducer P N Ag R T] - % P is the projector constant - % N is the number of P - % Ag is the arguments applied to the projector (except for the record) - % R is the record - % T is the reduced term - func proj-reducer constant, int, list term, term -> term. - :name "proj-reducer" - proj-reducer P N _ (global (const R)) T :- !, - coq.env.const R O Ty, - coq.safe-dest-app Ty _ TyAg, - proj-reducer-aux R P N O TyAg T. - proj-reducer P _ Ag X T :- name X, !, build-proj-term P Ag X T. - - % proj-reducer P _ Ag R T :- build-proj-term P Ag R T. - namespace instance { % Tells if the current name is a bound variables @@ -193,7 +117,7 @@ namespace tc { func work-proj constant, int, list term, term, nat -> term, nat. work-proj P _ Ag R N (tc.maybe-proj (app[global (const P) | Ag']) X) (s N) :- is-uvar R, !, std.append Ag [R] Ag', free-var X. - work-proj P PN Ag R N T' N :- proj-reducer P PN Ag R T', !. + work-proj P PN Ag R N T' N :- tc.proj-reducer P PN Ag R T', !. work-proj P _ Ag R N (tc.maybe-proj (app[global (const P) | Ag']) X) (s N) :- !, std.append Ag [R] Ag', free-var X. % @@ -205,7 +129,7 @@ namespace tc { precompile-aux _ (sort _ as C) A C A :- !. :name "precomp-proj-inst" precompile-aux _ T N T' N' :- - maybe-projection T P PN Ag R, !, + tc.maybe-projection T P PN Ag R, !, work-proj P PN Ag R N T' N'. % Detect maybe-eta term @@ -332,7 +256,7 @@ namespace tc { func work-proj constant, int, list term, term -> term. work-proj P _ Ag (uvar as R) (tc.maybe-proj (app[global (const P) | Ag']) X) :- !, std.append Ag [R] Ag', names X. - work-proj P PN Ag R T' :- proj-reducer P PN Ag R T', !. + work-proj P PN Ag R T' :- tc.proj-reducer P PN Ag R T', !. work-proj P _ Ag R (tc.maybe-proj (app[global (const P) | Ag']) X) :- std.append Ag [R] Ag', names X. @@ -343,7 +267,7 @@ namespace tc { precompile-aux (sort _ as C) A C A :- !. :name "precomp-proj-goal" precompile-aux T A T' A :- - maybe-projection T P PN Ag R, !, + tc.maybe-projection T P PN Ag R, !, work-proj P PN Ag R T'. % Detect maybe-eta term diff --git a/apps/tc/elpi/solver.elpi b/apps/tc/elpi/solver.elpi index ebbcaf815..b3b2b5cf7 100644 --- a/apps/tc/elpi/solver.elpi +++ b/apps/tc/elpi/solver.elpi @@ -11,7 +11,7 @@ namespace tc { tc.compile.goal Goal Goal' PostProcess, !, coq.safe-dest-app Goal' (global TC) TL', std.append TL' [Proof] TL, !, - coq.elpi.predicate {tc.gref->pred-name TC} TL Q. + coq.elpi.predicate {tc.gref->pred-name "tc" TC} TL Q. type tc.mode_fail term. diff --git a/apps/tc/elpi/tc_aux.elpi b/apps/tc/elpi/tc_aux.elpi index 7953ef72e..8a174276a 100644 --- a/apps/tc/elpi/tc_aux.elpi +++ b/apps/tc/elpi/tc_aux.elpi @@ -104,19 +104,22 @@ namespace tc { get-TC-of-inst-type T Hd, coq.TC.class? Hd. - % TC preds are on the form tc-[PATH_TO_TC].tc-[TC-Name] - func gref->pred-name gref -> string. - gref->pred-name Gr S :- + % [gref->pred-name P G S] + % takes a prefix P and a gref G + % returns S = P-[PATH_TO_G].P-[TC-Name] + % NOTE: P should start with lower case letter + func gref->pred-name string, gref -> string. + gref->pred-name P G S :- if (tc.is-option-active tc.oTC-clauseNameShortName) (Path = "") - (coq.gref->path Gr [Hd | Tl], + (coq.gref->path G [Hd | Tl], if (Hd = "Coq") (Hd' = "Corelib") (Hd' = Hd), std.string.concat "." [Hd'|Tl] Path', - Path is Path' ^ ".tc-"), + Path is Path' ^ "." ^ P ^ "-"), % CAVEAT : Non-ascii caractars can't be part of a pred % name, we replace ö with o - rex.replace "ö" "o" {coq.gref->id Gr} GrStr, - S is "tc-" ^ Path ^ GrStr. + rex.replace "ö" "o" {coq.gref->id G} GrStr, + S is P ^ "-" ^ Path ^ GrStr. func get-mode gref -> list string. get-mode ClassGR M :- tc.class ClassGR _ _ M, !. @@ -143,7 +146,7 @@ namespace tc { make-tc Goal Sol RuleBody IsPositive Rule :- coq.safe-dest-app Goal Class Args, get-TC-of-inst-type Class ClassGR, - gref->pred-name ClassGR ClassStr, + gref->pred-name "tc" ClassGR ClassStr, std.append Args [Sol] ArgsSol, coq.elpi.predicate ClassStr ArgsSol RuleHead, make-tc.aux IsPositive Sol RuleHead RuleBody Rule. @@ -213,6 +216,82 @@ namespace tc { time-it Opt P Msg :- time-is-active Opt, !, time-res P Time Res, build-msg Res Msg Msg', time-pp Msg' Time, Res. time-it _ P _ :- P. + func split-last list A -> list A, A. + split-last [X] [] X :- !. + split-last [X|Xs] [X|Y] Z :- split-last Xs Y Z. + + func list.pos list A, A -> int. + list.pos [A|_] A 0 :- !. + list.pos [_|L] A N :- list.pos L A N', N is N' + 1. + + func get-record int, term -> inductive. + get-record 0 (prod _ (app [global (indt I) | _]) _) I :- !. + get-record 0 (prod _ (global (indt I)) _) I :- !. + get-record N (prod _ _ Bo) T :- N > 0, N' is N - 1, + pi x\ get-record N' (Bo x) T, !. + + func get-proj-nb constant -> int. + get-proj-nb C N :- + coq.env.projection? C Nx, + coq.env.const C _ Ty, + get-record Nx Ty I, + coq.env.projections I P, + list.pos P (some C) M, + N is M + Nx. + + % [maybe-projection T C N A R] + % check if the head of T is the application of a projection + % for example T = app[P, ARGS..., R] + % where P is the projector, ARGS are the parameter of the projector + % R is the record to project + % C is the compatibily constant of the projector P + % N is the number position of C + % A is the list of argument applied to the projection (except for the record itself) + % R is the record + func maybe-projection term -> constant, int, list term, term. + :name "maybe-projection" + maybe-projection (app [primitive (proj P N), R]) C N A R :- + coq.env.primitive-projection? P C _, + std.assert-ok!(coq.typecheck R Ty) "err", + coq.safe-dest-app Ty _ A. + % TODO: should check that C is fully applied + maybe-projection (app [global (const C) | Args]) C N A R :- + coq.env.projection? C _, !, + get-proj-nb C N, std.assert!(split-last Args A R) "err: empty list". + + func build-proj-term constant, list term, term -> term. + build-proj-term P Ag C (app[global (const P) | Ag']) :- + std.append Ag [C] Ag'. + + + % [proj-reducer-aux R P N O L T] + % R is the record constant + % P is the compatibility constant of the projector + % N is the projection number + % O is the optional body of the projected constant + % L are the arguments of the projection + % T is the projected terms + :index(_ _ _ 1) + func proj-reducer-aux constant, constant, int, option term, list term -> term. + :name "proj-reducer-aux" + proj-reducer-aux _ _ N (some (app [_|L])) _ T :- std.nth N L T. + proj-reducer-aux R P _ none Ag T :- build-proj-term P Ag (global (const R)) T. + + % [proj-reducer P N Ag R T] + % P is the projector constant + % N is the number of P + % Ag is the arguments applied to the projector (except for the record) + % R is the record + % T is the reduced term + func proj-reducer constant, int, list term, term -> term. + :name "proj-reducer" + proj-reducer P N _ (global (const R)) T :- !, + coq.env.const R O Ty, + coq.safe-dest-app Ty _ TyAg, + proj-reducer-aux R P N O TyAg T. + proj-reducer P _ Ag X T :- name X, !, build-proj-term P Ag X T. + + kind range-arity type. type r-ar nat -> nat -> range-arity. @@ -235,4 +314,5 @@ namespace tc { term -> % The current precompiled subterm list term -> % The list of FV in the precomp subterm term. + } diff --git a/apps/tc/tests/test_proj.v b/apps/tc/tests/test_proj.v index abca7856e..29e583db2 100644 --- a/apps/tc/tests/test_proj.v +++ b/apps/tc/tests/test_proj.v @@ -114,6 +114,8 @@ Module m4. ofe_car2 :> Type -> Type; }. + Canonical Structure ss := Ofe nat nat (fun x => x). + Definition p := Ofe nat bool (fun x => x). Check (eq_refl : (p.(ofe_car1 _)) = bool). @@ -147,7 +149,33 @@ Module m4. Goal forall x y, C (@ofe_car2 x y x). intros x y. apply _. Qed. End m4. - +From elpi.apps Require Import db. + +From elpi.apps.tc.elpi Extra Dependency "tc_aux.elpi" as tc_aux. +From elpi.apps.tc.elpi Extra Dependency "base.elpi" as base. +From elpi.apps.tc.elpi Extra Dependency "cs.elpi" as cs. +Elpi Command B. +Elpi Accumulate Db tc.db. +Elpi Accumulate Db tc_options.db. +(* Elpi Accumulate File base. *) +Elpi Accumulate File tc_aux. +Elpi Accumulate File cs. + +Elpi Trace Browser. +Elpi Query lp:{{ cs.compiler.record.create-cs-pred {{r}}. }}. +Set Printing All. +Elpi Query lp:{{ cs.compiler.cs.main {{c}}. }}. + +Elpi Print TC.Compiler "elpi.apps.derive.tests/xxx". + +Definition rrf (H1 H2 : r) := (fun '(x,y) => (rf H1 x, rf H2 y)). +Canonical Structure rr (H1 H2 H3 : r) := mkr (car H1 * car H2) (rrf H1 H2). + +Elpi Trace Browser. +Elpi Query lp:{{ cs.compiler.cs.main {{rr}}. }}. +Elpi Print TC.Compiler "elpi.apps.derive.tests/xxx". +Goal exists x, car x = (nat * nat)%type. +Proof. eexists. auto. \ No newline at end of file diff --git a/apps/tc/theories/tc.v b/apps/tc/theories/tc.v index 31cc2d4b9..d9cb09ca5 100644 --- a/apps/tc/theories/tc.v +++ b/apps/tc/theories/tc.v @@ -13,6 +13,7 @@ From elpi.apps.tc.elpi Extra Dependency "unif.elpi" as unif. From elpi.apps.tc.elpi Extra Dependency "ho_link.elpi" as ho_link. From elpi.apps.tc.elpi Extra Dependency "solver.elpi" as solver. From elpi.apps.tc.elpi Extra Dependency "create_tc_predicate.elpi" as create_tc_predicate. +From elpi.apps.tc.elpi Extra Dependency "cs.elpi" as cs. From elpi.apps Require Import db. From elpi.apps Require Export add_commands. @@ -200,3 +201,8 @@ Set Warnings "elpi". Elpi TC.AddAllClasses. Elpi TC.AddAllInstances. + +Elpi Tactic cs. +Elpi Accumulate Db tc.db. +Elpi Accumulate File tc_aux. +Elpi Accumulate File cs. From 5255269d1311412af1d8920b9f741ad62df20640 Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Tue, 16 Jun 2026 15:19:18 +0200 Subject: [PATCH 21/62] fix tests --- apps/tc/tests/test_proj.v | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/apps/tc/tests/test_proj.v b/apps/tc/tests/test_proj.v index 29e583db2..baa31c769 100644 --- a/apps/tc/tests/test_proj.v +++ b/apps/tc/tests/test_proj.v @@ -167,7 +167,7 @@ Elpi Query lp:{{ cs.compiler.record.create-cs-pred {{r}}. }}. Set Printing All. Elpi Query lp:{{ cs.compiler.cs.main {{c}}. }}. -Elpi Print TC.Compiler "elpi.apps.derive.tests/xxx". +(* Elpi Print TC.Compiler "elpi.apps.derive.tests/xxx". *) Definition rrf (H1 H2 : r) := (fun '(x,y) => (rf H1 x, rf H2 y)). Canonical Structure rr (H1 H2 H3 : r) := mkr (car H1 * car H2) (rrf H1 H2). @@ -175,7 +175,7 @@ Canonical Structure rr (H1 H2 H3 : r) := mkr (car H1 * car H2) (rrf H1 H2). Elpi Trace Browser. Elpi Query lp:{{ cs.compiler.cs.main {{rr}}. }}. -Elpi Print TC.Compiler "elpi.apps.derive.tests/xxx". +(* Elpi Print TC.Compiler "elpi.apps.derive.tests/xxx". *) Goal exists x, car x = (nat * nat)%type. -Proof. eexists. auto. \ No newline at end of file +Proof. eexists. auto. Unshelve. apply c. Qed. \ No newline at end of file From 05c67b81adb620dc45443cf9d819aee193c5379d Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Tue, 16 Jun 2026 16:58:35 +0200 Subject: [PATCH 22/62] remove empty line --- apps/tc/elpi/cs.elpi | 2 -- 1 file changed, 2 deletions(-) diff --git a/apps/tc/elpi/cs.elpi b/apps/tc/elpi/cs.elpi index 4f57a34e3..b75382949 100644 --- a/apps/tc/elpi/cs.elpi +++ b/apps/tc/elpi/cs.elpi @@ -42,8 +42,6 @@ namespace cs { get-projn _ [] []. get-projn M [some X|Xs] [pr M X|Ys] :- N is M + 1, get-projn N Xs Ys. get-projn M [none|Xs] Ys :- N is M + 1, get-projn N Xs Ys. - - func get-proj term -> list (pair int constant). get-proj (prod _ _ B) Pg :- !, pi x\ get-proj (B x) Pg. From 70ba27c646574d5b50e3c4f780b5ff84cb2aed4f Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Tue, 16 Jun 2026 17:01:04 +0200 Subject: [PATCH 23/62] remove empty line --- apps/tc/elpi/cs.elpi | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/apps/tc/elpi/cs.elpi b/apps/tc/elpi/cs.elpi index b75382949..9d83ad3cb 100644 --- a/apps/tc/elpi/cs.elpi +++ b/apps/tc/elpi/cs.elpi @@ -6,8 +6,7 @@ namespace cs { namespace record { func proj-to-pname constant -> string. - proj-to-pname P S :- - tc.gref->pred-name "canstr" (const P) S. + proj-to-pname P S :- tc.gref->pred-name "canstr" (const P) S. func proj-to-args constant -> list (pair argument_mode string). proj-to-args _ [MT, MT] :- MT = pr out "term". From 8f657f041692b5ebd822a9fce55413ef43b0d9c8 Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Wed, 17 Jun 2026 11:48:07 +0200 Subject: [PATCH 24/62] add main to cs --- apps/tc/elpi/cs.elpi | 5 +++++ apps/tc/theories/tc.v | 3 +++ 2 files changed, 8 insertions(+) diff --git a/apps/tc/elpi/cs.elpi b/apps/tc/elpi/cs.elpi index 9d83ad3cb..062658d4e 100644 --- a/apps/tc/elpi/cs.elpi +++ b/apps/tc/elpi/cs.elpi @@ -172,4 +172,9 @@ namespace cs { namespace solver { } + + pred main list argument. + :name "cs-main" + main [str "class", trm T] :- cs.compiler.record.create-cs-pred T. + main [str "cs", trm T] :- cs.compiler.cs.main T. } \ No newline at end of file diff --git a/apps/tc/theories/tc.v b/apps/tc/theories/tc.v index d9cb09ca5..dd06546dc 100644 --- a/apps/tc/theories/tc.v +++ b/apps/tc/theories/tc.v @@ -206,3 +206,6 @@ Elpi Tactic cs. Elpi Accumulate Db tc.db. Elpi Accumulate File tc_aux. Elpi Accumulate File cs. +Elpi Accumulate lp:{{ + main L :- cs.main L. +}}. \ No newline at end of file From c9168030cb8d4215dccee3997cfc9d389f489a92 Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Wed, 17 Jun 2026 15:24:45 +0200 Subject: [PATCH 25/62] imporve cs comment --- apps/tc/elpi/cs.elpi | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/apps/tc/elpi/cs.elpi b/apps/tc/elpi/cs.elpi index 062658d4e..0ba319f5b 100644 --- a/apps/tc/elpi/cs.elpi +++ b/apps/tc/elpi/cs.elpi @@ -147,8 +147,8 @@ namespace cs { % IC is the projection being compiled together with its number % CS is the instance of the structure % Ag is the term being consumed for compilation (i.e. the implementation of CS) - % P is the list of premises (TODO: should be removed?) - % L is the list of abstractions: the arguments of CS + % L is the list of premises (TODO: should be removed?) + % A is the list of abstractions: the arguments of CS % C is the final rule func compiler bool, (pair int constant), term, term, list prop, list term -> prop. compiler B (pr N P) CS (app[_|Ag]) L A Rs :- !, @@ -158,7 +158,7 @@ namespace cs { precompile I z I' NPb, load-nestedp NPb B PN I' CS' [] Rs. compiler B P CS (fun N Ty Bo') L A (pi x\ R x) :- - @pi-decl N Ty x\ (is-uvar x :- !) => + @pi-decl N Ty x\ (is-uvar x :- !) ==> compiler B P CS (Bo' x) L [x|A] (R x). func main term ->. From 75e62c544159f0a6f7b9ceb43116aaba717ccaed Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Wed, 17 Jun 2026 15:25:35 +0200 Subject: [PATCH 26/62] extract common code in ho_precompile for reusability --- apps/tc/elpi/ho_precompile.elpi | 570 +++++++++++++++----------------- apps/tc/tests/test.v | 8 +- 2 files changed, 267 insertions(+), 311 deletions(-) diff --git a/apps/tc/elpi/ho_precompile.elpi b/apps/tc/elpi/ho_precompile.elpi index 356ceb48e..985ff12fe 100644 --- a/apps/tc/elpi/ho_precompile.elpi +++ b/apps/tc/elpi/ho_precompile.elpi @@ -1,311 +1,267 @@ -namespace tc { +namespace tc.precomp { shorten tc.{r-ar, range-arity}. + % Tells if the current name is a bound variables + pred is-name o:term. + % Tells if the current name stands for a uvar + pred is-uvar o:term. + + :index (_ _ 1) + func may-contract-to list term, term, term ->. + may-contract-to [] N N :- !. + may-contract-to L N (app [V|S]) :- (var V; is-uvar V), !, + std.forall [N|L] (x\ std.exists! S (may-contract-to [] x)). + may-contract-to L N (app [N|A]) :- + std.length A {std.length L}, + std.forall2 {std.rev L} A (may-contract-to []). + may-contract-to L N (fun _ _ B) :- + pi x\ may-contract-to [x|L] N (B x). + + :index (_ 1) + func occurs-rigidly term, term ->. + occurs-rigidly N N :- name N, !. + occurs-rigidly _ (app [N|_]) :- (var N; is-uvar N), !, fail. + occurs-rigidly _ (app [N|_]) :- var N, !, fail. + occurs-rigidly N (app A) :- std.exists! A (occurs-rigidly N). + occurs-rigidly N (fun _ _ B) :- pi x\ occurs-rigidly N (B x). + + func maybe-eta-aux term, list term ->. + % TODO: maybe var V _ X succeeds and X is not empty, should therefore + % also take into account X? + maybe-eta-aux (app[V|S]) L :- (var V; is-uvar V), !, + std.forall L (x\ std.exists! S (y\ may-contract-to [] x y)). + maybe-eta-aux (app [_|A]) L :- + SplitLen is {std.length A} - {std.length L}, + split-at-not-fatal SplitLen A HD TL, + std.forall L (x\ not (std.exists! HD (occurs-rigidly x))), + std.forall2 {std.rev L} TL (may-contract-to []). + maybe-eta-aux (fun _ _ B) L :- + pi x\ maybe-eta-aux (B x) [x|L]. + + func maybe-eta term ->. + maybe-eta (fun _ _ B) :- pi x\ maybe-eta-aux (B x) [x]. + + % [split-pf B L1 L2 L3 L4] + % splits the list of L1 into L3 and L4, so that: + % **∀ e \in L3, F i** and **L2 ∩ L3 = ∅** + func split-pf (pred term ->), list term, list term -> list term, list term. + split-pf F [] _ [] [] :- !. + split-pf F [X|Xs] Old [X|Ys] L :- F X, not (std.mem! Old X), !, split-pf F Xs [X|Old] Ys L. + split-pf F Xs _ [] Xs. + + % [work-proj F P PN Ag R N T N'] + % F is a function returning the scope of the current term + % P, PN are the constant and the proj number + % Ag are the argument of the projector (except for the record) + % R is the record + % N is the hole counter + % T is the new term + % N' is the updated counter + func work-proj (func -> list term), constant, int, list term, term, nat -> term, nat. + work-proj F P _ Ag R N (tc.maybe-proj (app[global (const P) | Ag']) X) (s N) :- (var R; is-uvar R), !, + std.append Ag [R] Ag', F X. + work-proj _ P PN Ag R N T' N :- tc.proj-reducer P PN Ag R T', !. + work-proj F P _ Ag R N (tc.maybe-proj (app[global (const P) | Ag']) X) (s N) :- !, + std.append Ag [R] Ag', F X. + + namespace instance { + + func free-var -> list term. + free-var L :- + std.findall (is-name _) T, + std.map T (x\y\ x = is-name y) L. + + kind positivity type. + type is_pos positivity. + type is_neg positivity. + type is_neg_fix positivity. + + :index (1 _) + func neg positivity -> positivity. + neg is_pos is_neg :- !. + neg is_neg is_pos :- !. + neg is_neg_fix is_neg_fix :- !. + + macro @max-min :- r-ar inf z. + + func min-max-nat range-arity, range-arity -> range-arity. + min-max-nat (r-ar A B) (r-ar A' B') (r-ar A'' B'') :- !, + min-nat A A' A'', max-nat B B' B''. + + % TODO: this is incomplete: it lacks of some term constructors + :index (_ 1) + func get-range-arity-aux term, term -> range-arity. + get-range-arity-aux N N (r-ar z z) :- !. + get-range-arity-aux _ N @max-min :- name N, !. + get-range-arity-aux T (app [T|L]) R :- !, + length-nat L Len, + std.fold L (r-ar Len Len) (x\y\w\ sigma M\ get-range-arity-aux T x M, min-max-nat y M w) R. + get-range-arity-aux T (app [_|L]) R :- !, + std.fold L @max-min (x\y\w\ sigma M\ get-range-arity-aux T x M, min-max-nat y M w) R. + get-range-arity-aux T (fun _ Ty B) R2 :- !, + get-range-arity-aux T Ty R, + (pi x\ get-range-arity-aux T (B x) R1), + min-max-nat R R1 R2. + get-range-arity-aux T (prod _ Ty B) R2 :- !, + get-range-arity-aux T Ty R, + (pi x\ get-range-arity-aux T (B x) R1), + min-max-nat R R1 R2. + get-range-arity-aux _ (global _) @max-min :- !. + get-range-arity-aux _ uvar @max-min :- !. + get-range-arity-aux _ (sort _) @max-min :- !. + get-range-arity-aux _ (pglobal _ _) @max-min :- !. + get-range-arity-aux X (let _ T Ty B) R4 :- !, + get-range-arity-aux X Ty R1, + get-range-arity-aux X T R2, + (pi x\ get-range-arity-aux T (B x) R3), + min-max-nat R1 R2 R12, + min-max-nat R12 R3 R4. + get-range-arity-aux A B _ :- coq.error "Count maximal arity failure" A B. + + func get-range-arity term, term, term -> range-arity. + get-range-arity _ Ty _ (r-ar z N) :- tc.get-TC-of-inst-type Ty _, !, count-prod Ty N. + get-range-arity B _ T N :- !, get-range-arity-aux B T N. + + + :index (_ 1) + func precompile-aux positivity, term, nat -> term, nat. + precompile-aux _ X A Y A :- name X, !, X = Y, !. % avoid loading "precompile-aux x A x A" at binders + precompile-aux _ (global _ as C) A C A :- !. + precompile-aux _ (pglobal _ _ as C) A C A :- !. + precompile-aux _ (sort _ as C) A C A :- !. + :name "precomp-proj-inst" + precompile-aux _ T N T' N' :- + tc.maybe-projection T P PN Ag R, !, + work-proj free-var P PN Ag R N T' N'. + + % Detect maybe-eta term + % TODO: should I precompile also the type of the fun and put it in the output term + precompile-aux _ (fun Name Ty B as T) N (tc.maybe-eta-tm (fun Name Ty B') Scope) (s M) :- + maybe-eta T, !, + free-var Scope, + precompile-aux is_neg_fix Ty N _ N', + (pi x\ is-name x => decl x Name Ty => precompile-aux is_neg_fix (B x) N' (B' x) M). + + precompile-aux _ (app [X|XS]) N (tc.maybe-llam-tm (app [app[X | PF] | NPF1]) Scope) (s M) :- + if (is-uvar X) (Sc = []) (var X _ Sc), split-pf is-name XS Sc PF NPF, + not (NPF = []), !, % else XS is a list of distinct names, i.e. `app [X|XS]` is in PF + free-var Scope, + std.fold-map NPF N (precompile-aux is_neg_fix) NPF1 M. + + % Charge if we work with unification variable or local name + % And returns the subterms is a prod-range + precompile-aux IsP (prod Name Ty B) N (tc.prod-range (prod Name Ty' B') MaxAr) P :- !, + std.assert! (pi x\ get-range-arity x Ty (B x) MaxAr) "[TC] get-range-arity should not fail", + if (IsP = is_pos) (C = x\ is-uvar x) (C = x\ is-name x), + std.assert! (pi x\ C x => decl x Name Ty => precompile-aux IsP (B x) N (B' x) M) "[TC] should not fail", + precompile-aux {neg IsP} Ty M Ty' P. + + % Working with fun + precompile-aux _ (fun N T F) A (fun N T1 F1) A2 :- !, + precompile-aux is_neg_fix T A T1 A1, pi x\ is-name x => decl x N T => precompile-aux is_neg_fix (F x) A1 (F1 x) A2. + + precompile-aux _ (app L) A (app L1) A1 :- !, std.fold-map L A (precompile-aux is_neg_fix) L1 A1. + precompile-aux _ X A X A :- var X, !. + + precompile-aux _ (let N T Ty Bo) A (let N T' Ty' Bo') A3 :- !, + precompile-aux is_neg_fix T A T' A1, + precompile-aux is_neg_fix Ty A1 Ty' A2, + pi x\ is-name x => def x N T Ty => precompile-aux is_neg_fix (Bo x) A2 (Bo' x) A3. + + + % TODO: what about the following constructors? + % precompile-aux IsP (let N T B F) A (let N T1 B1 F1) A3 :- !, + % precompile-aux IsP T A T1 A1, precompile-aux IsP B A1 B1 A2, pi x\ is-name x => precompile-aux IsP (F x) A2 (F1 x) A3. + % precompile-aux IsP (fix N Rno Ty F) A (fix N Rno Ty1 F1) A2 :- !, + % precompile-aux IsP Ty A Ty1 A1, pi x\ is-name x => precompile-aux IsP (F x) A1 (F1 x) A2. + % precompile-aux IsP (match T Rty B) A (match T1 Rty1 B1) A3 :- !, + % precompile-aux IsP T A T1 A1, precompile-aux IsP Rty A1 Rty1 A2, std.fold-map B A2 (precompile-aux IsP) B1 A3. + precompile-aux _ (primitive _ as C) A C A :- !. + % precompile-aux IsP (uvar M L as X) A W A1 :- var X, !, std.fold-map L A (precompile-aux IsP) L1 A1, coq.mk-app-uvar M L1 W. + % % when used in CHR rules + % precompile-aux IsP (uvar X L) A (uvar X L1) A1 :- std.fold-map L A (precompile-aux IsP) L1 A1. + + func get-univ-instances term -> list univ-instance. + get-univ-instances T L :- + (pi x L\ fold-map (pglobal _ x) L _ [x | L] :- !) => fold-map T [] _ L, !. + + func get-univ term -> list univ. + get-univ T L :- + coq.univ.variable.set.elements {coq.univ.variable.of-term T} Vars, + std.map Vars (x\r\ coq.univ.variable r x) L. - namespace precomp { - - namespace instance { - % Tells if the current name is a bound variables - pred is-name o:term. - % Tells if the current name stands for a uvar - pred is-uvar o:term. - - :index (_ _ 1) - func may-contract-to list term, term, term ->. - may-contract-to _ N N :- !. - may-contract-to L N (app [V|S]) :- var V, !, - std.forall [N|L] (x\ std.exists! S (may-contract-to [] x)). - may-contract-to L N (app [V|S]) :- is-uvar V, !, - std.forall [N|L] (x\ std.exists! S (may-contract-to [] x)). - may-contract-to L N (app [N|A]) :- - std.length A {std.length L}, - std.forall2 {std.rev L} A (may-contract-to []). - may-contract-to L N (fun _ _ B) :- - pi x\ may-contract-to [x|L] N (B x). - - :index (_ 1) - func occurs-rigidly term, term ->. - occurs-rigidly N N :- name N, !. - occurs-rigidly _ (app [N|_]) :- is-uvar N, !, fail. - occurs-rigidly _ (app [N|_]) :- var N, !, fail. - occurs-rigidly N (app A) :- std.exists! A (occurs-rigidly N). - occurs-rigidly N (fun _ _ B) :- pi x\ occurs-rigidly N (B x). - - func maybe-eta-aux term, list term ->. - maybe-eta-aux (app[V|S]) L :- is-uvar V, !, - std.forall L (x\ std.exists! S (y\ may-contract-to [] x y)). - maybe-eta-aux (app[V|S]) L :- var V, !, - std.forall L (x\ std.exists! S (y\ may-contract-to [] x y)). - maybe-eta-aux (app [_|A]) L :- - SplitLen is {std.length A} - {std.length L}, - split-at-not-fatal SplitLen A HD TL, - std.forall L (x\ not (std.exists! HD (occurs-rigidly x))), - std.forall2 {std.rev L} TL (may-contract-to []). - maybe-eta-aux (fun _ _ B) L :- - pi x\ maybe-eta-aux (B x) [x|L]. - - func maybe-eta term ->. - maybe-eta (fun _ _ B) :- pi x\ maybe-eta-aux (B x) [x]. - - func free-var -> list term. - free-var L :- - std.findall (is-name _) T, - std.map T (x\y\ x = is-name y) L. - - func split-pf list term, list term -> list term, list term. - split-pf [] _ [] [] :- !. - split-pf [X|Xs] Old [X|Ys] L :- is-name X, not (std.mem! Old X), !, split-pf Xs [X|Old] Ys L. - split-pf Xs _ [] Xs. - - kind positivity type. - type is_pos positivity. - type is_neg positivity. - type is_neg_fix positivity. - - :index (1 _) - func neg positivity -> positivity. - neg is_pos is_neg :- !. - neg is_neg is_pos :- !. - neg is_neg_fix is_neg_fix :- !. - - macro @max-min :- r-ar inf z. - - func min-max-nat range-arity, range-arity -> range-arity. - min-max-nat (r-ar A B) (r-ar A' B') (r-ar A'' B'') :- !, - min-nat A A' A'', max-nat B B' B''. - - % TODO: this is incomplete: it lacks of some term constructors - :index (_ 1) - func get-range-arity-aux term, term -> range-arity. - get-range-arity-aux N N (r-ar z z) :- !. - get-range-arity-aux _ N @max-min :- name N, !. - get-range-arity-aux T (app [T|L]) R :- !, - length-nat L Len, - std.fold L (r-ar Len Len) (x\y\w\ sigma M\ get-range-arity-aux T x M, min-max-nat y M w) R. - get-range-arity-aux T (app [_|L]) R :- !, - std.fold L @max-min (x\y\w\ sigma M\ get-range-arity-aux T x M, min-max-nat y M w) R. - get-range-arity-aux T (fun _ Ty B) R2 :- !, - get-range-arity-aux T Ty R, - (pi x\ get-range-arity-aux T (B x) R1), - min-max-nat R R1 R2. - get-range-arity-aux T (prod _ Ty B) R2 :- !, - get-range-arity-aux T Ty R, - (pi x\ get-range-arity-aux T (B x) R1), - min-max-nat R R1 R2. - get-range-arity-aux _ (global _) @max-min :- !. - get-range-arity-aux _ uvar @max-min :- !. - get-range-arity-aux _ (sort _) @max-min :- !. - get-range-arity-aux _ (pglobal _ _) @max-min :- !. - get-range-arity-aux X (let _ T Ty B) R4 :- !, - get-range-arity-aux X Ty R1, - get-range-arity-aux X T R2, - (pi x\ get-range-arity-aux T (B x) R3), - min-max-nat R1 R2 R12, - min-max-nat R12 R3 R4. - get-range-arity-aux A B _ :- coq.error "Count maximal arity failure" A B. - - func get-range-arity term, term, term -> range-arity. - get-range-arity _ Ty _ (r-ar z N) :- tc.get-TC-of-inst-type Ty _, !, count-prod Ty N. - get-range-arity B _ T N :- !, get-range-arity-aux B T N. - - % [work-proj P PN Ag R N T N'] - % P, PN are the constant and the proj number - % Ag are the argument of the projector (except for the record) - % R is the record - % N is the hole counter - % T is the new term - % N' is the updated counter - func work-proj constant, int, list term, term, nat -> term, nat. - work-proj P _ Ag R N (tc.maybe-proj (app[global (const P) | Ag']) X) (s N) :- is-uvar R, !, - std.append Ag [R] Ag', free-var X. - work-proj P PN Ag R N T' N :- tc.proj-reducer P PN Ag R T', !. - work-proj P _ Ag R N (tc.maybe-proj (app[global (const P) | Ag']) X) (s N) :- !, - std.append Ag [R] Ag', free-var X. -% - :index (_ 1) - func precompile-aux positivity, term, nat -> term, nat. - precompile-aux _ X A Y A :- name X, !, X = Y, !. % avoid loading "precompile-aux x A x A" at binders - precompile-aux _ (global _ as C) A C A :- !. - precompile-aux _ (pglobal _ _ as C) A C A :- !. - precompile-aux _ (sort _ as C) A C A :- !. - :name "precomp-proj-inst" - precompile-aux _ T N T' N' :- - tc.maybe-projection T P PN Ag R, !, - work-proj P PN Ag R N T' N'. - - % Detect maybe-eta term - % TODO: should I precompile also the type of the fun and put it in the output term - precompile-aux _ (fun Name Ty B as T) N (tc.maybe-eta-tm (fun Name Ty B') Scope) (s M) :- - maybe-eta T, !, - free-var Scope, - precompile-aux is_neg_fix Ty N _ N', - (pi x\ is-name x => decl x Name Ty => precompile-aux is_neg_fix (B x) N' (B' x) M). - - precompile-aux _ (app [X|XS]) N (tc.maybe-llam-tm (app [app[X | PF] | NPF1]) Scope) (s M) :- - if (is-uvar X) (Sc = []) (var X _ Sc), split-pf XS Sc PF NPF, - not (NPF = []), !, % else XS is a list of distinct names, i.e. `app [X|XS]` is in PF - free-var Scope, - std.fold-map NPF N (precompile-aux is_neg_fix) NPF1 M. - - % Charge if we work with unification variable or local name - % And returns the subterms is a prod-range - precompile-aux IsP (prod Name Ty B) N (tc.prod-range (prod Name Ty' B') MaxAr) P :- !, - std.assert! (pi x\ get-range-arity x Ty (B x) MaxAr) "[TC] get-range-arity should not fail", - if (IsP = is_pos) (C = x\ is-uvar x) (C = x\ is-name x), - std.assert! (pi x\ C x => decl x Name Ty => precompile-aux IsP (B x) N (B' x) M) "[TC] should not fail", - precompile-aux {neg IsP} Ty M Ty' P. - - % Working with fun - precompile-aux _ (fun N T F) A (fun N T1 F1) A2 :- !, - precompile-aux is_neg_fix T A T1 A1, pi x\ is-name x => decl x N T => precompile-aux is_neg_fix (F x) A1 (F1 x) A2. - - precompile-aux _ (app L) A (app L1) A1 :- !, std.fold-map L A (precompile-aux is_neg_fix) L1 A1. - precompile-aux _ X A X A :- var X, !. - - precompile-aux _ (let N T Ty Bo) A (let N T' Ty' Bo') A3 :- !, - precompile-aux is_neg_fix T A T' A1, - precompile-aux is_neg_fix Ty A1 Ty' A2, - pi x\ is-name x => def x N T Ty => precompile-aux is_neg_fix (Bo x) A2 (Bo' x) A3. - - - % TODO: what about the following constructors? - % precompile-aux IsP (let N T B F) A (let N T1 B1 F1) A3 :- !, - % precompile-aux IsP T A T1 A1, precompile-aux IsP B A1 B1 A2, pi x\ is-name x => precompile-aux IsP (F x) A2 (F1 x) A3. - % precompile-aux IsP (fix N Rno Ty F) A (fix N Rno Ty1 F1) A2 :- !, - % precompile-aux IsP Ty A Ty1 A1, pi x\ is-name x => precompile-aux IsP (F x) A1 (F1 x) A2. - % precompile-aux IsP (match T Rty B) A (match T1 Rty1 B1) A3 :- !, - % precompile-aux IsP T A T1 A1, precompile-aux IsP Rty A1 Rty1 A2, std.fold-map B A2 (precompile-aux IsP) B1 A3. - precompile-aux _ (primitive _ as C) A C A :- !. - % precompile-aux IsP (uvar M L as X) A W A1 :- var X, !, std.fold-map L A (precompile-aux IsP) L1 A1, coq.mk-app-uvar M L1 W. - % % when used in CHR rules - % precompile-aux IsP (uvar X L) A (uvar X L1) A1 :- std.fold-map L A (precompile-aux IsP) L1 A1. - - func get-univ-instances term -> list univ-instance. - get-univ-instances T L :- - (pi x L\ fold-map (pglobal _ x) L _ [x | L] :- !) => fold-map T [] _ L, !. - - func get-univ term -> list univ. - get-univ T L :- - coq.univ.variable.set.elements {coq.univ.variable.of-term T} Vars, - std.map Vars (x\r\ coq.univ.variable r x) L. - - } - - /* - [tc.precomp.instance T T' N] - Returns T' N from T, where: - T' is obtained by the replacement of - - all maybe-eta term `t1` with (tc.maybe-eta-tm `t1` `s`) where `s` = FV(`t1`) - ==> This helps knowing if a subterm should be replaced with a `eta-link` - - all `prod _ Ty (x\ Bo x)` with (tc.prod-range (prod _ Ty (x\ Bo x)) N), - where N is represent the "maximal" application of `x` in `Bo` - for example: - let Ty = {{Type -> Type -> Type -> Type -> Type}}, - and Bo = x\ c1 (x nat bool) (x nat) (x nat nat bool) - the term `prod _ Ty Bo` is replaced with - (tc.prod-range (prod _ T Bo) 3) - since x is applied at most 3 times in Bo - ==> This helps charging the right number of `eta-link` for map-deduplication rule - N is the number of problematic terms in T - */ - func instance term -> term, nat, list univ, list univ-instance. - instance T T' N UnivConstL UnivInstL :- - tc.precomp.instance.get-univ T UnivConstL, - tc.precomp.instance.get-univ-instances T UnivInstL, - std.assert!(instance.precompile-aux instance.is_pos T z T' N) "[TC] cannot precompile instance". - - namespace goal { - :index (_ _ 1) - func may-contract-to list term, term, term ->. - may-contract-to _ N N :- !. - % TODO: here we should do var V _ Scope and use scope: N can be in Scope but not in S - may-contract-to L N (app [V|S]) :- var V, !, - std.forall [N|L] (x\ std.exists! S (may-contract-to [] x)). - may-contract-to L N (app [N|A]) :- - std.length A {std.length L}, - std.forall2 {std.rev L} A (may-contract-to []). - may-contract-to L N (fun _ _ B) :- - pi x\ may-contract-to [x|L] N (B x). - - :index (_ 1) - func occurs-rigidly term, term ->. - occurs-rigidly N N :- name N, !. - occurs-rigidly _ (app [N|_]) :- var N, !, fail. - occurs-rigidly N (app A) :- std.exists! A (occurs-rigidly N). - occurs-rigidly N (fun _ _ B) :- pi x\ occurs-rigidly N (B x). - - func maybe-eta-aux term, list term ->. - % TODO: here we should do var V _ Scope and use Scope: an elt in L can appear in Scope - maybe-eta-aux (app[V|S]) L :- var V, !, - std.forall L (x\ std.exists! S (y\ may-contract-to [] x y)). - maybe-eta-aux (app [_|A]) L :- - SplitLen is {std.length A} - {std.length L}, - split-at-not-fatal SplitLen A HD TL, - std.forall L (x\ not (std.exists! HD (occurs-rigidly x))), - std.forall2 {std.rev L} TL (may-contract-to []). - maybe-eta-aux (fun _ _ B) L :- - pi x\ maybe-eta-aux (B x) [x|L]. - - func maybe-eta term ->. - maybe-eta (fun _ _ B) :- pi x\ maybe-eta-aux (B x) [x]. - - func split-pf list term, list term -> list term, list term. - split-pf [] _ [] [] :- !. - split-pf [X|Xs] Old [X|Ys] L :- name X, not (std.mem! Old X), !, split-pf Xs [X|Old] Ys L. - split-pf Xs _ [] Xs. - - func work-proj constant, int, list term, term -> term. - work-proj P _ Ag (uvar as R) (tc.maybe-proj (app[global (const P) | Ag']) X) :- !, - std.append Ag [R] Ag', names X. - work-proj P PN Ag R T' :- tc.proj-reducer P PN Ag R T', !. - work-proj P _ Ag R (tc.maybe-proj (app[global (const P) | Ag']) X) :- - std.append Ag [R] Ag', names X. - - func precompile-aux term, list term -> term, list term. - precompile-aux X A Y A :- name X, !, X = Y, !. % avoid loading "precompile-aux x A x A" at binders - precompile-aux (global _ as C) A C A :- !. - precompile-aux (pglobal _ _ as C) A C A :- !. - precompile-aux (sort _ as C) A C A :- !. - :name "precomp-proj-goal" - precompile-aux T A T' A :- - tc.maybe-projection T P PN Ag R, !, - work-proj P PN Ag R T'. - - % Detect maybe-eta term - precompile-aux (fun Name Ty B as T) N (tc.maybe-eta-tm (fun Name Ty' B') Scope) M :- - maybe-eta T, !, - names Scope, - (pi x\ decl x Name Ty => precompile-aux (B x) N (B' x) M'), - precompile-aux Ty M' Ty' M. - - % Detect maybe-beta term - precompile-aux (app [X|XS]) N (tc.maybe-llam-tm (app [app[X | PF] | NPF1]) Scope1) [X|M] :- - var X _ Scope, split-pf XS Scope PF NPF, - not (NPF = []), !, % else XS is a list of distinct names, i.e. `app [X|XS]` is in PF - names Scope1, - std.fold-map NPF N precompile-aux NPF1 M. - - % In the goal there are - precompile-aux (prod Name Ty B) N (tc.prod-range (prod Name Ty' B') (r-ar z MaxAr)) P :- !, - count-prod Ty MaxAr, - std.assert! (pi x\ decl x Name Ty => precompile-aux (B x) N (B' x) M) "[TC] should not fail", - precompile-aux Ty M Ty' P. - - % Working with fun - precompile-aux (fun N T F) A (fun N T F1) A2 :- !, A = A1, - /*precompile-aux IsP T A T1 A1,*/ pi x\ decl x N Ty => precompile-aux (F x) A1 (F1 x) A2. - - precompile-aux (app L) A (app L1) A1 :- !, std.fold-map L A precompile-aux L1 A1. - precompile-aux (let N T B F) A (let N T1 B1 F1) A3 :- !, - precompile-aux T A T1 A1, precompile-aux B A1 B1 A2, pi x\ def x N T1 B1 => precompile-aux (F x) A2 (F1 x) A3. - precompile-aux (fix N Rno Ty F) A (fix N Rno Ty1 F1) A2 :- !, - precompile-aux Ty A Ty1 A1, pi x\ precompile-aux (F x) A1 (F1 x) A2. - precompile-aux (match T Rty B) A (match T1 Rty1 B1) A3 :- !, - precompile-aux T A T1 A1, precompile-aux Rty A1 Rty1 A2, std.fold-map B A2 precompile-aux B1 A3. - precompile-aux (primitive _ as C) A C A :- !. - precompile-aux X A X [X|A] :- var X, !. - } - - func goal term -> term, list term. - goal T T' Vars' :- std.assert!(goal.precompile-aux T [] T' Vars) "[TC] cannot precompile goal", undup-same Vars Vars'. } + + /* + [tc.precomp.instance T T' N] + Returns T' N from T, where: + T' is obtained by the replacement of + - all maybe-eta term `t1` with (tc.maybe-eta-tm `t1` `s`) where `s` = FV(`t1`) + ==> This helps knowing if a subterm should be replaced with a `eta-link` + - all `prod _ Ty (x\ Bo x)` with (tc.prod-range (prod _ Ty (x\ Bo x)) N), + where N is represent the "maximal" application of `x` in `Bo` + for example: + let Ty = {{Type -> Type -> Type -> Type -> Type}}, + and Bo = x\ c1 (x nat bool) (x nat) (x nat nat bool) + the term `prod _ Ty Bo` is replaced with + (tc.prod-range (prod _ T Bo) 3) + since x is applied at most 3 times in Bo + ==> This helps charging the right number of `eta-link` for map-deduplication rule + N is the number of problematic terms in T + */ + func instance term -> term, nat, list univ, list univ-instance. + instance T T' N UnivConstL UnivInstL :- + tc.precomp.instance.get-univ T UnivConstL, + tc.precomp.instance.get-univ-instances T UnivInstL, + std.assert!(instance.precompile-aux instance.is_pos T z T' N) "[TC] cannot precompile instance". + + namespace goal { + + + func precompile-aux term, list term -> term, list term. + precompile-aux X A Y A :- name X, !, X = Y, !. % avoid loading "precompile-aux x A x A" at binders + precompile-aux (global _ as C) A C A :- !. + precompile-aux (pglobal _ _ as C) A C A :- !. + precompile-aux (sort _ as C) A C A :- !. + :name "precomp-proj-goal" + precompile-aux T A T' A :- + tc.maybe-projection T P PN Ag R, !, + work-proj names P PN Ag R z T' _. + + % Detect maybe-eta term + precompile-aux (fun Name Ty B as T) N (tc.maybe-eta-tm (fun Name Ty' B') Scope) M :- + maybe-eta T, !, + names Scope, + (pi x\ decl x Name Ty => precompile-aux (B x) N (B' x) M'), + precompile-aux Ty M' Ty' M. + + % Detect maybe-beta term + precompile-aux (app [X|XS]) N (tc.maybe-llam-tm (app [app[X | PF] | NPF1]) Scope1) [X|M] :- + var X _ Scope, split-pf name XS Scope PF NPF, + not (NPF = []), !, % else XS is a list of distinct names, i.e. `app [X|XS]` is in PF + names Scope1, + std.fold-map NPF N precompile-aux NPF1 M. + + % In the goal there are + precompile-aux (prod Name Ty B) N (tc.prod-range (prod Name Ty' B') (r-ar z MaxAr)) P :- !, + count-prod Ty MaxAr, + std.assert! (pi x\ decl x Name Ty => precompile-aux (B x) N (B' x) M) "[TC] should not fail", + precompile-aux Ty M Ty' P. + + % Working with fun + precompile-aux (fun N T F) A (fun N T F1) A2 :- !, A = A1, + /*precompile-aux IsP T A T1 A1,*/ pi x\ decl x N Ty => precompile-aux (F x) A1 (F1 x) A2. + + precompile-aux (app L) A (app L1) A1 :- !, std.fold-map L A precompile-aux L1 A1. + precompile-aux (let N T B F) A (let N T1 B1 F1) A3 :- !, + precompile-aux T A T1 A1, precompile-aux B A1 B1 A2, pi x\ def x N T1 B1 => precompile-aux (F x) A2 (F1 x) A3. + precompile-aux (fix N Rno Ty F) A (fix N Rno Ty1 F1) A2 :- !, + precompile-aux Ty A Ty1 A1, pi x\ precompile-aux (F x) A1 (F1 x) A2. + precompile-aux (match T Rty B) A (match T1 Rty1 B1) A3 :- !, + precompile-aux T A T1 A1, precompile-aux Rty A1 Rty1 A2, std.fold-map B A2 precompile-aux B1 A3. + precompile-aux (primitive _ as C) A C A :- !. + precompile-aux X A X [X|A] :- var X, !. + } + + func goal term -> term, list term. + goal T T' Vars' :- std.assert!(goal.precompile-aux T [] T' Vars) "[TC] cannot precompile goal", undup-same Vars Vars'. } \ No newline at end of file diff --git a/apps/tc/tests/test.v b/apps/tc/tests/test.v index 8ecbe3094..0fdea70e1 100644 --- a/apps/tc/tests/test.v +++ b/apps/tc/tests/test.v @@ -126,7 +126,7 @@ Module HO_swap. Class c2 (T : (Type -> Type -> Type)). Elpi Query TC.Solver lp:{{ - @pi-decl `x` {{Type -> Type}} f\ tc.precomp.instance.is-uvar f => + @pi-decl `x` {{Type -> Type}} f\ tc.precomp.is-uvar f => sigma T\ tc.precomp.instance {{c1 (fun x y => lp:f y x)}} T N _ _, std.assert! (T = app[{{c1}}, tc.maybe-eta-tm _ _]) "[TC] invalid precomp". @@ -245,7 +245,7 @@ Module HO_9. Instance i1 A: c1 (fun x => f (A x) (A x)). Qed. Elpi Query TC.Solver lp:{{ - pi F\ sigma T\ decl F `x` {{Type -> Type}} ==> tc.precomp.instance.is-uvar F ==> + pi F\ sigma T\ decl F `x` {{Type -> Type}} ==> tc.precomp.is-uvar F ==> tc.precomp.instance {{c1 (fun x => f (lp:F x) (lp:F x))}} T N _ _, std.assert! (T = app [{{c1}}, tc.maybe-eta-tm _ _]) "Invalid precompilation". }}. @@ -334,8 +334,8 @@ Module Llam_1. Class B (i: nat -> nat). Elpi Query TC.Solver lp:{{ - @pi-decl `x` {{Type -> Type}} f\ tc.precomp.instance.is-uvar f => - @pi-decl `x` {{Type -> Type}} g\ tc.precomp.instance.is-uvar g => + @pi-decl `x` {{Type -> Type}} f\ tc.precomp.is-uvar f => + @pi-decl `x` {{Type -> Type}} g\ tc.precomp.is-uvar g => sigma T\ tc.precomp.instance {{A (fun x => lp:f (lp:g x))}} T N _ _, std.assert! (T = app[{{A}}, tc.maybe-eta-tm (fun _ _ (x\ tc.maybe-llam-tm _ _)) _]) "[TC] invalid precomp". From 618753ee76e82ee9a368b87f7baea38edf6add21 Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Wed, 17 Jun 2026 15:26:55 +0200 Subject: [PATCH 27/62] add solve_cs tactic --- apps/tc/tests/test_proj.v | 105 +++++++++++++++++++++++++++----------- apps/tc/theories/tc.v | 10 +++- 2 files changed, 83 insertions(+), 32 deletions(-) diff --git a/apps/tc/tests/test_proj.v b/apps/tc/tests/test_proj.v index baa31c769..e8069ffbf 100644 --- a/apps/tc/tests/test_proj.v +++ b/apps/tc/tests/test_proj.v @@ -1,8 +1,8 @@ From elpi Require Import tc. +From elpi Require Import elpi. - -Set TC NameShortPath. -Class C (T : Type) := {f : T -> T}. +Global Set TC NameShortPath. +Class C (T : Type) := mkC {f : T -> T}. Class D (T : nat -> nat) := {g : unit}. Class E (T : nat) := {ge : unit}. Record r := mkr {car : Type; rf : car -> car}. @@ -12,13 +12,9 @@ Elpi Accumulate TC.Compiler lp:{{ % the goal is to check instances for C are correctly compiled func is-class-C prop ->. is-class-C (pi x\ X x) :- !, pi x\ is-class-C (X x). - :name "is-class-C" is-class-C (tc.instance _ _ _ _) :- !. - % :name "XX" - % is-class-C (tc-C _ _ :- _ as C) :- !, - % coq.say "Checking"C, if (expected-rule C) true (coq.error "Wrong compilation of" C). - % is-class-C (tc-C _ _ as C) :- !, - % coq.say "Checking"C, if (expected-rule C) true (coq.error "Wrong compilation of" C). + :name "is-class-C" + is-class-C (tc.class _ _ _ _) :- !. is-class-C C :- coq.error "FAIL" C. :before "tc-adder" @@ -150,32 +146,79 @@ Module m4. intros x y. apply _. Qed. End m4. -From elpi.apps Require Import db. -From elpi.apps.tc.elpi Extra Dependency "tc_aux.elpi" as tc_aux. -From elpi.apps.tc.elpi Extra Dependency "base.elpi" as base. -From elpi.apps.tc.elpi Extra Dependency "cs.elpi" as cs. -Elpi Command B. -Elpi Accumulate Db tc.db. -Elpi Accumulate Db tc_options.db. -(* Elpi Accumulate File base. *) -Elpi Accumulate File tc_aux. -Elpi Accumulate File cs. - -Elpi Trace Browser. -Elpi Query lp:{{ cs.compiler.record.create-cs-pred {{r}}. }}. +Elpi Accumulate TC.Compiler lp:{{ :after "is-class-C" is-class-C _ :- !. }}. Set Printing All. -Elpi Query lp:{{ cs.compiler.cs.main {{c}}. }}. -(* Elpi Print TC.Compiler "elpi.apps.derive.tests/xxx". *) +Module M. + + Elpi cs class (r). + Elpi cs class (C). + Elpi cs cs (c). + + (* Elpi Print TC.Compiler "elpi.apps.derive.tests/xxx". *) + + Definition fcs1 (H1 H2 : r) := (fun '(x,y) => (rf H1 x, rf H2 y)). + Local Canonical Structure cs1 (H1 H2 H3 : r) := mkr (car H1 * car H2) (fcs1 H1 H2). + Elpi cs cs (cs1). + + Goal exists x, car x = (nat * nat)%type. + Proof. eexists. auto. Unshelve. apply c. Qed. + + Local Canonical Structure cs2 (T : Type) (c : C T) := mkr T (@f _ c). + + Local Instance i : C bool. apply (mkC _ (fun x => x)). Qed. + Elpi cs cs (cs2). + (* Elpi Print TC.Compiler "elpi.apps.derive.tests/xxx". *) + + (* Print HintDb typeclass_instances. *) + Elpi TC Solver Activate TC.Solver. + (* Set Typeclasses Debug. *) + (* Set Debug "tactic-unification". *) + + Elpi Accumulate solve_cs lp:{{ + solve (goal _ _ {{@eq lp:T_ lp:P lp:T}} _ _ as G) GL :- + % coq.say "The goal is"G, + P = app [global (const Proj), A], + cs.compiler.cs.compiler ff (pr 0 Proj) A (app[_, T]) [] [] R, + % R, coq.say "The rule is"R, + @no-tc! => refine {{eq_refl}} G GL. + }}. + + Goal exists x, car x = bool. + Proof. + eexists. + Elpi Accumulate TC.Solver lp:{{tc.print-goal.}}. + elpi solve_cs. + Abort. (*TODO:*) +End M. -Definition rrf (H1 H2 : r) := (fun '(x,y) => (rf H1 x, rf H2 y)). -Canonical Structure rr (H1 H2 H3 : r) := mkr (car H1 * car H2) (rrf H1 H2). -Elpi Trace Browser. -Elpi Query lp:{{ cs.compiler.cs.main {{rr}}. }}. +(* Module tc. + Class Cx (t: Type) := mkC {op : t -> t -> bool}. + Record Rx := mkR {car : Type; class_of : Cx car}. -(* Elpi Print TC.Compiler "elpi.apps.derive.tests/xxx". *) + Set Printing All. + + Instance Ic : Cx bool := mkC _ (fun (x:bool) y => if x then y else negb y). + Canonical Structure Ir := mkR bool Ic. + + Elpi cs class (Rx). + Elpi cs cs (Ir). + Elpi Print TC.Compiler "elpi.apps.derive.tests/xxx". + + From elpi.apps.tc.elpi Extra Dependency "tc_aux.elpi" as tc_aux. + From elpi.apps.tc.elpi Extra Dependency "cs.elpi" as cs. + + Elpi Tactic solve_cs. + Elpi Accumulate Db tc.db. + Elpi Accumulate File tc_aux. + Elpi Accumulate File cs. + + Elpi Accumulate lp:{{ + solve (goal _ _ Ty _ _ as G) GL :- + coq.say Ty. + }}. -Goal exists x, car x = (nat * nat)%type. -Proof. eexists. auto. Unshelve. apply c. Qed. \ No newline at end of file + Definition op_of (T: Rx) := @op _ (class_of T). *) + \ No newline at end of file diff --git a/apps/tc/theories/tc.v b/apps/tc/theories/tc.v index dd06546dc..bbdffc69a 100644 --- a/apps/tc/theories/tc.v +++ b/apps/tc/theories/tc.v @@ -208,4 +208,12 @@ Elpi Accumulate File tc_aux. Elpi Accumulate File cs. Elpi Accumulate lp:{{ main L :- cs.main L. -}}. \ No newline at end of file +}}. + +Elpi Tactic solve_cs. +Elpi Accumulate Db tc.db. +Elpi Accumulate File tc_aux. +Elpi Accumulate File cs. +(* Elpi Accumulate lp:{{ + main L :- cs.main L. +}}. *) \ No newline at end of file From 06f93ffc4a8361a044a72d5fc234db89ce54c683 Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Wed, 17 Jun 2026 15:37:33 +0200 Subject: [PATCH 28/62] remove range-arity since unused --- apps/tc/elpi/ho_compile.elpi | 10 ++++----- apps/tc/elpi/ho_precompile.elpi | 39 ++++++++++++++------------------- apps/tc/elpi/tc_aux.elpi | 6 +---- apps/tc/tests/test.v | 2 +- 4 files changed, 23 insertions(+), 34 deletions(-) diff --git a/apps/tc/elpi/ho_compile.elpi b/apps/tc/elpi/ho_compile.elpi index 5b1bed3a8..9473c6593 100644 --- a/apps/tc/elpi/ho_compile.elpi +++ b/apps/tc/elpi/ho_compile.elpi @@ -203,15 +203,15 @@ namespace tc { :index (_ 1) func add-link-eta-dedup (func list prop -> prop), - range-arity, term, term, (list (pair term name)), list prop -> prop. + nat, term, term, (list (pair term name)), list prop -> prop. % Base case when the variable is always used at same arity - add-link-eta-dedup F (r-ar _ z) _ _ [] PremR Clause :- !, + add-link-eta-dedup F z _ _ [] PremR Clause :- !, F PremR Clause. - add-link-eta-dedup F (r-ar _ z) P Pty Acc PremR Clause :- !, + add-link-eta-dedup F z P Pty Acc PremR Clause :- !, make-eta-link P Pty Acc [] [] LinkEtaDedup, F [LinkEtaDedup|PremR] Clause. - add-link-eta-dedup F (r-ar M (s N)) P PTy Acc PremR (pi x y\ Clause x y) :- !, - pi x y\ name-pair P x (s N) => is-uvar x => add-link-eta-dedup F (r-ar M N) P PTy [pr x y|Acc] PremR (Clause x y). + add-link-eta-dedup F (s N) P PTy Acc PremR (pi x y\ Clause x y) :- !, + pi x y\ name-pair P x (s N) => is-uvar x => add-link-eta-dedup F N P PTy [pr x y|Acc] PremR (Clause x y). add-link-eta-dedup _ Ar P PTy _ _ _ :- coq.error "[TC] add-link-eta-dedup error" Ar P PTy. :functional diff --git a/apps/tc/elpi/ho_precompile.elpi b/apps/tc/elpi/ho_precompile.elpi index 985ff12fe..7380083ae 100644 --- a/apps/tc/elpi/ho_precompile.elpi +++ b/apps/tc/elpi/ho_precompile.elpi @@ -1,5 +1,4 @@ namespace tc.precomp { - shorten tc.{r-ar, range-arity}. % Tells if the current name is a bound variables pred is-name o:term. % Tells if the current name stands for a uvar @@ -81,44 +80,38 @@ namespace tc.precomp { neg is_neg is_pos :- !. neg is_neg_fix is_neg_fix :- !. - macro @max-min :- r-ar inf z. - - func min-max-nat range-arity, range-arity -> range-arity. - min-max-nat (r-ar A B) (r-ar A' B') (r-ar A'' B'') :- !, - min-nat A A' A'', max-nat B B' B''. - % TODO: this is incomplete: it lacks of some term constructors :index (_ 1) - func get-range-arity-aux term, term -> range-arity. - get-range-arity-aux N N (r-ar z z) :- !. - get-range-arity-aux _ N @max-min :- name N, !. + func get-range-arity-aux term, term -> nat. + get-range-arity-aux N N z :- !. + get-range-arity-aux _ N z :- name N, !. get-range-arity-aux T (app [T|L]) R :- !, length-nat L Len, - std.fold L (r-ar Len Len) (x\y\w\ sigma M\ get-range-arity-aux T x M, min-max-nat y M w) R. + std.fold L Len (x\y\w\ sigma M\ get-range-arity-aux T x M, max-nat y M w) R. get-range-arity-aux T (app [_|L]) R :- !, - std.fold L @max-min (x\y\w\ sigma M\ get-range-arity-aux T x M, min-max-nat y M w) R. + std.fold L z (x\y\w\ sigma M\ get-range-arity-aux T x M, max-nat y M w) R. get-range-arity-aux T (fun _ Ty B) R2 :- !, get-range-arity-aux T Ty R, (pi x\ get-range-arity-aux T (B x) R1), - min-max-nat R R1 R2. + max-nat R R1 R2. get-range-arity-aux T (prod _ Ty B) R2 :- !, get-range-arity-aux T Ty R, (pi x\ get-range-arity-aux T (B x) R1), - min-max-nat R R1 R2. - get-range-arity-aux _ (global _) @max-min :- !. - get-range-arity-aux _ uvar @max-min :- !. - get-range-arity-aux _ (sort _) @max-min :- !. - get-range-arity-aux _ (pglobal _ _) @max-min :- !. + max-nat R R1 R2. + get-range-arity-aux _ (global _) z :- !. + get-range-arity-aux _ uvar z :- !. + get-range-arity-aux _ (sort _) z :- !. + get-range-arity-aux _ (pglobal _ _) z :- !. get-range-arity-aux X (let _ T Ty B) R4 :- !, get-range-arity-aux X Ty R1, get-range-arity-aux X T R2, (pi x\ get-range-arity-aux T (B x) R3), - min-max-nat R1 R2 R12, - min-max-nat R12 R3 R4. + max-nat R1 R2 R12, + max-nat R12 R3 R4. get-range-arity-aux A B _ :- coq.error "Count maximal arity failure" A B. - func get-range-arity term, term, term -> range-arity. - get-range-arity _ Ty _ (r-ar z N) :- tc.get-TC-of-inst-type Ty _, !, count-prod Ty N. + func get-range-arity term, term, term -> nat. + get-range-arity _ Ty _ N :- tc.get-TC-of-inst-type Ty _, !, count-prod Ty N. get-range-arity B _ T N :- !, get-range-arity-aux B T N. @@ -242,7 +235,7 @@ namespace tc.precomp { std.fold-map NPF N precompile-aux NPF1 M. % In the goal there are - precompile-aux (prod Name Ty B) N (tc.prod-range (prod Name Ty' B') (r-ar z MaxAr)) P :- !, + precompile-aux (prod Name Ty B) N (tc.prod-range (prod Name Ty' B') MaxAr) P :- !, count-prod Ty MaxAr, std.assert! (pi x\ decl x Name Ty => precompile-aux (B x) N (B' x) M) "[TC] should not fail", precompile-aux Ty M Ty' P. diff --git a/apps/tc/elpi/tc_aux.elpi b/apps/tc/elpi/tc_aux.elpi index 8a174276a..f281e53b9 100644 --- a/apps/tc/elpi/tc_aux.elpi +++ b/apps/tc/elpi/tc_aux.elpi @@ -291,13 +291,9 @@ namespace tc { proj-reducer-aux R P N O TyAg T. proj-reducer P _ Ag X T :- name X, !, build-proj-term P Ag X T. - - kind range-arity type. - type r-ar nat -> nat -> range-arity. - type prod-range term -> % The current qunatified uvar - range-arity -> % Its minimum and maximal application + nat -> % Its minimum and maximal application term. type maybe-eta-tm diff --git a/apps/tc/tests/test.v b/apps/tc/tests/test.v index 0fdea70e1..b808d9f83 100644 --- a/apps/tc/tests/test.v +++ b/apps/tc/tests/test.v @@ -7,7 +7,7 @@ Section test_max_arity. (prod `a` _ c3 \ app [global _, app [c1, c3], c2]) c3 \ app [global _, c1, c2]), - pi x\ tc.precomp.instance.get-range-arity x _ (T x) (tc.r-ar z (s z)). + pi x\ tc.precomp.instance.get-range-arity x _ (T x) (s z). }}. End test_max_arity. From a6399e7f46a2c37e3f94e906449384bf479b6749 Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Wed, 17 Jun 2026 16:05:56 +0200 Subject: [PATCH 29/62] rename and comment max-arity-aux --- apps/tc/elpi/ho_precompile.elpi | 56 +++++++++++++++++---------------- apps/tc/tests/test.v | 2 +- 2 files changed, 30 insertions(+), 28 deletions(-) diff --git a/apps/tc/elpi/ho_precompile.elpi b/apps/tc/elpi/ho_precompile.elpi index 7380083ae..8efff09d5 100644 --- a/apps/tc/elpi/ho_precompile.elpi +++ b/apps/tc/elpi/ho_precompile.elpi @@ -80,39 +80,41 @@ namespace tc.precomp { neg is_neg is_pos :- !. neg is_neg_fix is_neg_fix :- !. - % TODO: this is incomplete: it lacks of some term constructors + % [max-arity-aux X T N] + % returns the maximal application of X in T + % for example, max-arity-aux x (f (x 1 2) (g (x 4 5 6))) returns 3 :index (_ 1) - func get-range-arity-aux term, term -> nat. - get-range-arity-aux N N z :- !. - get-range-arity-aux _ N z :- name N, !. - get-range-arity-aux T (app [T|L]) R :- !, + func get-max-arity-aux term, term -> nat. + get-max-arity-aux N N z :- !. + get-max-arity-aux _ N z :- name N, !. + get-max-arity-aux T (app [T|L]) R :- !, length-nat L Len, - std.fold L Len (x\y\w\ sigma M\ get-range-arity-aux T x M, max-nat y M w) R. - get-range-arity-aux T (app [_|L]) R :- !, - std.fold L z (x\y\w\ sigma M\ get-range-arity-aux T x M, max-nat y M w) R. - get-range-arity-aux T (fun _ Ty B) R2 :- !, - get-range-arity-aux T Ty R, - (pi x\ get-range-arity-aux T (B x) R1), + std.fold L Len (x\y\w\ sigma M\ get-max-arity-aux T x M, max-nat y M w) R. + get-max-arity-aux T (app [_|L]) R :- !, + std.fold L z (x\y\w\ sigma M\ get-max-arity-aux T x M, max-nat y M w) R. + get-max-arity-aux T (fun _ Ty B) R2 :- !, + get-max-arity-aux T Ty R, + (pi x\ get-max-arity-aux T (B x) R1), max-nat R R1 R2. - get-range-arity-aux T (prod _ Ty B) R2 :- !, - get-range-arity-aux T Ty R, - (pi x\ get-range-arity-aux T (B x) R1), + get-max-arity-aux T (prod _ Ty B) R2 :- !, + get-max-arity-aux T Ty R, + (pi x\ get-max-arity-aux T (B x) R1), max-nat R R1 R2. - get-range-arity-aux _ (global _) z :- !. - get-range-arity-aux _ uvar z :- !. - get-range-arity-aux _ (sort _) z :- !. - get-range-arity-aux _ (pglobal _ _) z :- !. - get-range-arity-aux X (let _ T Ty B) R4 :- !, - get-range-arity-aux X Ty R1, - get-range-arity-aux X T R2, - (pi x\ get-range-arity-aux T (B x) R3), + get-max-arity-aux _ (global _) z :- !. + get-max-arity-aux _ uvar z :- !. + get-max-arity-aux _ (sort _) z :- !. + get-max-arity-aux _ (pglobal _ _) z :- !. + get-max-arity-aux X (let _ T Ty B) R4 :- !, + get-max-arity-aux X Ty R1, + get-max-arity-aux X T R2, + (pi x\ get-max-arity-aux T (B x) R3), max-nat R1 R2 R12, max-nat R12 R3 R4. - get-range-arity-aux A B _ :- coq.error "Count maximal arity failure" A B. + get-max-arity-aux A B _ :- coq.error "TC: get-max-arity-aux failure with" A B. - func get-range-arity term, term, term -> nat. - get-range-arity _ Ty _ N :- tc.get-TC-of-inst-type Ty _, !, count-prod Ty N. - get-range-arity B _ T N :- !, get-range-arity-aux B T N. + func get-max-arity term, term, term -> nat. + get-max-arity _ Ty _ N :- tc.get-TC-of-inst-type Ty _, !, count-prod Ty N. + get-max-arity B _ T N :- !, get-max-arity-aux B T N. :index (_ 1) @@ -143,7 +145,7 @@ namespace tc.precomp { % Charge if we work with unification variable or local name % And returns the subterms is a prod-range precompile-aux IsP (prod Name Ty B) N (tc.prod-range (prod Name Ty' B') MaxAr) P :- !, - std.assert! (pi x\ get-range-arity x Ty (B x) MaxAr) "[TC] get-range-arity should not fail", + std.assert! (pi x\ get-max-arity x Ty (B x) MaxAr) "[TC] get-max-arity should not fail", if (IsP = is_pos) (C = x\ is-uvar x) (C = x\ is-name x), std.assert! (pi x\ C x => decl x Name Ty => precompile-aux IsP (B x) N (B' x) M) "[TC] should not fail", precompile-aux {neg IsP} Ty M Ty' P. diff --git a/apps/tc/tests/test.v b/apps/tc/tests/test.v index b808d9f83..1b3c35f30 100644 --- a/apps/tc/tests/test.v +++ b/apps/tc/tests/test.v @@ -7,7 +7,7 @@ Section test_max_arity. (prod `a` _ c3 \ app [global _, app [c1, c3], c2]) c3 \ app [global _, c1, c2]), - pi x\ tc.precomp.instance.get-range-arity x _ (T x) (s z). + pi x\ tc.precomp.instance.get-max-arity x _ (T x) (s z). }}. End test_max_arity. From 74d27188fea056807fbc76709391c40cf1863c17 Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Wed, 17 Jun 2026 16:20:18 +0200 Subject: [PATCH 30/62] clean get-max-arity-aux --- apps/tc/elpi/ho_precompile.elpi | 11 +++-------- 1 file changed, 3 insertions(+), 8 deletions(-) diff --git a/apps/tc/elpi/ho_precompile.elpi b/apps/tc/elpi/ho_precompile.elpi index 8efff09d5..17728deb8 100644 --- a/apps/tc/elpi/ho_precompile.elpi +++ b/apps/tc/elpi/ho_precompile.elpi @@ -85,13 +85,10 @@ namespace tc.precomp { % for example, max-arity-aux x (f (x 1 2) (g (x 4 5 6))) returns 3 :index (_ 1) func get-max-arity-aux term, term -> nat. - get-max-arity-aux N N z :- !. get-max-arity-aux _ N z :- name N, !. - get-max-arity-aux T (app [T|L]) R :- !, - length-nat L Len, + get-max-arity-aux T (app [H|L]) R :- !, + if (T == H) (length-nat L Len) (Len = z), std.fold L Len (x\y\w\ sigma M\ get-max-arity-aux T x M, max-nat y M w) R. - get-max-arity-aux T (app [_|L]) R :- !, - std.fold L z (x\y\w\ sigma M\ get-max-arity-aux T x M, max-nat y M w) R. get-max-arity-aux T (fun _ Ty B) R2 :- !, get-max-arity-aux T Ty R, (pi x\ get-max-arity-aux T (B x) R1), @@ -108,15 +105,13 @@ namespace tc.precomp { get-max-arity-aux X Ty R1, get-max-arity-aux X T R2, (pi x\ get-max-arity-aux T (B x) R3), - max-nat R1 R2 R12, - max-nat R12 R3 R4. + max-nat {max-nat R1 R2} R3 R4. get-max-arity-aux A B _ :- coq.error "TC: get-max-arity-aux failure with" A B. func get-max-arity term, term, term -> nat. get-max-arity _ Ty _ N :- tc.get-TC-of-inst-type Ty _, !, count-prod Ty N. get-max-arity B _ T N :- !, get-max-arity-aux B T N. - :index (_ 1) func precompile-aux positivity, term, nat -> term, nat. precompile-aux _ X A Y A :- name X, !, X = Y, !. % avoid loading "precompile-aux x A x A" at binders From b9bfc4bd61eae7084136071f59f4db80796a9ff7 Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Wed, 17 Jun 2026 16:27:33 +0200 Subject: [PATCH 31/62] add comment to get-max-arity --- apps/tc/elpi/ho_precompile.elpi | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/apps/tc/elpi/ho_precompile.elpi b/apps/tc/elpi/ho_precompile.elpi index 17728deb8..5e8f22e81 100644 --- a/apps/tc/elpi/ho_precompile.elpi +++ b/apps/tc/elpi/ho_precompile.elpi @@ -108,9 +108,15 @@ namespace tc.precomp { max-nat {max-nat R1 R2} R3 R4. get-max-arity-aux A B _ :- coq.error "TC: get-max-arity-aux failure with" A B. + % [get-max-arity T Ty T' N] + % Invariant = T is of type Ty and T is a name + % returns the number of variables that shoud be quantified + % when compiling T, in particular: + % - if Ty a type-class, then we return the number of arguments of the class + % - otherwise, we count at which arity T is used in T' func get-max-arity term, term, term -> nat. get-max-arity _ Ty _ N :- tc.get-TC-of-inst-type Ty _, !, count-prod Ty N. - get-max-arity B _ T N :- !, get-max-arity-aux B T N. + get-max-arity T _ T' N :- !, get-max-arity-aux T T' N. :index (_ 1) func precompile-aux positivity, term, nat -> term, nat. @@ -178,7 +184,6 @@ namespace tc.precomp { get-univ T L :- coq.univ.variable.set.elements {coq.univ.variable.of-term T} Vars, std.map Vars (x\r\ coq.univ.variable r x) L. - } /* @@ -205,8 +210,6 @@ namespace tc.precomp { std.assert!(instance.precompile-aux instance.is_pos T z T' N) "[TC] cannot precompile instance". namespace goal { - - func precompile-aux term, list term -> term, list term. precompile-aux X A Y A :- name X, !, X = Y, !. % avoid loading "precompile-aux x A x A" at binders precompile-aux (global _ as C) A C A :- !. From 561756ac9b9121d929ad738cbe8575f5f1f16566 Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Wed, 17 Jun 2026 16:44:37 +0200 Subject: [PATCH 32/62] align comment --- apps/tc/elpi/ho_compile.elpi | 2 +- apps/tc/elpi/tc_aux.elpi | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/apps/tc/elpi/ho_compile.elpi b/apps/tc/elpi/ho_compile.elpi index 9473c6593..4847a3916 100644 --- a/apps/tc/elpi/ho_compile.elpi +++ b/apps/tc/elpi/ho_compile.elpi @@ -421,7 +421,7 @@ namespace tc { std.append L' L'' L. } - % Goal Goal' Links + % Goal Goal' Links func goal term -> term, list prop. :name "compile-goal" goal Goal Goal' Links :- diff --git a/apps/tc/elpi/tc_aux.elpi b/apps/tc/elpi/tc_aux.elpi index f281e53b9..86b4cbce9 100644 --- a/apps/tc/elpi/tc_aux.elpi +++ b/apps/tc/elpi/tc_aux.elpi @@ -293,7 +293,7 @@ namespace tc { type prod-range term -> % The current qunatified uvar - nat -> % Its minimum and maximal application + nat -> % Its maximal application of the term term. type maybe-eta-tm From 374940b1d3d5a5f0772db58ec4630c5d1d2b47c3 Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Wed, 17 Jun 2026 16:57:18 +0200 Subject: [PATCH 33/62] collapse namespace in ho_compile --- apps/tc/elpi/ho_compile.elpi | 846 +++++++++++++++++------------------ 1 file changed, 421 insertions(+), 425 deletions(-) diff --git a/apps/tc/elpi/ho_compile.elpi b/apps/tc/elpi/ho_compile.elpi index 4847a3916..4df169326 100644 --- a/apps/tc/elpi/ho_compile.elpi +++ b/apps/tc/elpi/ho_compile.elpi @@ -1,435 +1,431 @@ -namespace tc { - shorten tc.{r-ar, range-arity}. - - namespace compile { - - namespace instance { - func is-name term ->. - func is-uvar term ->. - - % [name-pair H0 Hn Ar] - % the variable H0 (applied 0 time) is associated to the variable Hn which is - % applied Ar times. - pred name-pair o:term, o:term, o:nat. - - namespace decompile { - - func decompile-term-aux term, pair (list term) (list prop) -> term, pair (list term) (list prop). - - decompile-term-aux X A Y A :- name X, !, X = Y, !. % avoid loading "decompile-term-aux x A x A" at binders - decompile-term-aux (global _ as C) A C A :- !. - decompile-term-aux (pglobal _ _ as T) L T' L :- !, copy T T', !. - decompile-term-aux (sort _ as T) L T' L :- !, copy T T', !. - decompile-term-aux (uvar as X) L X L :- !. - decompile-term-aux (primitive _ as P) L P L :- !. - - :name "decompile-inst-maybe-proj" - decompile-term-aux (tc.maybe-proj T S) (pr [X|XS] L1) Y (pr XS [NL|L1]) :- !, - name Y X S, NL = tc.link.proj T Y. - - decompile-term-aux (tc.maybe-eta-tm T S) (pr [X|XS] L1) Y (pr XS' [NL | L2]) :- !, - name Y X S, - decompile-term-aux T (pr XS L1) T' (pr XS' L2), - NL = tc.link.eta Y T'. - - decompile-term-aux (tc.prod-range T _) A T' A' :- !, - decompile-term-aux T A T' A'. - - % Maybe-llam when H is a coq unif variable quantified in the instance type - % In the following instance, X is a HO variable applied to a constant (not a name) - % Instance i : forall (X : T1 -> T2) (a : T1), c (X a). - decompile-term-aux (tc.maybe-llam-tm (app[app[H | PF] | NPF]) S) (pr [X|XS] L1) Y (pr XS' [NL | L2]) :- - not (var H), !, % is-uvar H, holds - name Y X S, - length-nat PF Len, - std.assert!(name-pair H V Len) "[TC] fail to find name-pair", - name Hd V PF, - std.fold-map NPF (pr XS L1) decompile-term-aux Tl (pr XS' L2), - NL = tc.link.llam Y (app [Hd|Tl]). - - % Maybe-llam when H is a hole appearing in the shelved goals - % This happens when the instance to be compiled comes from the context - % Example: Goal exists (X : T1 -> T2), forall a, c (X a) -> ... - % intros; eexists. (* In the context we have the instance `H: c (?X a)` *) - decompile-term-aux (tc.maybe-llam-tm (app[app[H | PF] | NPF]) S) A Z (pr XS' [NL | L3]) :- !, - var H _ Scope, !, - std.append Scope S S', - prune Z S', - tc.compile.goal.make-pairs [T] Pairs, - % We build on the fly the eta-links for T - (Pairs => - (tc.compile.goal.build-eta-links-of-vars [T] P, - tc.compile.goal.get-uva-pair-arity T PF Y)), - std.fold-map NPF A decompile-term-aux Tl (pr XS' L2), - std.append P L2 L3, - NL = tc.link.llam Z (app [Y|Tl]). - - decompile-term-aux (fun Name Ty Bo) (pr XS L) (fun Name Ty' Bo') (pr XS2 L3) :- !, - (pi x\ is-name x => decompile-term-aux (Bo x) (pr XS []) (Bo' x) (pr XS1 (L1x x))), - close-term-no-prune-ty L1x {clean-term Ty} L1, - decompile-term-aux Ty (pr XS1 L) Ty' (pr XS2 L2), - std.append L1 L2 L3. - - decompile-term-aux (prod Name Ty Bo) (pr XS L) (prod Name Ty' Bo') (pr XS2 L3) :- !, - (pi x\ is-name x => decompile-term-aux (Bo x) (pr XS []) (Bo' x) (pr XS1 (L1x x))), - close-term-no-prune-ty L1x {clean-term Ty} L1, - decompile-term-aux Ty (pr XS1 L) Ty' (pr XS2 L2), - std.append L1 L2 L3. - - % HO var when H is a quantified variable in the instance type being in PF - % Example: Instance i: forall (X : T1 -> T2), (forall a, c1 (X a)) -> c2. - % Note: X is the HO var taken into account which is applied to the list of - % distinct_names [a] - decompile-term-aux (app [H|L]) N R N :- - is-uvar H, - std.forall L is-name, % Not needed, since precompile does this check - distinct_names L, !, % Not needed, since precompile does this check - length-nat L Len, - std.assert! (name-pair H V Len) "[TC] name-pair not found", - name R V L. - - % HO var when H is a hole appearing in the shelved goals - decompile-term-aux (app [T|L]) (pr A B) Z (pr A B') :- - var T _ Scope, - std.forall L is-name, % Not needed, since decompile for llam leaves only PF - distinct_names L, !, % Not needed, since decompile for llam leaves only PF - std.append Scope L Scope', - prune Z Scope', - tc.compile.goal.make-pairs [T] Pairs, - % We build on the fly the eta-links for `T` - (Pairs => - (tc.compile.goal.build-eta-links-of-vars [T] P, - tc.compile.goal.get-uva-pair-arity T L Y)), - var Z Y Scope', - std.append P B B'. - - decompile-term-aux (app L) PR (app L') PR' :- !, - std.fold-map L PR decompile-term-aux L' PR'. - - decompile-term-aux (let N T Ty Bo) PR (let N T' Ty' Bo') PR3 :- !, - decompile-term-aux T PR T' PR1, - decompile-term-aux Ty PR1 Ty' PR2, - (pi x\ is-name x => decompile-term-aux (Bo x) PR2 (Bo' x) PR3). - - decompile-term-aux A B _ _ :- coq.error "[TC] cannot decompile-term-aux of" A B. - - :functional - pred decompile-term i:list term, o:list term, i:term, o:term, o:list prop. - decompile-term L L' T R Links :- - decompile-term-aux T (pr L []) R (pr L' Links). - - } - - % TODO: also replace (sort (typ X)) and (pglobal _ X) with holes in the place of X - func clean-term term -> term. - clean-term A B :- - (pi t s r \ copy (tc.maybe-proj t s) t :- !) => - (pi t s r \ copy (tc.maybe-eta-tm t s) r :- !, copy t r, !) => - (pi t s r \ copy (tc.prod-range t s) r :- !, copy t r, !) => - (pi t s r \ copy (tc.maybe-llam-tm t s) r :- !, copy t r, !) => - std.assert! (copy A B) "[TC] clean-term error". - - func main - nat, % the number of problematic terms - term, % the type of the instance - term, % the global gref of the instance - list univ, % the list of univ variable to be replaced with elpi fresh vars - list univ-instance % the list of univ-instance to be replaced with elpi fresh vars - -> prop. % the compiled clause for the instance - - main N Ty ProofHd [] [] Clause :- - add-pi-problematic-terms N [] Ty ProofHd Clause. - main N Ty ProofHd [Univ | UnivL] UnivInstL (pi x\ Clause x) :- !, - pi x\ (copy (sort (typ Univ)) (sort (typ x)) :- !) => - main N Ty ProofHd UnivL UnivInstL (Clause x). - main N Ty ProofHd [] [UnivInst | UnivInstL] (pi x\ Clause x) :- !, - pi x\ (copy (pglobal A UnivInst) (pglobal A x) :- !) => - main N Ty ProofHd [] UnivInstL (Clause x). - - - % Start to charge the right number of pi for the resulting clause: - % This number is equal to the number of problematic terms + number of subterms with shape `sort _` and `pglobal _ _` - func add-pi-problematic-terms - nat, % the number of pi to quantify - list term, % the list of quantified pi - term, % the fuel of the compilation (the type of the instance) - term % the global gref of the current instance - -> prop. % the compiled clause for the instance - - add-pi-problematic-terms z L Ty ProofHd Clause :- - compile-ty L _ ProofHd tt Ty [] [] Clause. - add-pi-problematic-terms (s N) L Ty ProofHd (pi x\ Clause x) :- - pi x\ is-uvar x => add-pi-problematic-terms N [x|L] Ty ProofHd (Clause x). - - % Builds a eta link between the varibale A whose type _must_ be of type `prod` - % A is linked with B : A =_eta (fun (x : Ty) => B_x) - func make-eta-link-aux - term, % A : The variable to eta-expand - term, % prod _ Ty Bo : The type of A - pair term name, % pr B Bn : The eta-expanded version of B with its name (they are fresh names) - list term % L : The list of name in the scope of A and B - -> prop, % Link : The new eta-link - term, % Ty' : The cleaned version of the binder in Ty - (term -> term). % Bo : the body of the type of A - make-eta-link-aux A (prod _ Ty Bo) (pr B Name) L Link Ty' Bo :- !, - clean-term Ty Ty', - name A' A {std.rev L}, - Link = tc.link.eta A' (fun Name Ty' B'), - pi x\ sigma L'\ std.rev [x|L] L', name (B' x) B L'. - % Going under prod-range - make-eta-link-aux A (tc.prod-range Prod _) BN L Link Ty' Bo :- !, - make-eta-link-aux A Prod BN L Link Ty' Bo. - % The type of a higher order variable can be hidden behind a definition - % In this case we unfold this definition to get the prod constructor - make-eta-link-aux A T BN L Link Ty' Bo :- - coq.safe-dest-app T Hd Ag, - (@redflags! coq.redflags.delta => coq.reduction.lazy.whd Hd Hd'), - not (Hd = Hd'), !, - coq.mk-app Hd' Ag TT', - make-eta-link-aux A TT' BN L Link Ty' Bo. - make-eta-link-aux _ T _ _ _ _ _ :- coq.error "[TC] make-eta-link-aux of" T. - - % Create spine of eta-links - :index (_ _ 1) - func make-eta-link term, term, list (pair term name), list term, list prop -> prop. - make-eta-link P PTy [Hd] L Links (do [Link1|Links]) :- !, - make-eta-link-aux P PTy Hd L Link1 _ _. - make-eta-link P PTy [(pr B _ as Hd)|Tl] L Links (pi x\ decl x `x` PTy' => Res x) :- !, - make-eta-link-aux P PTy Hd L Link1 PTy' Bo, - pi x\ make-eta-link B (Bo x) Tl [x|L] [Link1|Links] (Res x). - make-eta-link P PTy _ _ _ _ :- coq.error "[TC] make-eta-link error : empty list of pairs" P PTy. - - % Accumulates pi for eta-links - :index (_ 1) - func add-link-eta-dedup - (func list prop -> prop), - nat, term, term, (list (pair term name)), list prop -> prop. - % Base case when the variable is always used at same arity - add-link-eta-dedup F z _ _ [] PremR Clause :- !, - F PremR Clause. - add-link-eta-dedup F z P Pty Acc PremR Clause :- !, - make-eta-link P Pty Acc [] [] LinkEtaDedup, - F [LinkEtaDedup|PremR] Clause. - add-link-eta-dedup F (s N) P PTy Acc PremR (pi x y\ Clause x y) :- !, - pi x y\ name-pair P x (s N) => is-uvar x => add-link-eta-dedup F N P PTy [pr x y|Acc] PremR (Clause x y). - add-link-eta-dedup _ Ar P PTy _ _ _ :- coq.error "[TC] add-link-eta-dedup error" Ar P PTy. +namespace tc.compile { + namespace instance { + func is-name term ->. + func is-uvar term ->. + + % [name-pair H0 Hn Ar] + % the variable H0 (applied 0 time) is associated to the variable Hn which is + % applied Ar times. + pred name-pair o:term, o:term, o:nat. + + namespace decompile { + + func decompile-term-aux term, pair (list term) (list prop) -> term, pair (list term) (list prop). + + decompile-term-aux X A Y A :- name X, !, X = Y, !. % avoid loading "decompile-term-aux x A x A" at binders + decompile-term-aux (global _ as C) A C A :- !. + decompile-term-aux (pglobal _ _ as T) L T' L :- !, copy T T', !. + decompile-term-aux (sort _ as T) L T' L :- !, copy T T', !. + decompile-term-aux (uvar as X) L X L :- !. + decompile-term-aux (primitive _ as P) L P L :- !. + + :name "decompile-inst-maybe-proj" + decompile-term-aux (tc.maybe-proj T S) (pr [X|XS] L1) Y (pr XS [NL|L1]) :- !, + name Y X S, NL = tc.link.proj T Y. + + decompile-term-aux (tc.maybe-eta-tm T S) (pr [X|XS] L1) Y (pr XS' [NL | L2]) :- !, + name Y X S, + decompile-term-aux T (pr XS L1) T' (pr XS' L2), + NL = tc.link.eta Y T'. + + decompile-term-aux (tc.prod-range T _) A T' A' :- !, + decompile-term-aux T A T' A'. + + % Maybe-llam when H is a coq unif variable quantified in the instance type + % In the following instance, X is a HO variable applied to a constant (not a name) + % Instance i : forall (X : T1 -> T2) (a : T1), c (X a). + decompile-term-aux (tc.maybe-llam-tm (app[app[H | PF] | NPF]) S) (pr [X|XS] L1) Y (pr XS' [NL | L2]) :- + not (var H), !, % is-uvar H, holds + name Y X S, + length-nat PF Len, + std.assert!(name-pair H V Len) "[TC] fail to find name-pair", + name Hd V PF, + std.fold-map NPF (pr XS L1) decompile-term-aux Tl (pr XS' L2), + NL = tc.link.llam Y (app [Hd|Tl]). + + % Maybe-llam when H is a hole appearing in the shelved goals + % This happens when the instance to be compiled comes from the context + % Example: Goal exists (X : T1 -> T2), forall a, c (X a) -> ... + % intros; eexists. (* In the context we have the instance `H: c (?X a)` *) + decompile-term-aux (tc.maybe-llam-tm (app[app[H | PF] | NPF]) S) A Z (pr XS' [NL | L3]) :- !, + var H _ Scope, !, + std.append Scope S S', + prune Z S', + tc.compile.goal.make-pairs [T] Pairs, + % We build on the fly the eta-links for T + (Pairs => + (tc.compile.goal.build-eta-links-of-vars [T] P, + tc.compile.goal.get-uva-pair-arity T PF Y)), + std.fold-map NPF A decompile-term-aux Tl (pr XS' L2), + std.append P L2 L3, + NL = tc.link.llam Z (app [Y|Tl]). + + decompile-term-aux (fun Name Ty Bo) (pr XS L) (fun Name Ty' Bo') (pr XS2 L3) :- !, + (pi x\ is-name x => decompile-term-aux (Bo x) (pr XS []) (Bo' x) (pr XS1 (L1x x))), + close-term-no-prune-ty L1x {clean-term Ty} L1, + decompile-term-aux Ty (pr XS1 L) Ty' (pr XS2 L2), + std.append L1 L2 L3. + + decompile-term-aux (prod Name Ty Bo) (pr XS L) (prod Name Ty' Bo') (pr XS2 L3) :- !, + (pi x\ is-name x => decompile-term-aux (Bo x) (pr XS []) (Bo' x) (pr XS1 (L1x x))), + close-term-no-prune-ty L1x {clean-term Ty} L1, + decompile-term-aux Ty (pr XS1 L) Ty' (pr XS2 L2), + std.append L1 L2 L3. + % HO var when H is a quantified variable in the instance type being in PF + % Example: Instance i: forall (X : T1 -> T2), (forall a, c1 (X a)) -> c2. + % Note: X is the HO var taken into account which is applied to the list of + % distinct_names [a] + decompile-term-aux (app [H|L]) N R N :- + is-uvar H, + std.forall L is-name, % Not needed, since precompile does this check + distinct_names L, !, % Not needed, since precompile does this check + length-nat L Len, + std.assert! (name-pair H V Len) "[TC] name-pair not found", + name R V L. + + % HO var when H is a hole appearing in the shelved goals + decompile-term-aux (app [T|L]) (pr A B) Z (pr A B') :- + var T _ Scope, + std.forall L is-name, % Not needed, since decompile for llam leaves only PF + distinct_names L, !, % Not needed, since decompile for llam leaves only PF + std.append Scope L Scope', + prune Z Scope', + tc.compile.goal.make-pairs [T] Pairs, + % We build on the fly the eta-links for `T` + (Pairs => + (tc.compile.goal.build-eta-links-of-vars [T] P, + tc.compile.goal.get-uva-pair-arity T L Y)), + var Z Y Scope', + std.append P B B'. + + decompile-term-aux (app L) PR (app L') PR' :- !, + std.fold-map L PR decompile-term-aux L' PR'. + + decompile-term-aux (let N T Ty Bo) PR (let N T' Ty' Bo') PR3 :- !, + decompile-term-aux T PR T' PR1, + decompile-term-aux Ty PR1 Ty' PR2, + (pi x\ is-name x => decompile-term-aux (Bo x) PR2 (Bo' x) PR3). + + decompile-term-aux A B _ _ :- coq.error "[TC] cannot decompile-term-aux of" A B. + :functional - pred compile-premise - i:list term, % L : a list of pi-quantified variables (used as elpi unification variables when building links) - o:list term, % L' : a suffix of L containing the still unused variables - i:term, % P : the premise of an instance whose applicative head is a class - i:term, % Pt : the type of P - i:term, % I : the instance at toplevel that triggered the instance compilation - i:bool, % B : tells if the premise P is in positive or negative position - i:term, % It : the type of I that has not yet been explored - i:list term, % Ag : the arguments of I that will be part of the proof - i:list prop, % Pr : the premises of the rule - o:prop. % C : the final clause corresponding to the compilation of I - compile-premise L L2 P PTy ProofHd IsPositive ITy ProofTlR PremR Clause :- - ((pi a b c\ tc.get-TC-of-inst-type (tc.prod-range a c) b :- !, tc.get-TC-of-inst-type a b) => - tc.get-TC-of-inst-type PTy TC), !, - compile-ty L L1 P {neg IsPositive} PTy [] [] NewPrem, - if (tc.class TC _ tc.deterministic _) - (NewPrem' = std.once NewPrem) - (NewPrem' = NewPrem), !, - compile-ty L1 L2 ProofHd IsPositive ITy ProofTlR [NewPrem' | PremR] Clause. - compile-premise L L1 _ _ ProofHd IsPositive ITy ProofTlR PremR Clause :- - compile-ty L L1 ProofHd IsPositive ITy ProofTlR PremR Clause. - - :index (_ _ _ _ 1) - func compile-ty - list term, % L : a list of pi-quantified variables (used as elpi unification variables when building links) - list term, % L' : a suffix of L containing the still unused variables - term, % I : the premise of an instance whose applicative head is a class - bool, % B : tells if the premise P is in positive or negative position - term, % It : the type of I that has not yet been explored - list term, % Ag : the arguments of I that will be part of the proof - list prop % Pr : the premises of the rule - -> prop. % C : the final clause corresponding to the compilation of I - compile-ty L L1 ProofHd IsPositive (tc.prod-range (prod N Ty Bo) Arity) ProofTlR PremR Clause :- !, - std.do![ - if (IsPositive = tt) - (Clause = (pi x\ C x), E = is-uvar) - (clean-term Ty Ty', Clause = (pi x\ decl x N Ty' => C x), E = is-name), - pi p\ sigma F\ - F = compile-premise L L1 p Ty ProofHd IsPositive (Bo p) [p|ProofTlR], - decl p N Ty' => - name-pair p p z => E p => add-link-eta-dedup F Arity p Ty [] PremR (C p) - ]. - compile-ty L L1 ProofHd IsPositive (let _ Ty T Bo) ProofTlR PremR Clause :- !, + pred decompile-term i:list term, o:list term, i:term, o:term, o:list prop. + decompile-term L L' T R Links :- + decompile-term-aux T (pr L []) R (pr L' Links). + + } + + % TODO: also replace (sort (typ X)) and (pglobal _ X) with holes in the place of X + func clean-term term -> term. + clean-term A B :- + (pi t s r \ copy (tc.maybe-proj t s) t :- !) => + (pi t s r \ copy (tc.maybe-eta-tm t s) r :- !, copy t r, !) => + (pi t s r \ copy (tc.prod-range t s) r :- !, copy t r, !) => + (pi t s r \ copy (tc.maybe-llam-tm t s) r :- !, copy t r, !) => + std.assert! (copy A B) "[TC] clean-term error". + + func main + nat, % the number of problematic terms + term, % the type of the instance + term, % the global gref of the instance + list univ, % the list of univ variable to be replaced with elpi fresh vars + list univ-instance % the list of univ-instance to be replaced with elpi fresh vars + -> prop. % the compiled clause for the instance + + main N Ty ProofHd [] [] Clause :- + add-pi-problematic-terms N [] Ty ProofHd Clause. + main N Ty ProofHd [Univ | UnivL] UnivInstL (pi x\ Clause x) :- !, + pi x\ (copy (sort (typ Univ)) (sort (typ x)) :- !) => + main N Ty ProofHd UnivL UnivInstL (Clause x). + main N Ty ProofHd [] [UnivInst | UnivInstL] (pi x\ Clause x) :- !, + pi x\ (copy (pglobal A UnivInst) (pglobal A x) :- !) => + main N Ty ProofHd [] UnivInstL (Clause x). + + + % Start to charge the right number of pi for the resulting clause: + % This number is equal to the number of problematic terms + number of subterms with shape `sort _` and `pglobal _ _` + func add-pi-problematic-terms + nat, % the number of pi to quantify + list term, % the list of quantified pi + term, % the fuel of the compilation (the type of the instance) + term % the global gref of the current instance + -> prop. % the compiled clause for the instance + + add-pi-problematic-terms z L Ty ProofHd Clause :- + compile-ty L _ ProofHd tt Ty [] [] Clause. + add-pi-problematic-terms (s N) L Ty ProofHd (pi x\ Clause x) :- + pi x\ is-uvar x => add-pi-problematic-terms N [x|L] Ty ProofHd (Clause x). + + % Builds a eta link between the varibale A whose type _must_ be of type `prod` + % A is linked with B : A =_eta (fun (x : Ty) => B_x) + func make-eta-link-aux + term, % A : The variable to eta-expand + term, % prod _ Ty Bo : The type of A + pair term name, % pr B Bn : The eta-expanded version of B with its name (they are fresh names) + list term % L : The list of name in the scope of A and B + -> prop, % Link : The new eta-link + term, % Ty' : The cleaned version of the binder in Ty + (term -> term). % Bo : the body of the type of A + make-eta-link-aux A (prod _ Ty Bo) (pr B Name) L Link Ty' Bo :- !, + clean-term Ty Ty', + name A' A {std.rev L}, + Link = tc.link.eta A' (fun Name Ty' B'), + pi x\ sigma L'\ std.rev [x|L] L', name (B' x) B L'. + % Going under prod-range + make-eta-link-aux A (tc.prod-range Prod _) BN L Link Ty' Bo :- !, + make-eta-link-aux A Prod BN L Link Ty' Bo. + % The type of a higher order variable can be hidden behind a definition + % In this case we unfold this definition to get the prod constructor + make-eta-link-aux A T BN L Link Ty' Bo :- + coq.safe-dest-app T Hd Ag, + (@redflags! coq.redflags.delta => coq.reduction.lazy.whd Hd Hd'), + not (Hd = Hd'), !, + coq.mk-app Hd' Ag TT', + make-eta-link-aux A TT' BN L Link Ty' Bo. + make-eta-link-aux _ T _ _ _ _ _ :- coq.error "[TC] make-eta-link-aux of" T. + + % Create spine of eta-links + :index (_ _ 1) + func make-eta-link term, term, list (pair term name), list term, list prop -> prop. + make-eta-link P PTy [Hd] L Links (do [Link1|Links]) :- !, + make-eta-link-aux P PTy Hd L Link1 _ _. + make-eta-link P PTy [(pr B _ as Hd)|Tl] L Links (pi x\ decl x `x` PTy' => Res x) :- !, + make-eta-link-aux P PTy Hd L Link1 PTy' Bo, + pi x\ make-eta-link B (Bo x) Tl [x|L] [Link1|Links] (Res x). + make-eta-link P PTy _ _ _ _ :- coq.error "[TC] make-eta-link error : empty list of pairs" P PTy. + + % Accumulates pi for eta-links + :index (_ 1) + func add-link-eta-dedup + (func list prop -> prop), + nat, term, term, (list (pair term name)), list prop -> prop. + % Base case when the variable is always used at same arity + add-link-eta-dedup F z _ _ [] PremR Clause :- !, + F PremR Clause. + add-link-eta-dedup F z P Pty Acc PremR Clause :- !, + make-eta-link P Pty Acc [] [] LinkEtaDedup, + F [LinkEtaDedup|PremR] Clause. + add-link-eta-dedup F (s N) P PTy Acc PremR (pi x y\ Clause x y) :- !, + pi x y\ name-pair P x (s N) => is-uvar x => add-link-eta-dedup F N P PTy [pr x y|Acc] PremR (Clause x y). + add-link-eta-dedup _ Ar P PTy _ _ _ :- coq.error "[TC] add-link-eta-dedup error" Ar P PTy. + + :functional + pred compile-premise + i:list term, % L : a list of pi-quantified variables (used as elpi unification variables when building links) + o:list term, % L' : a suffix of L containing the still unused variables + i:term, % P : the premise of an instance whose applicative head is a class + i:term, % Pt : the type of P + i:term, % I : the instance at toplevel that triggered the instance compilation + i:bool, % B : tells if the premise P is in positive or negative position + i:term, % It : the type of I that has not yet been explored + i:list term, % Ag : the arguments of I that will be part of the proof + i:list prop, % Pr : the premises of the rule + o:prop. % C : the final clause corresponding to the compilation of I + compile-premise L L2 P PTy ProofHd IsPositive ITy ProofTlR PremR Clause :- + ((pi a b c\ tc.get-TC-of-inst-type (tc.prod-range a c) b :- !, tc.get-TC-of-inst-type a b) => + tc.get-TC-of-inst-type PTy TC), !, + compile-ty L L1 P {neg IsPositive} PTy [] [] NewPrem, + if (tc.class TC _ tc.deterministic _) + (NewPrem' = std.once NewPrem) + (NewPrem' = NewPrem), !, + compile-ty L1 L2 ProofHd IsPositive ITy ProofTlR [NewPrem' | PremR] Clause. + compile-premise L L1 _ _ ProofHd IsPositive ITy ProofTlR PremR Clause :- + compile-ty L L1 ProofHd IsPositive ITy ProofTlR PremR Clause. + + :index (_ _ _ _ 1) + func compile-ty + list term, % L : a list of pi-quantified variables (used as elpi unification variables when building links) + list term, % L' : a suffix of L containing the still unused variables + term, % I : the premise of an instance whose applicative head is a class + bool, % B : tells if the premise P is in positive or negative position + term, % It : the type of I that has not yet been explored + list term, % Ag : the arguments of I that will be part of the proof + list prop % Pr : the premises of the rule + -> prop. % C : the final clause corresponding to the compilation of I + compile-ty L L1 ProofHd IsPositive (tc.prod-range (prod N Ty Bo) Arity) ProofTlR PremR Clause :- !, + std.do![ if (IsPositive = tt) (Clause = (pi x\ C x), E = is-uvar) - (clean-term Ty Ty', Clause = (pi x\ decl x N Ty' => C x), E = is-name), !, - pi p\ sigma F NewPrem\ - (decl p N Ty' :- !) => (E p :- !) => ( - NewPrem = tc.link.unif-eq T p, - compile-premise L L1 p Ty ProofHd IsPositive (Bo p) ProofTlR [NewPrem | PremR] (C p) - ). - - compile-ty L L2 ProofHd IsPositive Goal ProofTlR PremR Clause :- - std.do![ - coq.mk-app ProofHd {std.rev ProofTlR} Proof, - decompile.decompile-term L L1 Proof Proof' Prem1, - decompile.decompile-term L1 L2 Goal Goal' Prem2, - compile-conclusion IsPositive Goal' Proof' Prem2 Prem1 {std.rev PremR} Clause - ]. - - func compile-conclusion - bool, % tt if the term is in positive position - term, % the goal (invariant: it is a constant or a application) - term, % the proof - list prop, % the list of HOPremises in input mode - list prop, % the list of HOPremises in output mode - list prop % the premises - -> prop. % the compiled clause for the instance - - compile-conclusion tt Goal Proof HOPremisesIn HOPremisesOut Premises Clause :- - std.append {std.append HOPremisesIn Premises} HOPremisesOut AllPremises, - tc.make-tc Goal Proof AllPremises tt Clause. - compile-conclusion ff Goal Proof HOPremisesIn HOPremisesOut Premises Clause :- - tc.make-tc Goal Proof Premises ff Clause1, - Clause = (do HOPremisesIn, Clause1, do HOPremisesOut). - - func context goal-ctx -> list prop. - context [] []. - % if the hyp is for a TC we compile before its insertion in the context - context [X | Xs] [Clause | ResTl] :- - (decl Var _ Ty = X; def Var _ Ty _ = X), - tc.is-instance-term Ty, !, - std.assert! (compile.instance Ty Var Clause) "[TC] cannot compile instance of context", - context Xs ResTl. - context [_ | Tl] L :- context Tl L. - } + (clean-term Ty Ty', Clause = (pi x\ decl x N Ty' => C x), E = is-name), + pi p\ sigma F\ + F = compile-premise L L1 p Ty ProofHd IsPositive (Bo p) [p|ProofTlR], + decl p N Ty' => + name-pair p p z => E p => add-link-eta-dedup F Arity p Ty [] PremR (C p) + ]. + compile-ty L L1 ProofHd IsPositive (let _ Ty T Bo) ProofTlR PremR Clause :- !, + if (IsPositive = tt) + (Clause = (pi x\ C x), E = is-uvar) + (clean-term Ty Ty', Clause = (pi x\ decl x N Ty' => C x), E = is-name), !, + pi p\ sigma F NewPrem\ + (decl p N Ty' :- !) => (E p :- !) => ( + NewPrem = tc.link.unif-eq T p, + compile-premise L L1 p Ty ProofHd IsPositive (Bo p) ProofTlR [NewPrem | PremR] (C p) + ). + + compile-ty L L2 ProofHd IsPositive Goal ProofTlR PremR Clause :- + std.do![ + coq.mk-app ProofHd {std.rev ProofTlR} Proof, + decompile.decompile-term L L1 Proof Proof' Prem1, + decompile.decompile-term L1 L2 Goal Goal' Prem2, + compile-conclusion IsPositive Goal' Proof' Prem2 Prem1 {std.rev PremR} Clause + ]. + + func compile-conclusion + bool, % tt if the term is in positive position + term, % the goal (invariant: it is a constant or a application) + term, % the proof + list prop, % the list of HOPremises in input mode + list prop, % the list of HOPremises in output mode + list prop % the premises + -> prop. % the compiled clause for the instance + + compile-conclusion tt Goal Proof HOPremisesIn HOPremisesOut Premises Clause :- + std.append {std.append HOPremisesIn Premises} HOPremisesOut AllPremises, + tc.make-tc Goal Proof AllPremises tt Clause. + compile-conclusion ff Goal Proof HOPremisesIn HOPremisesOut Premises Clause :- + tc.make-tc Goal Proof Premises ff Clause1, + Clause = (do HOPremisesIn, Clause1, do HOPremisesOut). - % build a list of Clauses of type tc to be temporarly added to the - % database, used in theorems having assumptions. func context goal-ctx -> list prop. - :name "tc-compile-context" - context Ctx Clauses :- - std.assert! (instance.context Ctx Clauses) "[TC] cannot compile context". - - func instance term, term -> prop. - instance Ty ProofHd Clause :- - tc.time-it tc.oTC-time-compile-instance ( - tc.normalize-ty Ty Ty', - tc.precomp.instance Ty' Ty'' N UnivConst UnivInst, - instance.main N Ty'' ProofHd UnivConst UnivInst Clause - ) "Compile Instance", !. - - func instance-gr gref -> prop. - % If the instance is polymorphic, we wrap its gref into the pglobal constructor - instance-gr InstGR (pi x\ Clause x) :- coq.env.univpoly? InstGR _, !, - coq.env.typeof InstGR Ty, - pi x\ tc.compile.instance Ty (pglobal InstGR x) (Clause x). - instance-gr InstGR Clause :- - coq.env.typeof InstGR Ty, - tc.compile.instance Ty (global InstGR) Clause. - - namespace goal { - % [uvar-pair V1 Ty V2] List of uvar for link-eta-dedup - % V1 has arity n and V2 has arity n+1 - % If V1 has type A -> B, then A = Ty - pred uvar-pair i:term, o:term, o:term. - - % Type Var Cnt uvar-pair-list - func make-pairs-aux term, term -> list prop. - make-pairs-aux (prod _ Ty Bo) V [pi x\ uvar-pair x Ty X' :- x == V, ! | L] :- !, - pi x\ make-pairs-aux (Bo x) X' L. - make-pairs-aux _ _ []. - - func make-pairs list term -> list prop. - make-pairs [] [] :- !. - make-pairs [X|Xs] L :- !, - coq.typecheck X Ty ok, - make-pairs-aux Ty X L', - make-pairs Xs L'', - std.append L' L'' L. - - func get-uva-pair-arity term, list term -> term. - get-uva-pair-arity X [] X :- !. - get-uva-pair-arity X [_|L] Z :- uvar-pair X _ Y, !, - get-uva-pair-arity Y L Z. - - func decompile-problematic-term term, list prop -> term, list prop. - decompile-problematic-term (tc.maybe-eta-tm T S) L V [tc.link.eta V T' | L2] :- - prune V S, !, fold-map T L T' L2. - - decompile-problematic-term (tc.maybe-proj A S) L X [NL|L] :- !, - prune X S, - NL = tc.link.proj A X. - - decompile-problematic-term (tc.prod-range T _) A T' A' :- !, - fold-map T A T' A'. - - decompile-problematic-term (tc.maybe-llam-tm (app [app[H|S] | NPF]) Sc) L Z [NL|L'] :- !, - prune Z Sc, - get-uva-pair-arity H S Y, - std.fold-map NPF L fold-map Tl L', - NL = tc.link.llam Z (app[Y | Tl]). - - % TODO: complete this fold - decompile-problematic-term (app[X|S]) L Z L :- - var X _ Scope, - std.append Scope S Scope', - distinct_names Scope', !, - get-uva-pair-arity X S Y, - prune Z Scope', var Z Y Scope'. - - decompile-problematic-term A L A L :- var A, !. - - decompile-problematic-term (fun N Ty Bo) L (fun N Ty' Bo') L3 :- - fold-map Ty L Ty' L1, - (pi x\ fold-map (Bo x) [] (Bo' x) (Lx x)), - close-term-no-prune-ty Lx Ty' L2, - std.append L1 L2 L3. + context [] []. + % if the hyp is for a TC we compile before its insertion in the context + context [X | Xs] [Clause | ResTl] :- + (decl Var _ Ty = X; def Var _ Ty _ = X), + tc.is-instance-term Ty, !, + std.assert! (instance Ty Var Clause) "[TC] cannot compile instance of context", + context Xs ResTl. + context [_ | Tl] L :- context Tl L. + } - decompile-problematic-term (prod N Ty Bo) L (prod N Ty' Bo') L3 :- - (pi x\ fold-map (Bo x) [] (Bo' x) (Lx x)), - close-term-no-prune-ty Lx Ty L1, - fold-map Ty L Ty' L2, - std.append L2 L1 L3. - - func compile term, list prop -> term, list prop. - compile T L T' L' :- - (pi t l t' l'\ fold-map t l t' l' :- decompile-problematic-term t l t' l', !) => - fold-map T L T' L'. - - % Uva Binders LinkEta - func build-eta-links-of-vars-aux term, list term -> list prop. - build-eta-links-of-vars-aux Old L [Hd | Xs] :- - uvar-pair Old Ty Next, !, - prune OldScope L, - prune Name L, - var OldScope Old L, - Hd = tc.link.eta OldScope (fun Name Ty (x\ NextScope x)), - pi x\ sigma L'\ - std.append L [x] L', - prune (NextScope x) L', - var (NextScope x) Next L', - build-eta-links-of-vars-aux Next L' (Ys x), !, - sigma Closed\ (close-term-no-prune-ty Ys Ty Closed), - Xs = Closed. - build-eta-links-of-vars-aux _ _ []. - - func build-eta-links-of-vars list term -> list prop. - build-eta-links-of-vars [] []. - build-eta-links-of-vars [V|Vars] L :- - var V Hd S, - build-eta-links-of-vars-aux Hd S L', - build-eta-links-of-vars Vars L'', - std.append L' L'' L. - } + % build a list of Clauses of type tc to be temporarly added to the + % database, used in theorems having assumptions. + func context goal-ctx -> list prop. + :name "tc-compile-context" + context Ctx Clauses :- + std.assert! (instance.context Ctx Clauses) "[TC] cannot compile context". + + func instance term, term -> prop. + instance Ty ProofHd Clause :- + tc.time-it tc.oTC-time-compile-instance ( + tc.normalize-ty Ty Ty', + tc.precomp.instance Ty' Ty'' N UnivConst UnivInst, + instance.main N Ty'' ProofHd UnivConst UnivInst Clause + ) "Compile Instance", !. + + func instance-gr gref -> prop. + % If the instance is polymorphic, we wrap its gref into the pglobal constructor + instance-gr InstGR (pi x\ Clause x) :- coq.env.univpoly? InstGR _, !, + coq.env.typeof InstGR Ty, + pi x\ tc.compile.instance Ty (pglobal InstGR x) (Clause x). + instance-gr InstGR Clause :- + coq.env.typeof InstGR Ty, + tc.compile.instance Ty (global InstGR) Clause. + + namespace goal { + % [uvar-pair V1 Ty V2] List of uvar for link-eta-dedup + % V1 has arity n and V2 has arity n+1 + % If V1 has type A -> B, then A = Ty + pred uvar-pair i:term, o:term, o:term. + + % Type Var Cnt uvar-pair-list + func make-pairs-aux term, term -> list prop. + make-pairs-aux (prod _ Ty Bo) V [pi x\ uvar-pair x Ty X' :- x == V, ! | L] :- !, + pi x\ make-pairs-aux (Bo x) X' L. + make-pairs-aux _ _ []. + + func make-pairs list term -> list prop. + make-pairs [] [] :- !. + make-pairs [X|Xs] L :- !, + coq.typecheck X Ty ok, + make-pairs-aux Ty X L', + make-pairs Xs L'', + std.append L' L'' L. + + func get-uva-pair-arity term, list term -> term. + get-uva-pair-arity X [] X :- !. + get-uva-pair-arity X [_|L] Z :- uvar-pair X _ Y, !, + get-uva-pair-arity Y L Z. + + func decompile-problematic-term term, list prop -> term, list prop. + decompile-problematic-term (tc.maybe-eta-tm T S) L V [tc.link.eta V T' | L2] :- + prune V S, !, fold-map T L T' L2. + + decompile-problematic-term (tc.maybe-proj A S) L X [NL|L] :- !, + prune X S, + NL = tc.link.proj A X. + + decompile-problematic-term (tc.prod-range T _) A T' A' :- !, + fold-map T A T' A'. + + decompile-problematic-term (tc.maybe-llam-tm (app [app[H|S] | NPF]) Sc) L Z [NL|L'] :- !, + prune Z Sc, + get-uva-pair-arity H S Y, + std.fold-map NPF L fold-map Tl L', + NL = tc.link.llam Z (app[Y | Tl]). + + % TODO: complete this fold + decompile-problematic-term (app[X|S]) L Z L :- + var X _ Scope, + std.append Scope S Scope', + distinct_names Scope', !, + get-uva-pair-arity X S Y, + prune Z Scope', var Z Y Scope'. - % Goal Goal' Links - func goal term -> term, list prop. - :name "compile-goal" - goal Goal Goal' Links :- - tc.precomp.goal Goal GoalPrecomp Vars, !, - goal.make-pairs Vars Pairs, - Pairs => ( - std.assert!(goal.build-eta-links-of-vars Vars EtaLinks) "[TC] cannot build eta-links", - std.assert!(goal.compile GoalPrecomp EtaLinks Goal' Links) "[TC] cannot compile goal" - ). + decompile-problematic-term A L A L :- var A, !. + + decompile-problematic-term (fun N Ty Bo) L (fun N Ty' Bo') L3 :- + fold-map Ty L Ty' L1, + (pi x\ fold-map (Bo x) [] (Bo' x) (Lx x)), + close-term-no-prune-ty Lx Ty' L2, + std.append L1 L2 L3. + + decompile-problematic-term (prod N Ty Bo) L (prod N Ty' Bo') L3 :- + (pi x\ fold-map (Bo x) [] (Bo' x) (Lx x)), + close-term-no-prune-ty Lx Ty L1, + fold-map Ty L Ty' L2, + std.append L2 L1 L3. + + func compile term, list prop -> term, list prop. + compile T L T' L' :- + (pi t l t' l'\ fold-map t l t' l' :- decompile-problematic-term t l t' l', !) => + fold-map T L T' L'. + + % Uva Binders LinkEta + func build-eta-links-of-vars-aux term, list term -> list prop. + build-eta-links-of-vars-aux Old L [Hd | Xs] :- + uvar-pair Old Ty Next, !, + prune OldScope L, + prune Name L, + var OldScope Old L, + Hd = tc.link.eta OldScope (fun Name Ty (x\ NextScope x)), + pi x\ sigma L'\ + std.append L [x] L', + prune (NextScope x) L', + var (NextScope x) Next L', + build-eta-links-of-vars-aux Next L' (Ys x), !, + sigma Closed\ (close-term-no-prune-ty Ys Ty Closed), + Xs = Closed. + build-eta-links-of-vars-aux _ _ []. + + func build-eta-links-of-vars list term -> list prop. + build-eta-links-of-vars [] []. + build-eta-links-of-vars [V|Vars] L :- + var V Hd S, + build-eta-links-of-vars-aux Hd S L', + build-eta-links-of-vars Vars L'', + std.append L' L'' L. } + + % Goal Goal' Links + func goal term -> term, list prop. + :name "compile-goal" + goal Goal Goal' Links :- + tc.precomp.goal Goal GoalPrecomp Vars, !, + goal.make-pairs Vars Pairs, + Pairs => ( + std.assert!(goal.build-eta-links-of-vars Vars EtaLinks) "[TC] cannot build eta-links", + std.assert!(goal.compile GoalPrecomp EtaLinks Goal' Links) "[TC] cannot compile goal" + ). } + From cd54eb5547b8d3668c716ab822b8bd328f94cb30 Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Wed, 17 Jun 2026 17:12:36 +0200 Subject: [PATCH 34/62] curry decompile-term-aux --- apps/tc/elpi/ho_compile.elpi | 68 +++++++++++++++++++----------------- 1 file changed, 36 insertions(+), 32 deletions(-) diff --git a/apps/tc/elpi/ho_compile.elpi b/apps/tc/elpi/ho_compile.elpi index 4df169326..29464b61f 100644 --- a/apps/tc/elpi/ho_compile.elpi +++ b/apps/tc/elpi/ho_compile.elpi @@ -8,46 +8,50 @@ namespace tc.compile { % applied Ar times. pred name-pair o:term, o:term, o:nat. + func fold-map2 list A, B, D, (func A, B, D -> C, B, D) -> list C, B, D. + fold-map2 [] A B _ [] A B. + fold-map2 [X|XS] A B F [Y|YS] A2 B2 :- F X A B Y A1 B1, fold-map2 XS A1 B1 F YS A2 B2. + namespace decompile { - func decompile-term-aux term, pair (list term) (list prop) -> term, pair (list term) (list prop). + func decompile-term-aux term, list term, list prop -> term, list term, list prop. - decompile-term-aux X A Y A :- name X, !, X = Y, !. % avoid loading "decompile-term-aux x A x A" at binders - decompile-term-aux (global _ as C) A C A :- !. - decompile-term-aux (pglobal _ _ as T) L T' L :- !, copy T T', !. - decompile-term-aux (sort _ as T) L T' L :- !, copy T T', !. - decompile-term-aux (uvar as X) L X L :- !. - decompile-term-aux (primitive _ as P) L P L :- !. + decompile-term-aux X A L Y A L :- name X, !, X = Y, !. % avoid loading "decompile-term-aux x A x A" at binders + decompile-term-aux (global _ as C) A L C A L :- !. + decompile-term-aux (pglobal _ _ as T) A L T' A L :- !, copy T T', !. + decompile-term-aux (sort _ as T) A L T' A L :- !, copy T T', !. + decompile-term-aux (uvar as X) A L X A L :- !. + decompile-term-aux (primitive _ as P) A L P A L :- !. :name "decompile-inst-maybe-proj" - decompile-term-aux (tc.maybe-proj T S) (pr [X|XS] L1) Y (pr XS [NL|L1]) :- !, + decompile-term-aux (tc.maybe-proj T S) [X|XS] L1 Y XS [NL|L1] :- !, name Y X S, NL = tc.link.proj T Y. - decompile-term-aux (tc.maybe-eta-tm T S) (pr [X|XS] L1) Y (pr XS' [NL | L2]) :- !, + decompile-term-aux (tc.maybe-eta-tm T S) [X|XS] L1 Y XS' [NL | L2] :- !, name Y X S, - decompile-term-aux T (pr XS L1) T' (pr XS' L2), + decompile-term-aux T XS L1 T' XS' L2, NL = tc.link.eta Y T'. - decompile-term-aux (tc.prod-range T _) A T' A' :- !, - decompile-term-aux T A T' A'. + decompile-term-aux (tc.prod-range T _) A L T' A' L' :- !, + decompile-term-aux T A L T' A' L'. % Maybe-llam when H is a coq unif variable quantified in the instance type % In the following instance, X is a HO variable applied to a constant (not a name) % Instance i : forall (X : T1 -> T2) (a : T1), c (X a). - decompile-term-aux (tc.maybe-llam-tm (app[app[H | PF] | NPF]) S) (pr [X|XS] L1) Y (pr XS' [NL | L2]) :- + decompile-term-aux (tc.maybe-llam-tm (app[app[H | PF] | NPF]) S) [X|XS] L1 Y XS' [NL | L2] :- not (var H), !, % is-uvar H, holds name Y X S, length-nat PF Len, std.assert!(name-pair H V Len) "[TC] fail to find name-pair", name Hd V PF, - std.fold-map NPF (pr XS L1) decompile-term-aux Tl (pr XS' L2), + fold-map2 NPF XS L1 decompile-term-aux Tl XS' L2, NL = tc.link.llam Y (app [Hd|Tl]). % Maybe-llam when H is a hole appearing in the shelved goals % This happens when the instance to be compiled comes from the context % Example: Goal exists (X : T1 -> T2), forall a, c (X a) -> ... % intros; eexists. (* In the context we have the instance `H: c (?X a)` *) - decompile-term-aux (tc.maybe-llam-tm (app[app[H | PF] | NPF]) S) A Z (pr XS' [NL | L3]) :- !, + decompile-term-aux (tc.maybe-llam-tm (app[app[H | PF] | NPF]) S) A L Z XS' [NL | L3] :- !, var H _ Scope, !, std.append Scope S S', prune Z S', @@ -56,27 +60,27 @@ namespace tc.compile { (Pairs => (tc.compile.goal.build-eta-links-of-vars [T] P, tc.compile.goal.get-uva-pair-arity T PF Y)), - std.fold-map NPF A decompile-term-aux Tl (pr XS' L2), + fold-map2 NPF A L decompile-term-aux Tl XS' L2, std.append P L2 L3, NL = tc.link.llam Z (app [Y|Tl]). - decompile-term-aux (fun Name Ty Bo) (pr XS L) (fun Name Ty' Bo') (pr XS2 L3) :- !, - (pi x\ is-name x => decompile-term-aux (Bo x) (pr XS []) (Bo' x) (pr XS1 (L1x x))), + decompile-term-aux (fun Name Ty Bo) XS L (fun Name Ty' Bo') XS2 L3 :- !, + (pi x\ is-name x => decompile-term-aux (Bo x) XS [] (Bo' x) XS1 (L1x x)), close-term-no-prune-ty L1x {clean-term Ty} L1, - decompile-term-aux Ty (pr XS1 L) Ty' (pr XS2 L2), + decompile-term-aux Ty XS1 L Ty' XS2 L2, std.append L1 L2 L3. - decompile-term-aux (prod Name Ty Bo) (pr XS L) (prod Name Ty' Bo') (pr XS2 L3) :- !, - (pi x\ is-name x => decompile-term-aux (Bo x) (pr XS []) (Bo' x) (pr XS1 (L1x x))), + decompile-term-aux (prod Name Ty Bo) XS L (prod Name Ty' Bo') XS2 L3 :- !, + (pi x\ is-name x => decompile-term-aux (Bo x) XS [] (Bo' x) XS1 (L1x x)), close-term-no-prune-ty L1x {clean-term Ty} L1, - decompile-term-aux Ty (pr XS1 L) Ty' (pr XS2 L2), + decompile-term-aux Ty XS1 L Ty' XS2 L2, std.append L1 L2 L3. % HO var when H is a quantified variable in the instance type being in PF % Example: Instance i: forall (X : T1 -> T2), (forall a, c1 (X a)) -> c2. % Note: X is the HO var taken into account which is applied to the list of % distinct_names [a] - decompile-term-aux (app [H|L]) N R N :- + decompile-term-aux (app [H|L]) N A R N A :- is-uvar H, std.forall L is-name, % Not needed, since precompile does this check distinct_names L, !, % Not needed, since precompile does this check @@ -85,7 +89,7 @@ namespace tc.compile { name R V L. % HO var when H is a hole appearing in the shelved goals - decompile-term-aux (app [T|L]) (pr A B) Z (pr A B') :- + decompile-term-aux (app [T|L]) A B Z A B' :- var T _ Scope, std.forall L is-name, % Not needed, since decompile for llam leaves only PF distinct_names L, !, % Not needed, since decompile for llam leaves only PF @@ -99,20 +103,20 @@ namespace tc.compile { var Z Y Scope', std.append P B B'. - decompile-term-aux (app L) PR (app L') PR' :- !, - std.fold-map L PR decompile-term-aux L' PR'. + decompile-term-aux (app L) A PR (app L') A' PR' :- !, + fold-map2 L A PR decompile-term-aux L' A' PR'. - decompile-term-aux (let N T Ty Bo) PR (let N T' Ty' Bo') PR3 :- !, - decompile-term-aux T PR T' PR1, - decompile-term-aux Ty PR1 Ty' PR2, - (pi x\ is-name x => decompile-term-aux (Bo x) PR2 (Bo' x) PR3). + decompile-term-aux (let N T Ty Bo) A PR (let N T' Ty' Bo') A3 PR3 :- !, + decompile-term-aux T A PR T' A1 PR1, + decompile-term-aux Ty A1 PR1 Ty' A2 PR2, + (pi x\ is-name x => decompile-term-aux (Bo x) A2 PR2 (Bo' x) A3 PR3). - decompile-term-aux A B _ _ :- coq.error "[TC] cannot decompile-term-aux of" A B. + decompile-term-aux A B C _ _ _ :- coq.error "[TC] cannot decompile-term-aux of" A B C. :functional pred decompile-term i:list term, o:list term, i:term, o:term, o:list prop. decompile-term L L' T R Links :- - decompile-term-aux T (pr L []) R (pr L' Links). + decompile-term-aux T L [] R L' Links. } From 461b22b42124bbf8489c4ac9d560d3e8b503341a Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Wed, 17 Jun 2026 17:14:05 +0200 Subject: [PATCH 35/62] clean sig of fold-map2 --- apps/tc/elpi/ho_compile.elpi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/apps/tc/elpi/ho_compile.elpi b/apps/tc/elpi/ho_compile.elpi index 29464b61f..e3e0ec995 100644 --- a/apps/tc/elpi/ho_compile.elpi +++ b/apps/tc/elpi/ho_compile.elpi @@ -8,7 +8,7 @@ namespace tc.compile { % applied Ar times. pred name-pair o:term, o:term, o:nat. - func fold-map2 list A, B, D, (func A, B, D -> C, B, D) -> list C, B, D. + func fold-map2 list A, B, C, (func A, B, C -> A', B, C) -> list A', B, C. fold-map2 [] A B _ [] A B. fold-map2 [X|XS] A B F [Y|YS] A2 B2 :- F X A B Y A1 B1, fold-map2 XS A1 B1 F YS A2 B2. From 508ec64569f0eca3bf5c0c0b0cd6013f347375f3 Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Wed, 17 Jun 2026 17:32:18 +0200 Subject: [PATCH 36/62] externalize decomp-term from fold-map --- apps/tc/elpi/ho_compile.elpi | 57 +++++++++++++++++++++++------------- 1 file changed, 36 insertions(+), 21 deletions(-) diff --git a/apps/tc/elpi/ho_compile.elpi b/apps/tc/elpi/ho_compile.elpi index e3e0ec995..93e1545a8 100644 --- a/apps/tc/elpi/ho_compile.elpi +++ b/apps/tc/elpi/ho_compile.elpi @@ -351,49 +351,64 @@ namespace tc.compile { get-uva-pair-arity X [_|L] Z :- uvar-pair X _ Y, !, get-uva-pair-arity Y L Z. - func decompile-problematic-term term, list prop -> term, list prop. - decompile-problematic-term (tc.maybe-eta-tm T S) L V [tc.link.eta V T' | L2] :- - prune V S, !, fold-map T L T' L2. + func decomp-term term, list prop -> term, list prop. + decomp-term X A Y A :- name X, !, X = Y, !. + decomp-term (global _ as C) A C A :- !. + decomp-term (pglobal _ _ as C) A C A :- !. + decomp-term (sort _ as C) A C A :- !. - decompile-problematic-term (tc.maybe-proj A S) L X [NL|L] :- !, + decomp-term (tc.maybe-eta-tm T S) L V [tc.link.eta V T' | L2] :- + prune V S, !, decomp-term T L T' L2. + + decomp-term (tc.maybe-proj A S) L X [NL|L] :- !, prune X S, NL = tc.link.proj A X. - decompile-problematic-term (tc.prod-range T _) A T' A' :- !, - fold-map T A T' A'. + decomp-term (tc.prod-range T _) A T' A' :- !, + decomp-term T A T' A'. - decompile-problematic-term (tc.maybe-llam-tm (app [app[H|S] | NPF]) Sc) L Z [NL|L'] :- !, + decomp-term (tc.maybe-llam-tm (app [app[H|S] | NPF]) Sc) L Z [NL|L'] :- !, prune Z Sc, get-uva-pair-arity H S Y, - std.fold-map NPF L fold-map Tl L', + std.fold-map NPF L decomp-term Tl L', NL = tc.link.llam Z (app[Y | Tl]). % TODO: complete this fold - decompile-problematic-term (app[X|S]) L Z L :- + decomp-term (app[X|S]) L Z L :- var X _ Scope, std.append Scope S Scope', distinct_names Scope', !, get-uva-pair-arity X S Y, prune Z Scope', var Z Y Scope'. - decompile-problematic-term A L A L :- var A, !. + decomp-term A L A L :- var A, !. - decompile-problematic-term (fun N Ty Bo) L (fun N Ty' Bo') L3 :- - fold-map Ty L Ty' L1, - (pi x\ fold-map (Bo x) [] (Bo' x) (Lx x)), + decomp-term (fun N Ty Bo) L (fun N Ty' Bo') L3 :- + decomp-term Ty L Ty' L1, + (pi x\ decomp-term (Bo x) [] (Bo' x) (Lx x)), close-term-no-prune-ty Lx Ty' L2, std.append L1 L2 L3. - decompile-problematic-term (prod N Ty Bo) L (prod N Ty' Bo') L3 :- - (pi x\ fold-map (Bo x) [] (Bo' x) (Lx x)), + decomp-term (prod N Ty Bo) L (prod N Ty' Bo') L3 :- + (pi x\ decomp-term (Bo x) [] (Bo' x) (Lx x)), close-term-no-prune-ty Lx Ty L1, - fold-map Ty L Ty' L2, + decomp-term Ty L Ty' L2, std.append L2 L1 L3. - func compile term, list prop -> term, list prop. - compile T L T' L' :- - (pi t l t' l'\ fold-map t l t' l' :- decompile-problematic-term t l t' l', !) => - fold-map T L T' L'. + decomp-term (let N T B F) A (let N T1 B1 F1) A3 :- !, + decomp-term T A T1 A1, decomp-term B A1 B1 A2, + pi x\ decomp-term (F x) A2 (F1 x) A3. + decomp-term (app L) A (app L1) A1 :- !, + std.fold-map L A decomp-term L1 A1. + decomp-term (fix N Rno Ty F) A (fix N Rno Ty1 F1) A2 :- !, + decomp-term Ty A Ty1 A1, + pi x\ decomp-term (F x) A1 (F1 x) A2. + decomp-term (match T Rty B) A (match T1 Rty1 B1) A3 :- !, + decomp-term T A T1 A1, decomp-term Rty A1 Rty1 A2, + std.fold-map B A2 decomp-term B1 A3. + decomp-term (primitive _ as C) A C A :- !. + decomp-term (uvar M L as X) A W A1 :- var X, !, + std.fold-map L A decomp-term L1 A1, coq.mk-app-uvar M L1 W. % Uva Binders LinkEta func build-eta-links-of-vars-aux term, list term -> list prop. @@ -429,7 +444,7 @@ namespace tc.compile { goal.make-pairs Vars Pairs, Pairs => ( std.assert!(goal.build-eta-links-of-vars Vars EtaLinks) "[TC] cannot build eta-links", - std.assert!(goal.compile GoalPrecomp EtaLinks Goal' Links) "[TC] cannot compile goal" + std.assert!(goal.decomp-term GoalPrecomp EtaLinks Goal' Links) "[TC] cannot compile goal" ). } From 5115749405db93d0bda030395214ac277fe59f74 Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Wed, 17 Jun 2026 17:41:48 +0200 Subject: [PATCH 37/62] ho_compile share common code --- apps/tc/elpi/ho_compile.elpi | 114 +++++++++++++++++------------------ apps/tc/tests/test.v | 2 +- 2 files changed, 56 insertions(+), 60 deletions(-) diff --git a/apps/tc/elpi/ho_compile.elpi b/apps/tc/elpi/ho_compile.elpi index 93e1545a8..310a4b23d 100644 --- a/apps/tc/elpi/ho_compile.elpi +++ b/apps/tc/elpi/ho_compile.elpi @@ -1,4 +1,53 @@ namespace tc.compile { + % [uvar-pair V1 Ty V2] List of uvar for link-eta-dedup + % V1 has arity n and V2 has arity n+1 + % If V1 has type A -> B, then A = Ty + pred uvar-pair i:term, o:term, o:term. + + % Type Var Cnt uvar-pair-list + func make-pairs-aux term, term -> list prop. + make-pairs-aux (prod _ Ty Bo) V [pi x\ uvar-pair x Ty X' :- x == V, ! | L] :- !, + pi x\ make-pairs-aux (Bo x) X' L. + make-pairs-aux _ _ []. + + func make-pairs list term -> list prop. + make-pairs [] [] :- !. + make-pairs [X|Xs] L :- !, + coq.typecheck X Ty ok, + make-pairs-aux Ty X L', + make-pairs Xs L'', + std.append L' L'' L. + + % Uva Binders LinkEta + func build-eta-links-of-vars-aux term, list term -> list prop. + build-eta-links-of-vars-aux Old L [Hd | Xs] :- + uvar-pair Old Ty Next, !, + prune OldScope L, + prune Name L, + var OldScope Old L, + Hd = tc.link.eta OldScope (fun Name Ty (x\ NextScope x)), + pi x\ sigma L'\ + std.append L [x] L', + prune (NextScope x) L', + var (NextScope x) Next L', + build-eta-links-of-vars-aux Next L' (Ys x), !, + sigma Closed\ (close-term-no-prune-ty Ys Ty Closed), + Xs = Closed. + build-eta-links-of-vars-aux _ _ []. + + func build-eta-links-of-vars list term -> list prop. + build-eta-links-of-vars [] []. + build-eta-links-of-vars [V|Vars] L :- + var V Hd S, + build-eta-links-of-vars-aux Hd S L', + build-eta-links-of-vars Vars L'', + std.append L' L'' L. + + func get-uva-pair-arity term, list term -> term. + get-uva-pair-arity X [] X :- !. + get-uva-pair-arity X [_|L] Z :- uvar-pair X _ Y, !, + get-uva-pair-arity Y L Z. + namespace instance { func is-name term ->. func is-uvar term ->. @@ -55,11 +104,9 @@ namespace tc.compile { var H _ Scope, !, std.append Scope S S', prune Z S', - tc.compile.goal.make-pairs [T] Pairs, + make-pairs [T] Pairs, % We build on the fly the eta-links for T - (Pairs => - (tc.compile.goal.build-eta-links-of-vars [T] P, - tc.compile.goal.get-uva-pair-arity T PF Y)), + (Pairs ==> build-eta-links-of-vars [T] P, get-uva-pair-arity T PF Y), fold-map2 NPF A L decompile-term-aux Tl XS' L2, std.append P L2 L3, NL = tc.link.llam Z (app [Y|Tl]). @@ -95,11 +142,9 @@ namespace tc.compile { distinct_names L, !, % Not needed, since decompile for llam leaves only PF std.append Scope L Scope', prune Z Scope', - tc.compile.goal.make-pairs [T] Pairs, + make-pairs [T] Pairs, % We build on the fly the eta-links for `T` - (Pairs => - (tc.compile.goal.build-eta-links-of-vars [T] P, - tc.compile.goal.get-uva-pair-arity T L Y)), + (Pairs ==> build-eta-links-of-vars [T] P, get-uva-pair-arity T L Y), var Z Y Scope', std.append P B B'. @@ -327,30 +372,6 @@ namespace tc.compile { tc.compile.instance Ty (global InstGR) Clause. namespace goal { - % [uvar-pair V1 Ty V2] List of uvar for link-eta-dedup - % V1 has arity n and V2 has arity n+1 - % If V1 has type A -> B, then A = Ty - pred uvar-pair i:term, o:term, o:term. - - % Type Var Cnt uvar-pair-list - func make-pairs-aux term, term -> list prop. - make-pairs-aux (prod _ Ty Bo) V [pi x\ uvar-pair x Ty X' :- x == V, ! | L] :- !, - pi x\ make-pairs-aux (Bo x) X' L. - make-pairs-aux _ _ []. - - func make-pairs list term -> list prop. - make-pairs [] [] :- !. - make-pairs [X|Xs] L :- !, - coq.typecheck X Ty ok, - make-pairs-aux Ty X L', - make-pairs Xs L'', - std.append L' L'' L. - - func get-uva-pair-arity term, list term -> term. - get-uva-pair-arity X [] X :- !. - get-uva-pair-arity X [_|L] Z :- uvar-pair X _ Y, !, - get-uva-pair-arity Y L Z. - func decomp-term term, list prop -> term, list prop. decomp-term X A Y A :- name X, !, X = Y, !. decomp-term (global _ as C) A C A :- !. @@ -409,31 +430,6 @@ namespace tc.compile { decomp-term (primitive _ as C) A C A :- !. decomp-term (uvar M L as X) A W A1 :- var X, !, std.fold-map L A decomp-term L1 A1, coq.mk-app-uvar M L1 W. - - % Uva Binders LinkEta - func build-eta-links-of-vars-aux term, list term -> list prop. - build-eta-links-of-vars-aux Old L [Hd | Xs] :- - uvar-pair Old Ty Next, !, - prune OldScope L, - prune Name L, - var OldScope Old L, - Hd = tc.link.eta OldScope (fun Name Ty (x\ NextScope x)), - pi x\ sigma L'\ - std.append L [x] L', - prune (NextScope x) L', - var (NextScope x) Next L', - build-eta-links-of-vars-aux Next L' (Ys x), !, - sigma Closed\ (close-term-no-prune-ty Ys Ty Closed), - Xs = Closed. - build-eta-links-of-vars-aux _ _ []. - - func build-eta-links-of-vars list term -> list prop. - build-eta-links-of-vars [] []. - build-eta-links-of-vars [V|Vars] L :- - var V Hd S, - build-eta-links-of-vars-aux Hd S L', - build-eta-links-of-vars Vars L'', - std.append L' L'' L. } % Goal Goal' Links @@ -441,9 +437,9 @@ namespace tc.compile { :name "compile-goal" goal Goal Goal' Links :- tc.precomp.goal Goal GoalPrecomp Vars, !, - goal.make-pairs Vars Pairs, + make-pairs Vars Pairs, Pairs => ( - std.assert!(goal.build-eta-links-of-vars Vars EtaLinks) "[TC] cannot build eta-links", + std.assert!(build-eta-links-of-vars Vars EtaLinks) "[TC] cannot build eta-links", std.assert!(goal.decomp-term GoalPrecomp EtaLinks Goal' Links) "[TC] cannot compile goal" ). } diff --git a/apps/tc/tests/test.v b/apps/tc/tests/test.v index 1b3c35f30..aab23e495 100644 --- a/apps/tc/tests/test.v +++ b/apps/tc/tests/test.v @@ -212,7 +212,7 @@ Module HO_81. tc.compile.goal Goal _ _ :- Goal = {{HO_81.c1 lp:_}}, !, tc.precomp.goal Goal _ Vars, !, - tc.compile.goal.make-pairs Vars Pairs, + tc.compile.make-pairs Vars Pairs, std.assert! (Pairs = []) "", fail. }}. From ac6672f7032d8ee203381e3f118f4125435755e3 Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Thu, 18 Jun 2026 09:00:18 +0200 Subject: [PATCH 38/62] add doc precompile-aux of instances --- apps/tc/elpi/ho_precompile.elpi | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/apps/tc/elpi/ho_precompile.elpi b/apps/tc/elpi/ho_precompile.elpi index 5e8f22e81..9c0555ee3 100644 --- a/apps/tc/elpi/ho_precompile.elpi +++ b/apps/tc/elpi/ho_precompile.elpi @@ -118,6 +118,11 @@ namespace tc.precomp { get-max-arity _ Ty _ N :- tc.get-TC-of-inst-type Ty _, !, count-prod Ty N. get-max-arity T _ T' N :- !, get-max-arity-aux T T' N. + % [precompile-aux P T N T' N'] + % P tells if we are in positive or negative position + % takes a term T and a nat N + % returns a tagged term T and an unpdated nat N' + % the tags are for problematic subterms and N' is for how many problamatic subterms exists :index (_ 1) func precompile-aux positivity, term, nat -> term, nat. precompile-aux _ X A Y A :- name X, !, X = Y, !. % avoid loading "precompile-aux x A x A" at binders From a6bf2fe772a5a6be1d449c37023aefffee46573e Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Thu, 18 Jun 2026 09:10:57 +0200 Subject: [PATCH 39/62] move fold-map2 in base.elpi --- apps/tc/elpi/base.elpi | 5 +++++ apps/tc/elpi/ho_compile.elpi | 4 ---- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/apps/tc/elpi/base.elpi b/apps/tc/elpi/base.elpi index a62ecfab3..cfaa7e3c4 100644 --- a/apps/tc/elpi/base.elpi +++ b/apps/tc/elpi/base.elpi @@ -150,3 +150,8 @@ func close-term-no-prune-ty (term -> list prop), term -> list prop. close-term-no-prune-ty (x\ []) _ [] :- !. close-term-no-prune-ty (x\ [X x | Xs x]) Ty [@pi-decl `x` Ty x\ X x | Xs'] :- !, close-term-no-prune-ty Xs Ty Xs'. + + +func fold-map2 list A, B, C, (func A, B, C -> A', B, C) -> list A', B, C. +fold-map2 [] A B _ [] A B. +fold-map2 [X|XS] A B F [Y|YS] A2 B2 :- F X A B Y A1 B1, fold-map2 XS A1 B1 F YS A2 B2. diff --git a/apps/tc/elpi/ho_compile.elpi b/apps/tc/elpi/ho_compile.elpi index 310a4b23d..8e4a08b20 100644 --- a/apps/tc/elpi/ho_compile.elpi +++ b/apps/tc/elpi/ho_compile.elpi @@ -57,10 +57,6 @@ namespace tc.compile { % applied Ar times. pred name-pair o:term, o:term, o:nat. - func fold-map2 list A, B, C, (func A, B, C -> A', B, C) -> list A', B, C. - fold-map2 [] A B _ [] A B. - fold-map2 [X|XS] A B F [Y|YS] A2 B2 :- F X A B Y A1 B1, fold-map2 XS A1 B1 F YS A2 B2. - namespace decompile { func decompile-term-aux term, list term, list prop -> term, list term, list prop. From 870d3bad80abdafcce8c491078f8742874254028 Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Thu, 18 Jun 2026 09:23:25 +0200 Subject: [PATCH 40/62] complete pattern matching for precompile-aux in instances --- apps/tc/elpi/ho_precompile.elpi | 15 ++++----------- 1 file changed, 4 insertions(+), 11 deletions(-) diff --git a/apps/tc/elpi/ho_precompile.elpi b/apps/tc/elpi/ho_precompile.elpi index 9c0555ee3..31652617c 100644 --- a/apps/tc/elpi/ho_precompile.elpi +++ b/apps/tc/elpi/ho_precompile.elpi @@ -169,17 +169,11 @@ namespace tc.precomp { pi x\ is-name x => def x N T Ty => precompile-aux is_neg_fix (Bo x) A2 (Bo' x) A3. - % TODO: what about the following constructors? - % precompile-aux IsP (let N T B F) A (let N T1 B1 F1) A3 :- !, - % precompile-aux IsP T A T1 A1, precompile-aux IsP B A1 B1 A2, pi x\ is-name x => precompile-aux IsP (F x) A2 (F1 x) A3. - % precompile-aux IsP (fix N Rno Ty F) A (fix N Rno Ty1 F1) A2 :- !, - % precompile-aux IsP Ty A Ty1 A1, pi x\ is-name x => precompile-aux IsP (F x) A1 (F1 x) A2. - % precompile-aux IsP (match T Rty B) A (match T1 Rty1 B1) A3 :- !, - % precompile-aux IsP T A T1 A1, precompile-aux IsP Rty A1 Rty1 A2, std.fold-map B A2 (precompile-aux IsP) B1 A3. + precompile-aux B (fix N Rno Ty F) A (fix N Rno Ty1 F1) A2 :- !, + precompile-aux B Ty A Ty1 A1, pi x\ precompile-aux is_neg_fix (F x) A1 (F1 x) A2. + precompile-aux IsP (match T Rty B) A (match T1 Rty1 B1) A3 :- !, + precompile-aux IsP T A T1 A1, precompile-aux IsP Rty A1 Rty1 A2, std.fold-map B A2 (precompile-aux IsP) B1 A3. precompile-aux _ (primitive _ as C) A C A :- !. - % precompile-aux IsP (uvar M L as X) A W A1 :- var X, !, std.fold-map L A (precompile-aux IsP) L1 A1, coq.mk-app-uvar M L1 W. - % % when used in CHR rules - % precompile-aux IsP (uvar X L) A (uvar X L1) A1 :- std.fold-map L A (precompile-aux IsP) L1 A1. func get-univ-instances term -> list univ-instance. get-univ-instances T L :- @@ -239,7 +233,6 @@ namespace tc.precomp { names Scope1, std.fold-map NPF N precompile-aux NPF1 M. - % In the goal there are precompile-aux (prod Name Ty B) N (tc.prod-range (prod Name Ty' B') MaxAr) P :- !, count-prod Ty MaxAr, std.assert! (pi x\ decl x Name Ty => precompile-aux (B x) N (B' x) M) "[TC] should not fail", From e46bedd4442703bd1bb21fe436ad4bffafb5208a Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Thu, 18 Jun 2026 10:29:38 +0200 Subject: [PATCH 41/62] namespace in ho_link --- apps/tc/elpi/ho_link.elpi | 340 +++++++++++++++++++------------------- 1 file changed, 169 insertions(+), 171 deletions(-) diff --git a/apps/tc/elpi/ho_link.elpi b/apps/tc/elpi/ho_link.elpi index a1fc55208..ec9d4e0f4 100644 --- a/apps/tc/elpi/ho_link.elpi +++ b/apps/tc/elpi/ho_link.elpi @@ -1,186 +1,184 @@ -namespace tc { - namespace link { - shorten tc.{get-vars}. - - %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - % ETA LINK % - %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - namespace eta { - func eta-expand term -> term. - eta-expand T1 (fun _ _ B) :- (name T1; is-coq-term T1), !, pi x\ coq.mk-app T1 [x] (B x). - eta-expand T1 (fun _ _ R) :- pi x\ name (R x) T1 [x]. - - :index (_ _ 1) - func may-contract-to list term, term, term ->. - may-contract-to _ N N :- name N, !. - may-contract-to L N V :- var V _ S, !, - std.forall [N|L] (x\ std.exists! S (may-contract-to [] x)). - may-contract-to L N (app [N|A]) :- - std.length A {std.length L}, - std.forall2 {std.rev L} A (may-contract-to []). - may-contract-to L N (fun _ _ B) :- - pi x\ may-contract-to [x|L] N (B x). - - :index (_ 1) - func occurs-rigidly term, term ->. - occurs-rigidly N N :- name N, !. - occurs-rigidly _ V :- var V, !, fail. - occurs-rigidly N (app A) :- std.exists! A (occurs-rigidly N). - occurs-rigidly N (fun _ _ B) :- pi x\ occurs-rigidly N (B x). - - :index (1) - func maybe-eta-aux term, list term ->. - maybe-eta-aux V L :- var V _ S, !, std.forall L (std.mem! S). - maybe-eta-aux (app [_|A]) L :- - SplitLen is {std.length A} - {std.length L}, - split-at-not-fatal SplitLen A HD TL, - std.forall L (x\ not (std.exists! HD (occurs-rigidly x))), - std.forall2 {std.rev L} TL (may-contract-to []). - maybe-eta-aux (fun _ _ B) L :- - pi x\ maybe-eta-aux (B x) [x|L]. - - func maybe-eta term ->. - maybe-eta (fun _ _ B) :- pi x\ maybe-eta-aux (B x) [x]. - - func unify-left-right term, term ->. - unify-left-right (fun _ _ A) (fun _ _ A') :- !, pi x\ unify-left-right (A x) (A' x). - unify-left-right A (fun _ _ _ as T) :- !, eta-expand A Ae, pi x\ unify-left-right Ae T. - unify-left-right A A' :- A = A'. - - func progress-eta-left term -> term. - progress-eta-left A _ :- var A, !, fail. - progress-eta-left (fun _ _ A) (fun _ _ A) :- !. - progress-eta-left A A' :- (name A; is-coq-term A), !, eta-expand A A'. - - func progress-eta-right term -> term. - progress-eta-right (fun _ _ B as T) T :- pi x\ var (B x), !, fail. - progress-eta-right A A' :- coq.reduction.eta-contract A A', not (A = A'), !. - progress-eta-right A A :- not (maybe-eta A), !. - - func scope-check term, term ->. - scope-check (uvar _ L) T :- prune A L, A = T, !. - - :index (1) - func relocate list term, list term, term -> term. - relocate [] [] T T' :- copy T T', coq.say "Copy result is" T T'. - relocate [X|Xs] [Y|Ys] T T' :- - coq.say "Charging" (copy Y X), - (copy Y X :- !) => relocate Xs Ys T T'. - - pred collect-store o:list prop. - func collect-store-aux list prop -> list prop. - - collect-store L :- collect-store-aux [] L. - collect-store-aux X L :- declare_constraint (collect-store-aux X L) [_]. - - func unify-eta term, term ->. - % unify-eta A B :- coq.say "Unify-eta" "A"A"B"B, fail. - unify-eta A B :- var A, !, A = B, !. - unify-eta (fun _ _ A) (fun _ _ B) :- !, pi x\ unify-eta (A x) (B x). - unify-eta A (fun _ _ _ as B) :- !, eta-expand A A', unify-eta A' B. - unify-eta A B :- A = B. - - constraint eta uvar relocate fun collect-store-aux solve-eta { - rule solve-eta \ (eta A B) <=> (unify-eta A B). - rule \ solve-eta. - % rule (N1 : G1 ?- eta (uvar X L1) (fun _ T1 B1)) - % \ (N2 : G2 ?- eta (uvar X L2) (fun _ T2 B2)) - % | ( - % pi x\ relocate L1 L2 (B2 x) (B2' x) - % % coq.say "Deduplicating" - % % (eta (uvar X L1) (fun _ T1 B1)) - % % (eta (uvar X L2) (fun _ T2 B2)) - % % "B2' is" (B2') - % ) - % <=> (N1 : G1 ?- B1 = B2'). - - % TODO: link collect do not work since it closes links and - % therefore variables are prune - % rule \ (tc.link.eta A B) (collect-store-aux L R) | (coq.say A B {names}) <=> (collect-store-aux [tc.link.eta A B|L] R). - % rule \ (collect-store-aux L R) <=> (R = L). - } - - func eta term, term ->. - eta _ uvar :- !, coq.error "[TC] link.eta error, flexible rhs". - eta A (fun _ _ B as T) :- not (var A), not (var B), !, unify-left-right A T. - eta A B :- progress-eta-right B B', !, A = B'. - eta A B :- progress-eta-left A A', !, A' = B. - eta A B :- scope-check A B, get-vars B Vars, declare_constraint (eta A B) [_,A|Vars]. +namespace tc.link { + shorten tc.{get-vars}. + + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + % ETA LINK % + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + namespace eta { + func eta-expand term -> term. + eta-expand T1 (fun _ _ B) :- (name T1; is-coq-term T1), !, pi x\ coq.mk-app T1 [x] (B x). + eta-expand T1 (fun _ _ R) :- pi x\ name (R x) T1 [x]. + + :index (_ _ 1) + func may-contract-to list term, term, term ->. + may-contract-to _ N N :- name N, !. + may-contract-to L N V :- var V _ S, !, + std.forall [N|L] (x\ std.exists! S (may-contract-to [] x)). + may-contract-to L N (app [N|A]) :- + std.length A {std.length L}, + std.forall2 {std.rev L} A (may-contract-to []). + may-contract-to L N (fun _ _ B) :- + pi x\ may-contract-to [x|L] N (B x). + + :index (_ 1) + func occurs-rigidly term, term ->. + occurs-rigidly N N :- name N, !. + occurs-rigidly _ V :- var V, !, fail. + occurs-rigidly N (app A) :- std.exists! A (occurs-rigidly N). + occurs-rigidly N (fun _ _ B) :- pi x\ occurs-rigidly N (B x). + + :index (1) + func maybe-eta-aux term, list term ->. + maybe-eta-aux V L :- var V _ S, !, std.forall L (std.mem! S). + maybe-eta-aux (app [_|A]) L :- + SplitLen is {std.length A} - {std.length L}, + split-at-not-fatal SplitLen A HD TL, + std.forall L (x\ not (std.exists! HD (occurs-rigidly x))), + std.forall2 {std.rev L} TL (may-contract-to []). + maybe-eta-aux (fun _ _ B) L :- + pi x\ maybe-eta-aux (B x) [x|L]. + + func maybe-eta term ->. + maybe-eta (fun _ _ B) :- pi x\ maybe-eta-aux (B x) [x]. + + func unify-left-right term, term ->. + unify-left-right (fun _ _ A) (fun _ _ A') :- !, pi x\ unify-left-right (A x) (A' x). + unify-left-right A (fun _ _ _ as T) :- !, eta-expand A Ae, pi x\ unify-left-right Ae T. + unify-left-right A A' :- A = A'. + + func progress-eta-left term -> term. + progress-eta-left A _ :- var A, !, fail. + progress-eta-left (fun _ _ A) (fun _ _ A) :- !. + progress-eta-left A A' :- (name A; is-coq-term A), !, eta-expand A A'. + + func progress-eta-right term -> term. + progress-eta-right (fun _ _ B as T) T :- pi x\ var (B x), !, fail. + progress-eta-right A A' :- coq.reduction.eta-contract A A', not (A = A'), !. + progress-eta-right A A :- not (maybe-eta A), !. + + func scope-check term, term ->. + scope-check (uvar _ L) T :- prune A L, A = T, !. + + :index (1) + func relocate list term, list term, term -> term. + relocate [] [] T T' :- copy T T', coq.say "Copy result is" T T'. + relocate [X|Xs] [Y|Ys] T T' :- + coq.say "Charging" (copy Y X), + (copy Y X :- !) => relocate Xs Ys T T'. + + pred collect-store o:list prop. + func collect-store-aux list prop -> list prop. + + collect-store L :- collect-store-aux [] L. + collect-store-aux X L :- declare_constraint (collect-store-aux X L) [_]. + + func unify-eta term, term ->. + % unify-eta A B :- coq.say "Unify-eta" "A"A"B"B, fail. + unify-eta A B :- var A, !, A = B, !. + unify-eta (fun _ _ A) (fun _ _ B) :- !, pi x\ unify-eta (A x) (B x). + unify-eta A (fun _ _ _ as B) :- !, eta-expand A A', unify-eta A' B. + unify-eta A B :- A = B. + + constraint eta uvar relocate fun collect-store-aux solve-eta { + rule solve-eta \ (eta A B) <=> (unify-eta A B). + rule \ solve-eta. + % rule (N1 : G1 ?- eta (uvar X L1) (fun _ T1 B1)) + % \ (N2 : G2 ?- eta (uvar X L2) (fun _ T2 B2)) + % | ( + % pi x\ relocate L1 L2 (B2 x) (B2' x) + % % coq.say "Deduplicating" + % % (eta (uvar X L1) (fun _ T1 B1)) + % % (eta (uvar X L2) (fun _ T2 B2)) + % % "B2' is" (B2') + % ) + % <=> (N1 : G1 ?- B1 = B2'). + + % TODO: link collect do not work since it closes links and + % therefore variables are prune + % rule \ (tc.link.eta A B) (collect-store-aux L R) | (coq.say A B {names}) <=> (collect-store-aux [tc.link.eta A B|L] R). + % rule \ (collect-store-aux L R) <=> (R = L). } - %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - % LLAM LINK % - %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - namespace llam { - func llam term, term ->. - llam A (uvar _ S as T) :- distinct_names S, !, A = T. - llam A (app [H|L] as T) :- var A, var H, !, get-vars T Vars, declare_constraint (llam A (app [H|L])) [_,A|Vars]. - llam (fun _ _ _ as F) (app [H | TL]) :- - var H _ Scope, !, - std.drop-last 1 TL TL', - H = fun _ _Ty (x\ Bo'), % TODO give a valid _Ty: should be: (Ty of dropped -> Ty of F) - prune H' Scope, - coq.mk-app H' TL' Bo', - pi x\ llam F Bo'. - llam A B :- !, std.once(tc.unify-eq A B). - - constraint solve-llam llam { - rule solve-llam \ (llam A B) <=> (A = B). - rule \ solve-llam. - } - } + func eta term, term ->. + eta _ uvar :- !, coq.error "[TC] link.eta error, flexible rhs". + eta A (fun _ _ B as T) :- not (var A), not (var B), !, unify-left-right A T. + eta A B :- progress-eta-right B B', !, A = B'. + eta A B :- progress-eta-left A A', !, A' = B. + eta A B :- scope-check A B, get-vars B Vars, declare_constraint (eta A B) [_,A|Vars]. + } - %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - % Projection LINK % - %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - namespace proj { - func proj term, term ->. - proj T V :- var V, !, get-vars T Vars, declare_constraint (proj T V) [_,V|Vars]. - :name "proj-unif" - proj T R :- coq.unify-eq T R ok. - - func force-unify list prop, term, term ->. - :name "force-proj" - % If B is a variale we launch elpi unification - force-unify _ A B :- var B, !, A = B. - force-unify Ctx A B :- Ctx => coq.unify-eq A B ok. - - - constraint decl def ?- solve-proj proj { - % TODO: should add a dedup constraint - rule solve-proj \ (Ctx ?- proj A B) <=> (force-unify Ctx A B). - % rule solve-proj \ (Ctx ?- proj A B) <=> (A = B). - rule \ solve-proj. - } + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + % LLAM LINK % + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + namespace llam { + func llam term, term ->. + llam A (uvar _ S as T) :- distinct_names S, !, A = T. + llam A (app [H|L] as T) :- var A, var H, !, get-vars T Vars, declare_constraint (llam A (app [H|L])) [_,A|Vars]. + llam (fun _ _ _ as F) (app [H | TL]) :- + var H _ Scope, !, + std.drop-last 1 TL TL', + H = fun _ _Ty (x\ Bo'), % TODO give a valid _Ty: should be: (Ty of dropped -> Ty of F) + prune H' Scope, + coq.mk-app H' TL' Bo', + pi x\ llam F Bo'. + llam A B :- !, std.once(tc.unify-eq A B). + + constraint solve-llam llam { + rule solve-llam \ (llam A B) <=> (A = B). + rule \ solve-llam. } + } - namespace unif-eq { - func unif-eq term, term. - unif-eq T1 (uvar as T2) :- !, declare_constraint (unif-eq T1 T2) [_,T2]. - unif-eq T1 T2 :- !, coq.unify-eq T1 T2 ok. + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + % Projection LINK % + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + namespace proj { + func proj term, term ->. + proj T V :- var V, !, get-vars T Vars, declare_constraint (proj T V) [_,V|Vars]. + :name "proj-unif" + proj T R :- coq.unify-eq T R ok. + + func force-unify list prop, term, term ->. + :name "force-proj" + % If B is a variale we launch elpi unification + force-unify _ A B :- var B, !, A = B. + force-unify Ctx A B :- Ctx => coq.unify-eq A B ok. + + + constraint decl def ?- solve-proj proj { + % TODO: should add a dedup constraint + rule solve-proj \ (Ctx ?- proj A B) <=> (force-unify Ctx A B). + % rule solve-proj \ (Ctx ?- proj A B) <=> (A = B). + rule \ solve-proj. } + } - func unif-eq term, term ->. - unif-eq T1 T2 :- unif-eq.unif-eq T1 T2. + namespace unif-eq { + func unif-eq term, term. + unif-eq T1 (uvar as T2) :- !, declare_constraint (unif-eq T1 T2) [_,T2]. + unif-eq T1 T2 :- !, coq.unify-eq T1 T2 ok. + } + func unif-eq term, term ->. + unif-eq T1 T2 :- unif-eq.unif-eq T1 T2. - func eta term, term -> . - eta A B :- eta.eta A B. - func solve-eta. - solve-eta :- declare_constraint solve-eta [_]. + func eta term, term -> . + eta A B :- eta.eta A B. - func llam term, term ->. - llam A B :- llam.llam A B. + func solve-eta. + solve-eta :- declare_constraint solve-eta [_]. - func solve-llam. - solve-llam :- declare_constraint solve-llam [_]. + func llam term, term ->. + llam A B :- llam.llam A B. - func proj term, term ->. - proj A B :- proj.proj A B. + func solve-llam. + solve-llam :- declare_constraint solve-llam [_]. - func solve-proj. - solve-proj :- declare_constraint solve-proj [_]. + func proj term, term ->. + proj A B :- proj.proj A B. - } -} \ No newline at end of file + func solve-proj. + solve-proj :- declare_constraint solve-proj [_]. + +} From 1d6723df80e2b77c93c93c361dd9e6063da6c40b Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Fri, 19 Jun 2026 09:33:22 +0200 Subject: [PATCH 42/62] rework constr maybe-proj + first integration of tc with cs using ad-hoc predicates --- apps/tc/elpi/cs.elpi | 10 ++++----- apps/tc/elpi/ho_compile.elpi | 11 +++++----- apps/tc/elpi/ho_precompile.elpi | 6 ++---- apps/tc/elpi/tc_aux.elpi | 7 +++++-- apps/tc/tests/prim_proj.v | 2 ++ apps/tc/tests/test_proj.v | 36 ++++++++++++++++++++++++--------- apps/tc/theories/add_commands.v | 2 ++ apps/tc/theories/db.v | 3 +-- apps/tc/theories/tc.v | 5 ++++- 9 files changed, 52 insertions(+), 30 deletions(-) diff --git a/apps/tc/elpi/cs.elpi b/apps/tc/elpi/cs.elpi index 0ba319f5b..b6e46356a 100644 --- a/apps/tc/elpi/cs.elpi +++ b/apps/tc/elpi/cs.elpi @@ -67,11 +67,9 @@ namespace cs { mk-rule ff P R (R => P). func work-proj constant, int, list term, term, nat -> term, nat. - work-proj P _ Ag R N (tc.maybe-proj (app[global (const P) | Ag']) []) (s N) :- is-uvar R, !, - std.append Ag [R] Ag'. + work-proj P PN Ag R N (tc.maybe-proj P PN Ag R []) (s N) :- is-uvar R, !. work-proj P PN Ag R N T' N :- tc.proj-reducer P PN Ag R T', !. - work-proj P _ Ag R N (tc.maybe-proj (app[global (const P) | Ag']) []) (s N) :- !, - std.append Ag [R] Ag'. + work-proj P PN Ag R N (tc.maybe-proj P PN Ag R []) (s N) :- !. func precompile term, nat -> term, nat. :name "cs-precompile" @@ -102,10 +100,10 @@ namespace cs { func decompile term, pair (list term) (list prop) -> term, pair (list term) (list prop). :name "cs-decompile" - decompile (tc.maybe-proj (app[global (const C) | Ag']) S) (pr [X|XS] L1) Y (pr XS [NL|L1]) :- !, + decompile (tc.maybe-proj C _ _ R S) (pr [X|XS] L1) Y (pr XS [NL|L1]) :- !, name Y X S, record.proj-to-pname C PN, - coq.elpi.predicate PN [{std.last Ag'}, Y] NL. + coq.elpi.predicate PN [R, Y] NL. decompile X A Y A :- name X, !, X = Y, !. % avoid loading "decompile x A x A" at binders decompile (global _ as C) A C A :- !. diff --git a/apps/tc/elpi/ho_compile.elpi b/apps/tc/elpi/ho_compile.elpi index 8e4a08b20..9c0143651 100644 --- a/apps/tc/elpi/ho_compile.elpi +++ b/apps/tc/elpi/ho_compile.elpi @@ -69,8 +69,9 @@ namespace tc.compile { decompile-term-aux (primitive _ as P) A L P A L :- !. :name "decompile-inst-maybe-proj" - decompile-term-aux (tc.maybe-proj T S) [X|XS] L1 Y XS [NL|L1] :- !, - name Y X S, NL = tc.link.proj T Y. + decompile-term-aux (tc.maybe-proj P _ _ T S) [X|XS] L1 Y XS [NL|L1] :- !, + name Y X S, + cs.compiler.cs.compiler ff (pr 0 P) T (app[_, Y]) [] [] NL. decompile-term-aux (tc.maybe-eta-tm T S) [X|XS] L1 Y XS' [NL | L2] :- !, name Y X S, @@ -164,7 +165,7 @@ namespace tc.compile { % TODO: also replace (sort (typ X)) and (pglobal _ X) with holes in the place of X func clean-term term -> term. clean-term A B :- - (pi t s r \ copy (tc.maybe-proj t s) t :- !) => + (pi c n a s sc r \ copy (tc.maybe-proj c n a s sc) r :- !, sigma X\ std.append a [s] X, copy (app[global(const c) | X]) r) => (pi t s r \ copy (tc.maybe-eta-tm t s) r :- !, copy t r, !) => (pi t s r \ copy (tc.prod-range t s) r :- !, copy t r, !) => (pi t s r \ copy (tc.maybe-llam-tm t s) r :- !, copy t r, !) => @@ -377,9 +378,9 @@ namespace tc.compile { decomp-term (tc.maybe-eta-tm T S) L V [tc.link.eta V T' | L2] :- prune V S, !, decomp-term T L T' L2. - decomp-term (tc.maybe-proj A S) L X [NL|L] :- !, + decomp-term (tc.maybe-proj P _ Ag T S) L X [NL|L] :- !, prune X S, - NL = tc.link.proj A X. + cs.compiler.cs.compiler ff (pr 0 P) T (app[_, X]) [] [] NL. decomp-term (tc.prod-range T _) A T' A' :- !, decomp-term T A T' A'. diff --git a/apps/tc/elpi/ho_precompile.elpi b/apps/tc/elpi/ho_precompile.elpi index 31652617c..a110eba6f 100644 --- a/apps/tc/elpi/ho_precompile.elpi +++ b/apps/tc/elpi/ho_precompile.elpi @@ -56,11 +56,9 @@ namespace tc.precomp { % T is the new term % N' is the updated counter func work-proj (func -> list term), constant, int, list term, term, nat -> term, nat. - work-proj F P _ Ag R N (tc.maybe-proj (app[global (const P) | Ag']) X) (s N) :- (var R; is-uvar R), !, - std.append Ag [R] Ag', F X. + work-proj F P PN Ag R N (tc.maybe-proj P PN Ag R X) (s N) :- (var R; is-uvar R), !, F X. work-proj _ P PN Ag R N T' N :- tc.proj-reducer P PN Ag R T', !. - work-proj F P _ Ag R N (tc.maybe-proj (app[global (const P) | Ag']) X) (s N) :- !, - std.append Ag [R] Ag', F X. + work-proj F P _ Ag R N (tc.maybe-proj P PN Ag R X) (s N) :- !, F X. namespace instance { diff --git a/apps/tc/elpi/tc_aux.elpi b/apps/tc/elpi/tc_aux.elpi index 86b4cbce9..d5bd229e1 100644 --- a/apps/tc/elpi/tc_aux.elpi +++ b/apps/tc/elpi/tc_aux.elpi @@ -307,8 +307,11 @@ namespace tc { term. type maybe-proj - term -> % The current precompiled subterm - list term -> % The list of FV in the precomp subterm + constant -> % The canonical constant of a projection (INVARIANT: it is the canonical projection of a CS) + int -> % The position of the CS in the record + list term -> % The arguments of the projection + term -> % The record which is projected + list term -> % The list of FV in the scope of the problematic term term. } diff --git a/apps/tc/tests/prim_proj.v b/apps/tc/tests/prim_proj.v index 16d102eb6..414dc44db 100644 --- a/apps/tc/tests/prim_proj.v +++ b/apps/tc/tests/prim_proj.v @@ -4,6 +4,8 @@ Set Primitive Projections. Record S := { sort :> Type }. Unset Primitive Projections. +Elpi cs class (S). + Class C (s : Type) := {}. Instance SC (s : S) : C s := Build_C s. diff --git a/apps/tc/tests/test_proj.v b/apps/tc/tests/test_proj.v index e8069ffbf..09252a1fc 100644 --- a/apps/tc/tests/test_proj.v +++ b/apps/tc/tests/test_proj.v @@ -5,9 +5,14 @@ Global Set TC NameShortPath. Class C (T : Type) := mkC {f : T -> T}. Class D (T : nat -> nat) := {g : unit}. Class E (T : nat) := {ge : unit}. -Record r := mkr {car : Type; rf : car -> car}. +Record r := mkr {car : Type; #[canonical=no] rf : car -> car}. Canonical Structure c := mkr nat (fun x => x). +Elpi Query TC.Solver lp:{{ true. }}. + +Elpi cs class (r). +Elpi cs cs (c). + Elpi Accumulate TC.Compiler lp:{{ % the goal is to check instances for C are correctly compiled func is-class-C prop ->. @@ -56,13 +61,11 @@ Module m1''. :after "is-class-C" is-class-C (tc-E X _ :- [K_]) :- !, name X. }}. - (* TODO: the current compiler is too permessive: it replaces rf c 3 *) - (* which contains 1. record reduction 2. beta reduction *) - (* two solutions 1. avid to define a class like that one 2. correctly reduce *) Local Instance inst_red: E (rf c 3). now constructor. Qed. Elpi Accumulate TC.Compiler lp:{{ :after "is-class-C" is-class-C C :- coq.error "FAIL" C, !. }}. - Goal E 3. apply _. Qed. + (* TODO: check this *) + Goal E 3. Fail apply _. Abort. End m1''. Module m2. @@ -152,10 +155,6 @@ Set Printing All. Module M. - Elpi cs class (r). - Elpi cs class (C). - Elpi cs cs (c). - (* Elpi Print TC.Compiler "elpi.apps.derive.tests/xxx". *) Definition fcs1 (H1 H2 : r) := (fun '(x,y) => (rf H1 x, rf H2 y)). @@ -168,7 +167,7 @@ Module M. Local Canonical Structure cs2 (T : Type) (c : C T) := mkr T (@f _ c). Local Instance i : C bool. apply (mkC _ (fun x => x)). Qed. - Elpi cs cs (cs2). + (* Elpi cs cs (cs2). *) (* Elpi Print TC.Compiler "elpi.apps.derive.tests/xxx". *) (* Print HintDb typeclass_instances. *) @@ -190,9 +189,26 @@ Module M. eexists. Elpi Accumulate TC.Solver lp:{{tc.print-goal.}}. elpi solve_cs. + Show Proof. Abort. (*TODO:*) End M. +Module M1. + + Inductive to_prop (x : Type) : Prop := c : to_prop x. + + Class C (T : Type) := {f : T -> Prop}. + Instance i x : C (car x). Admitted. + + Elpi TC Solver Activate TC.Solver. + Set Typeclasses Debug. + Print HintDb typeclass_instances. + Set Debug "tactic-unification". + Elpi Trace Browser. + Check (_ : C (car _)). +End M1. + + (* Module tc. Class Cx (t: Type) := mkC {op : t -> t -> bool}. diff --git a/apps/tc/theories/add_commands.v b/apps/tc/theories/add_commands.v index 6781bc8ba..5a5b88f8b 100644 --- a/apps/tc/theories/add_commands.v +++ b/apps/tc/theories/add_commands.v @@ -13,6 +13,7 @@ From elpi.apps.tc.elpi Extra Dependency "ho_link.elpi" as ho_link. From elpi.apps.tc.elpi Extra Dependency "parser_addInstances.elpi" as parser_addInstances. From elpi.apps.tc.elpi Extra Dependency "solver.elpi" as solver. From elpi.apps.tc.elpi Extra Dependency "create_tc_predicate.elpi" as create_tc_predicate. +From elpi.apps.tc.elpi Extra Dependency "cs.elpi" as cs. (* Set Warnings "+elpi". *) @@ -23,6 +24,7 @@ Elpi Accumulate File tc_aux. Elpi Accumulate File ho_precompile. Elpi Accumulate File unif. Elpi Accumulate File ho_link. +Elpi Accumulate File cs. Elpi Accumulate File ho_compile. Elpi Accumulate File compiler1. Elpi Accumulate File modes. diff --git a/apps/tc/theories/db.v b/apps/tc/theories/db.v index e0ce8ebd0..4f370b64d 100644 --- a/apps/tc/theories/db.v +++ b/apps/tc/theories/db.v @@ -56,8 +56,7 @@ Elpi Db tc_options.db lp:{{ func is-option-active (func (list string) ->) ->. is-option-active uvar :- !, fail. - is-option-active Opt :- - Opt X, coq.option.get X (coq.option.bool tt). + is-option-active Opt :- Opt X, coq.option.get X (coq.option.bool tt). func warning-name -> string. warning-name "[TC] Warning". diff --git a/apps/tc/theories/tc.v b/apps/tc/theories/tc.v index bbdffc69a..d28b5473e 100644 --- a/apps/tc/theories/tc.v +++ b/apps/tc/theories/tc.v @@ -51,7 +51,7 @@ Elpi Accumulate Db tc_options.db. Elpi Accumulate File tc_aux. Elpi Accumulate File unif. Elpi Accumulate File ho_link. -(* Elpi Accumulate File compiler. *) +Elpi Accumulate File cs. Elpi Accumulate File ho_precompile. Elpi Accumulate File ho_compile. Elpi Accumulate File compiler1. @@ -80,6 +80,7 @@ Elpi Command TC.Compiler. Elpi Accumulate Db tc.db. Elpi Accumulate Db tc_options.db. Elpi Accumulate File tc_aux. +Elpi Accumulate File cs. Elpi Accumulate File modes. Elpi Accumulate File create_tc_predicate. Elpi Accumulate File ho_precompile. @@ -203,6 +204,7 @@ Elpi TC.AddAllClasses. Elpi TC.AddAllInstances. Elpi Tactic cs. +Elpi Accumulate Db tc_options.db. Elpi Accumulate Db tc.db. Elpi Accumulate File tc_aux. Elpi Accumulate File cs. @@ -211,6 +213,7 @@ Elpi Accumulate lp:{{ }}. Elpi Tactic solve_cs. +Elpi Accumulate Db tc_options.db. Elpi Accumulate Db tc.db. Elpi Accumulate File tc_aux. Elpi Accumulate File cs. From b282d71f8ecd2872b76a1487eaf1a28a206325ba Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Fri, 19 Jun 2026 09:44:49 +0200 Subject: [PATCH 43/62] remove main in solver.elpi --- apps/tc/elpi/solver.elpi | 1 - 1 file changed, 1 deletion(-) diff --git a/apps/tc/elpi/solver.elpi b/apps/tc/elpi/solver.elpi index b3b2b5cf7..af22a19ba 100644 --- a/apps/tc/elpi/solver.elpi +++ b/apps/tc/elpi/solver.elpi @@ -1,6 +1,5 @@ /* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ -main _. msolve L N :- tc.time-it tc.oTC-time-msolve (coq.ltac.all (coq.ltac.open tc.solve-aux) L N) "msolve". msolve L _ :- coq.ltac.fail _ "[TC] fail to solve" L. From 88186a120202bb8a4b31970355b37b2761af9019 Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Fri, 19 Jun 2026 10:00:51 +0200 Subject: [PATCH 44/62] use coq.CS.canonical-projection? to check if the constant refers to a canonical projection --- apps/tc/elpi/tc_aux.elpi | 4 ++-- apps/tc/tests/test_proj.v | 49 ++++++++++----------------------------- 2 files changed, 14 insertions(+), 39 deletions(-) diff --git a/apps/tc/elpi/tc_aux.elpi b/apps/tc/elpi/tc_aux.elpi index d5bd229e1..5a4fefb3b 100644 --- a/apps/tc/elpi/tc_aux.elpi +++ b/apps/tc/elpi/tc_aux.elpi @@ -251,12 +251,12 @@ namespace tc { func maybe-projection term -> constant, int, list term, term. :name "maybe-projection" maybe-projection (app [primitive (proj P N), R]) C N A R :- - coq.env.primitive-projection? P C _, + coq.env.primitive-projection? P C _, coq.CS.canonical-projection? C, std.assert-ok!(coq.typecheck R Ty) "err", coq.safe-dest-app Ty _ A. % TODO: should check that C is fully applied maybe-projection (app [global (const C) | Args]) C N A R :- - coq.env.projection? C _, !, + coq.CS.canonical-projection? C, !, get-proj-nb C N, std.assert!(split-last Args A R) "err: empty list". func build-proj-term constant, list term, term -> term. diff --git a/apps/tc/tests/test_proj.v b/apps/tc/tests/test_proj.v index 09252a1fc..58733e0f5 100644 --- a/apps/tc/tests/test_proj.v +++ b/apps/tc/tests/test_proj.v @@ -47,35 +47,32 @@ End m1. Module m1'. Elpi Accumulate TC.Compiler lp:{{ - :after "is-class-C" is-class-C (tc-D {{fun x => x}} _) :- !. + % NOTE: rf is not canonical, therefore no reduced nor linked + :after "is-class-C" is-class-C (tc-D {{rf c}} _) :- !. }}. Local Instance inst_red: D (rf c). now constructor. Qed. Elpi Accumulate TC.Compiler lp:{{ :after "is-class-C" is-class-C C :- coq.error "FAIL" C, !. }}. - Goal D (fun x => x). apply _. Qed. + (* NOTE: The failure here is due to delta and beta conversion rules *) + Goal D (fun x => x). Fail apply _. Abort. End m1'. Module m1''. Elpi Accumulate TC.Compiler lp:{{ - :after "is-class-C" is-class-C (tc-E X _ :- [K_]) :- !, name X. + :after "is-class-C" is-class-C (tc-E {{rf c 3}} _) :- !. }}. Local Instance inst_red: E (rf c 3). now constructor. Qed. Elpi Accumulate TC.Compiler lp:{{ :after "is-class-C" is-class-C C :- coq.error "FAIL" C, !. }}. - (* TODO: check this *) + (* NOTE: similarly to previous test, this fails due to delta-beta conv rules *) Goal E 3. Fail apply _. Abort. End m1''. Module m2. - (* Mh, why this fails? *) - (* Elpi Accumulate TC.Compiler lp:{{ - :after "x" expected-rule X :- !, coq.say "CIAO"X, std.spy(X = (tc-C Y _ :- [tc.link.proj _ _])), !. - }}. *) Elpi Accumulate TC.Compiler lp:{{ - % TODO: here I am doing to weak check, should make the previous Accumulate succeeds - :after "is-class-C" is-class-C (tc-C X _ :- [K_]) :- !, name X, coq.say K_. + :after "is-class-C" is-class-C (tc-C X (app[_,W]) :- [canstr-car X W]) :- !, name X. }}. (* cannot reduce the projection: c is quantified *) @@ -101,7 +98,6 @@ Module m3. Goal C nat. apply _. Qed. Goal C (car c). apply _. Qed. (* with local instance for c *) - Elpi Trace Browser. Goal forall x, C (car x). intros. apply _. Qed. End m3. @@ -142,24 +138,18 @@ Module m4. Local Instance inst2 c: C c. now constructor. Qed. - Goal forall x y, C (@ofe_car1 x y). - intros x y. apply _. Qed. + Goal forall x y, C (@ofe_car1 x y). apply _. Qed. - Goal forall x y, C (@ofe_car2 x y x). - intros x y. apply _. Qed. + Goal forall x y, C (@ofe_car2 x y x). apply _. Qed. End m4. - Elpi Accumulate TC.Compiler lp:{{ :after "is-class-C" is-class-C _ :- !. }}. Set Printing All. Module M. - (* Elpi Print TC.Compiler "elpi.apps.derive.tests/xxx". *) - Definition fcs1 (H1 H2 : r) := (fun '(x,y) => (rf H1 x, rf H2 y)). Local Canonical Structure cs1 (H1 H2 H3 : r) := mkr (car H1 * car H2) (fcs1 H1 H2). - Elpi cs cs (cs1). Goal exists x, car x = (nat * nat)%type. Proof. eexists. auto. Unshelve. apply c. Qed. @@ -167,13 +157,6 @@ Module M. Local Canonical Structure cs2 (T : Type) (c : C T) := mkr T (@f _ c). Local Instance i : C bool. apply (mkC _ (fun x => x)). Qed. - (* Elpi cs cs (cs2). *) - (* Elpi Print TC.Compiler "elpi.apps.derive.tests/xxx". *) - - (* Print HintDb typeclass_instances. *) - Elpi TC Solver Activate TC.Solver. - (* Set Typeclasses Debug. *) - (* Set Debug "tactic-unification". *) Elpi Accumulate solve_cs lp:{{ solve (goal _ _ {{@eq lp:T_ lp:P lp:T}} _ _ as G) GL :- @@ -187,24 +170,16 @@ Module M. Goal exists x, car x = bool. Proof. eexists. - Elpi Accumulate TC.Solver lp:{{tc.print-goal.}}. elpi solve_cs. - Show Proof. Abort. (*TODO:*) End M. Module M1. - - Inductive to_prop (x : Type) : Prop := c : to_prop x. - Class C (T : Type) := {f : T -> Prop}. Instance i x : C (car x). Admitted. - - Elpi TC Solver Activate TC.Solver. - Set Typeclasses Debug. - Print HintDb typeclass_instances. - Set Debug "tactic-unification". - Elpi Trace Browser. + Elpi Accumulate TC.Solver lp:{{ + tc.print-compiled-goal. + }}. Check (_ : C (car _)). End M1. From 6a241658cb13f8651774feb7911142cc4b40dfcb Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Fri, 19 Jun 2026 10:04:00 +0200 Subject: [PATCH 45/62] remove call to solver main in bench_inj.v --- apps/tc/tests-stdlib/bench/bench_inj.py | 1 - apps/tc/tests-stdlib/bench/bench_inj.v | 2 +- 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/apps/tc/tests-stdlib/bench/bench_inj.py b/apps/tc/tests-stdlib/bench/bench_inj.py index 6ebf4cc32..ebe740cec 100644 --- a/apps/tc/tests-stdlib/bench/bench_inj.py +++ b/apps/tc/tests-stdlib/bench/bench_inj.py @@ -120,7 +120,6 @@ def writeFile(fileName: str, composeLen: int, isCoq: bool): else: TXT += "From elpi_apps_tc_tests_stdlib Require Import stdppInj.\n" TXT += refine_no_check # (Un)Comment this for using refine or refine.no_check - TXT += "Elpi TC.Solver.\n" TXT += f"Goal Inj eq eq({GOAL}).\n" # TXT += "Elpi Command time_it. Elpi Accumulate lp:{{ main _ :- coq.say {gettimeofday}. }}. Elpi time_it.\n" TXT += 'Set Time TC Bench. Set Debug "elpitime".\n' diff --git a/apps/tc/tests-stdlib/bench/bench_inj.v b/apps/tc/tests-stdlib/bench/bench_inj.v index 43dde51ab..1202e9df0 100644 --- a/apps/tc/tests-stdlib/bench/bench_inj.v +++ b/apps/tc/tests-stdlib/bench/bench_inj.v @@ -1,3 +1,3 @@ From elpi_apps_tc_tests_stdlib Require Import stdppInj. -Elpi TC.Solver. Set TC Time Refine. Set TC Time Instance Search. Set Debug "elpitime". +Set TC Time Refine. Set TC Time Instance Search. Set Debug "elpitime". Goal Inj eq eq((compose f f )). Time apply _. Qed. From 8c22eff0281eaf47f3994923bffa6fd24a218e5f Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Fri, 19 Jun 2026 10:36:19 +0200 Subject: [PATCH 46/62] cs compile only canonical projection predicates --- apps/tc/elpi/cs.elpi | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/apps/tc/elpi/cs.elpi b/apps/tc/elpi/cs.elpi index b6e46356a..f25ef36a2 100644 --- a/apps/tc/elpi/cs.elpi +++ b/apps/tc/elpi/cs.elpi @@ -39,8 +39,8 @@ namespace cs { :index (_ 1) func get-projn int, list (option constant) -> list (pair int constant). get-projn _ [] []. - get-projn M [some X|Xs] [pr M X|Ys] :- N is M + 1, get-projn N Xs Ys. - get-projn M [none|Xs] Ys :- N is M + 1, get-projn N Xs Ys. + get-projn M [some C|Xs] [pr M C|Ys] :- coq.CS.canonical-projection? C, !, N is M + 1, get-projn N Xs Ys. + get-projn M [_|Xs] Ys :- N is M + 1, get-projn N Xs Ys. func get-proj term -> list (pair int constant). get-proj (prod _ _ B) Pg :- !, pi x\ get-proj (B x) Pg. From 57ad4f897b8623a79014e9d9215cae7bbf9a3caa Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Fri, 19 Jun 2026 10:36:36 +0200 Subject: [PATCH 47/62] cs input mode in predicate declaration --- apps/tc/elpi/cs.elpi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/apps/tc/elpi/cs.elpi b/apps/tc/elpi/cs.elpi index f25ef36a2..2046504ea 100644 --- a/apps/tc/elpi/cs.elpi +++ b/apps/tc/elpi/cs.elpi @@ -9,7 +9,7 @@ namespace cs { proj-to-pname P S :- tc.gref->pred-name "canstr" (const P) S. func proj-to-args constant -> list (pair argument_mode string). - proj-to-args _ [MT, MT] :- MT = pr out "term". + proj-to-args _ [pr in "term", pr out "term"]. % coq.env.projection? C N, % std.list.init N (x\y\ y = MT) L, % std.append L [MT, MT] R. From 651d73b6bb36854df00d040f1dfa3c6f1283010d Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Fri, 19 Jun 2026 10:37:09 +0200 Subject: [PATCH 48/62] cs main error message on wrong input --- apps/tc/elpi/cs.elpi | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/apps/tc/elpi/cs.elpi b/apps/tc/elpi/cs.elpi index 2046504ea..14d379b44 100644 --- a/apps/tc/elpi/cs.elpi +++ b/apps/tc/elpi/cs.elpi @@ -173,6 +173,11 @@ namespace cs { pred main list argument. :name "cs-main" - main [str "class", trm T] :- cs.compiler.record.create-cs-pred T. - main [str "cs", trm T] :- cs.compiler.cs.main T. + main [str "class", trm T] :- !, std.assert! (cs.compiler.record.create-cs-pred T) "Cannot compile record projection". + main [str "cs", trm T] :- !, std.assert! (cs.compiler.cs.main T) "Cannot compile canonical structure". + main L :- coq.error " + Invalid input for command cs\n + Expected:\n + \tElpi cs cs (CANSTR)\n + \tElpi class (STRU)\n" L. } \ No newline at end of file From b5de4365f81250172bf2f746f2c5630efce46fdb Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Fri, 19 Jun 2026 10:41:40 +0200 Subject: [PATCH 49/62] rm map-filter2 (already in stdlib) --- apps/tc/elpi/cs.elpi | 7 ------- 1 file changed, 7 deletions(-) diff --git a/apps/tc/elpi/cs.elpi b/apps/tc/elpi/cs.elpi index 14d379b44..c62538013 100644 --- a/apps/tc/elpi/cs.elpi +++ b/apps/tc/elpi/cs.elpi @@ -29,13 +29,6 @@ namespace cs { std.forall P (x\ omap' x (make-pred-sig "tc.db")). } namespace cs { - func map-filter2 list A, list B, (func A, B -> C) -> list C. - map-filter2 [] [_|_] _ _ :- std.fatal-error "map2 on lists of different length". - map-filter2 [_|_] [] _ _ :- std.fatal-error "map2 on lists of different length". - map-filter2 [] [] _ []. - map-filter2 [X|XS] [Y|YS] F [Z|ZS] :- F X Y Z, !, map-filter2 XS YS F ZS. - map-filter2 [_|XS] [_|YS] F ZS :- !, map-filter2 XS YS F ZS. - :index (_ 1) func get-projn int, list (option constant) -> list (pair int constant). get-projn _ [] []. From 39814477fb3d53bd4dfe2d28f8c00aeba8b2b1e1 Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Fri, 19 Jun 2026 11:44:21 +0200 Subject: [PATCH 50/62] forall-ocan to iter over a list of option constant --- apps/tc/elpi/cs.elpi | 35 ++++++++++++++++++++++------------- 1 file changed, 22 insertions(+), 13 deletions(-) diff --git a/apps/tc/elpi/cs.elpi b/apps/tc/elpi/cs.elpi index c62538013..1c3ca3292 100644 --- a/apps/tc/elpi/cs.elpi +++ b/apps/tc/elpi/cs.elpi @@ -1,13 +1,17 @@ namespace cs { namespace compiler { - func omap' option A, (func A ->). - omap' (some A) F :- F A. - omap' none _. + func ocan (func constant ->), option constant. + ocan F (some C) :- coq.CS.canonical-projection? C, !, F C. + ocan _ _. - namespace record { - func proj-to-pname constant -> string. - proj-to-pname P S :- tc.gref->pred-name "canstr" (const P) S. + func forall-ocan (func constant ->), list (option constant) ->. + forall-ocan F L :- std.forall L (ocan F). + + + func proj-to-pname constant -> string. + proj-to-pname P S :- tc.gref->pred-name "canstr" (const P) S. + namespace record { func proj-to-args constant -> list (pair argument_mode string). proj-to-args _ [pr in "term", pr out "term"]. % coq.env.projection? C N, @@ -18,15 +22,15 @@ namespace cs { % C the projection's constant % Db the name of the database in which adding the predicate func make-pred-sig string, constant ->. - make-pred-sig Db C :- + make-pred-sig Db C :- !, proj-to-pname C S, proj-to-args C A, coq.elpi.add-predicate Db _ S A. func create-cs-pred i:term. create-cs-pred (global (indt R)) :- - coq.env.projections R P, - std.forall P (x\ omap' x (make-pred-sig "tc.db")). + coq.env.projections R LP, + forall-ocan (make-pred-sig "tc.db") LP. } namespace cs { :index (_ 1) @@ -51,7 +55,7 @@ namespace cs { % R = the compiled rule for the cs func compile constant, term, term -> prop. compile P I CS R :- - record.proj-to-pname P PN, + proj-to-pname P PN, coq.elpi.predicate PN [I, CS] R. func mk-rule bool, prop, list prop -> prop. @@ -95,7 +99,7 @@ namespace cs { :name "cs-decompile" decompile (tc.maybe-proj C _ _ R S) (pr [X|XS] L1) Y (pr XS [NL|L1]) :- !, name Y X S, - record.proj-to-pname C PN, + proj-to-pname C PN, coq.elpi.predicate PN [R, Y] NL. decompile X A Y A :- name X, !, X = Y, !. % avoid loading "decompile x A x A" at binders @@ -144,7 +148,7 @@ namespace cs { func compiler bool, (pair int constant), term, term, list prop, list term -> prop. compiler B (pr N P) CS (app[_|Ag]) L A Rs :- !, coq.mk-app CS {std.rev A} CS', - record.proj-to-pname P PN, + proj-to-pname P PN, std.nth N Ag I, precompile I z I' NPb, load-nestedp NPb B PN I' CS' [] Rs. @@ -158,6 +162,9 @@ namespace cs { get-proj Ty P, std.forall P (x\ sigma R\ compiler tt x T Bo [] [] R, tc.add-tc-db _ _ R). } + + namespace default { + } } namespace solver { @@ -168,9 +175,11 @@ namespace cs { :name "cs-main" main [str "class", trm T] :- !, std.assert! (cs.compiler.record.create-cs-pred T) "Cannot compile record projection". main [str "cs", trm T] :- !, std.assert! (cs.compiler.cs.main T) "Cannot compile canonical structure". + main [str "default", trm T] :- !, coq.error "TODO". main L :- coq.error " Invalid input for command cs\n Expected:\n \tElpi cs cs (CANSTR)\n - \tElpi class (STRU)\n" L. + \tElpi class (STRU)\n + \tElpi default (CANSTR)\n" L. } \ No newline at end of file From a0e53432586d96bc4c34a10596d757baa830c049 Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Fri, 19 Jun 2026 13:18:21 +0200 Subject: [PATCH 51/62] tc.link.proj for all projection using specific predicate per projection seems difficult for awaking proj links after resolution. see commend in cs.elpi --- apps/tc/elpi/cs.elpi | 107 +++++++++++++++++++++++--------------- apps/tc/elpi/ho_link.elpi | 16 +++--- apps/tc/tests/test_proj.v | 50 ++++++------------ apps/tc/theories/db.v | 3 +- 4 files changed, 90 insertions(+), 86 deletions(-) diff --git a/apps/tc/elpi/cs.elpi b/apps/tc/elpi/cs.elpi index 1c3ca3292..a7e97b761 100644 --- a/apps/tc/elpi/cs.elpi +++ b/apps/tc/elpi/cs.elpi @@ -8,30 +8,42 @@ namespace cs { forall-ocan F L :- std.forall L (ocan F). - func proj-to-pname constant -> string. - proj-to-pname P S :- tc.gref->pred-name "canstr" (const P) S. - - namespace record { - func proj-to-args constant -> list (pair argument_mode string). - proj-to-args _ [pr in "term", pr out "term"]. - % coq.env.projection? C N, - % std.list.init N (x\y\ y = MT) L, - % std.append L [MT, MT] R. - - % [make-pred-sig C Db] - % C the projection's constant - % Db the name of the database in which adding the predicate - func make-pred-sig string, constant ->. - make-pred-sig Db C :- !, - proj-to-pname C S, - proj-to-args C A, - coq.elpi.add-predicate Db _ S A. - - func create-cs-pred i:term. - create-cs-pred (global (indt R)) :- - coq.env.projections R LP, - forall-ocan (make-pred-sig "tc.db") LP. - } + % NOTE: the following code is to build a predicate name canstr-projx + % the problem is that we need to awake all links for CS projection + % after the execution of a tc resolution. Rules for constraints seems + % not to be dynamically extensible, therefore tc.link.solver-proj will + % not be capable of awaking new dynamically declared predicates. + % We use a single predicate tc.link.proj with three arguments for each + % projection: tc.link.proj PNAME CAR CS + % func proj-to-pname constant -> string. + % proj-to-pname P S :- tc.gref->pred-name "canstr" (const P) S. + + % namespace record { + % % each cs goal has three argument: + % % - N the name of the projection + % % - A the argument of the projection + % % - the canonical structure of N applied to A + % func proj-to-args constant -> list (pair argument_mode string). + % proj-to-args _ [pr in "term", pr in "term", pr out "term"]. + % % coq.env.projection? C N, + % % std.list.init N (x\y\ y = MT) L, + % % std.append L [MT, MT] R. + + % % [make-pred-sig C Db] + % % C the projection's constant + % % Db the name of the database in which adding the predicate + % func make-pred-sig string, constant ->. + % make-pred-sig Db C :- !, + % proj-to-pname C S, + % proj-to-args C A, + % coq.elpi.add-predicate Db _ S A. + + % func create-cs-pred i:term. + % create-cs-pred (global (indt R)) :- + % coq.env.projections R LP, + % forall-ocan (make-pred-sig "tc.db") LP. + % } + namespace cs { :index (_ 1) func get-projn int, list (option constant) -> list (pair int constant). @@ -54,9 +66,10 @@ namespace cs { % CS = canonical structure % R = the compiled rule for the cs func compile constant, term, term -> prop. - compile P I CS R :- - proj-to-pname P PN, - coq.elpi.predicate PN [I, CS] R. + % compile P I CS R :- + % proj-to-pname P PN, + % coq.elpi.predicate PN [I, CS] R. + compile P I CS (tc.link.proj P I CS :- !). func mk-rule bool, prop, list prop -> prop. mk-rule _ P [] P :- !. @@ -97,10 +110,10 @@ namespace cs { func decompile term, pair (list term) (list prop) -> term, pair (list term) (list prop). :name "cs-decompile" - decompile (tc.maybe-proj C _ _ R S) (pr [X|XS] L1) Y (pr XS [NL|L1]) :- !, - name Y X S, - proj-to-pname C PN, - coq.elpi.predicate PN [R, Y] NL. + decompile (tc.maybe-proj C _ _ R S) (pr [X|XS] L1) Y (pr XS [tc.link.proj C R Y|L1]) :- !, + name Y X S. + % proj-to-pname C PN, + % coq.elpi.predicate PN [R, Y] NL. decompile X A Y A :- name X, !, X = Y, !. % avoid loading "decompile x A x A" at binders decompile (global _ as C) A C A :- !. @@ -125,17 +138,17 @@ namespace cs { % [load-nestedp N B S T P L C] % N is the number of pi to load % B is the pos/neg position of the term being compiled - % S is the name of the predicate + % C is the name of the predicate % T is the argument (with N problematic subterms) % P is the instance of the record to be used % L is the list of pi accumulated terms - % C is the created clause - func load-nestedp nat, bool, string, term, term, list term -> prop. - load-nestedp z B S T P L C :- + % R is the created clause + func load-nestedp nat, bool, constant, term, term, list term -> prop. + load-nestedp z B C T P L R :- decompile T (pr L []) T' (pr _ Pm), - coq.elpi.predicate S [T', P] Hd, - mk-rule B Hd {std.rev Pm} C. - load-nestedp (s N) B S T P L (pi x\ C x) :- pi x\ load-nestedp N B S T P [x|L] (C x). + % coq.elpi.predicate C [T', P] Hd, + mk-rule B (tc.link.proj C T' P) {std.rev Pm} R. + load-nestedp (s N) B C T P L (pi x\ R x) :- pi x\ load-nestedp N B C T P [x|L] (R x). % [compiler B IC CS Ag P L C] % B is the pos/neg position of the term @@ -148,10 +161,9 @@ namespace cs { func compiler bool, (pair int constant), term, term, list prop, list term -> prop. compiler B (pr N P) CS (app[_|Ag]) L A Rs :- !, coq.mk-app CS {std.rev A} CS', - proj-to-pname P PN, std.nth N Ag I, precompile I z I' NPb, - load-nestedp NPb B PN I' CS' [] Rs. + load-nestedp NPb B P I' CS' [] Rs. compiler B P CS (fun N Ty Bo') L A (pi x\ R x) :- @pi-decl N Ty x\ (is-uvar x :- !) ==> compiler B P CS (Bo' x) L [x|A] (R x). @@ -164,6 +176,15 @@ namespace cs { } namespace default { + func build-default constant ->. + build-default D :- + R = (pi x y z \ tc.link.proj D (uvar as x) y :- declare_constraint (tc.link.proj D x y) [x,z]), + tc.add-tc-db _ _ R. + + func main term ->. + main (global (indt C)) :- + coq.env.projections C P, + cs.compiler.forall-ocan build-default P. } } @@ -173,13 +194,13 @@ namespace cs { pred main list argument. :name "cs-main" - main [str "class", trm T] :- !, std.assert! (cs.compiler.record.create-cs-pred T) "Cannot compile record projection". + % main [str "class", trm T] :- !, std.assert! (cs.compiler.record.create-cs-pred T) "Cannot compile record projection". main [str "cs", trm T] :- !, std.assert! (cs.compiler.cs.main T) "Cannot compile canonical structure". - main [str "default", trm T] :- !, coq.error "TODO". + main [str "default", trm T] :- !, std.assert! (cs.compiler.default.main T) "Cannot compile canonical structure". main L :- coq.error " Invalid input for command cs\n Expected:\n \tElpi cs cs (CANSTR)\n - \tElpi class (STRU)\n \tElpi default (CANSTR)\n" L. + % \tElpi class (STRU)\n } \ No newline at end of file diff --git a/apps/tc/elpi/ho_link.elpi b/apps/tc/elpi/ho_link.elpi index ec9d4e0f4..d037bce07 100644 --- a/apps/tc/elpi/ho_link.elpi +++ b/apps/tc/elpi/ho_link.elpi @@ -133,10 +133,10 @@ namespace tc.link { % Projection LINK % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% namespace proj { - func proj term, term ->. - proj T V :- var V, !, get-vars T Vars, declare_constraint (proj T V) [_,V|Vars]. - :name "proj-unif" - proj T R :- coq.unify-eq T R ok. + % func proj term, term ->. + % proj T V :- var V, !, get-vars T Vars, declare_constraint (proj T V) [_,V|Vars]. + % :name "proj-unif" + % proj T R :- coq.unify-eq T R ok. func force-unify list prop, term, term ->. :name "force-proj" @@ -145,9 +145,9 @@ namespace tc.link { force-unify Ctx A B :- Ctx => coq.unify-eq A B ok. - constraint decl def ?- solve-proj proj { + constraint decl def ?- solve-proj tc.link.proj force-unify { % TODO: should add a dedup constraint - rule solve-proj \ (Ctx ?- proj A B) <=> (force-unify Ctx A B). + rule solve-proj \ (Ctx ?- tc.link.proj C A B) <=> (force-unify Ctx (app[global (const C), A]) B). % rule solve-proj \ (Ctx ?- proj A B) <=> (A = B). rule \ solve-proj. } @@ -175,8 +175,8 @@ namespace tc.link { func solve-llam. solve-llam :- declare_constraint solve-llam [_]. - func proj term, term ->. - proj A B :- proj.proj A B. + % func proj constant, term -> term. + % proj A B :- proj.proj A B. func solve-proj. solve-proj :- declare_constraint solve-proj [_]. diff --git a/apps/tc/tests/test_proj.v b/apps/tc/tests/test_proj.v index 58733e0f5..0bbd34cec 100644 --- a/apps/tc/tests/test_proj.v +++ b/apps/tc/tests/test_proj.v @@ -10,7 +10,7 @@ Canonical Structure c := mkr nat (fun x => x). Elpi Query TC.Solver lp:{{ true. }}. -Elpi cs class (r). +Elpi cs default (r). Elpi cs cs (c). Elpi Accumulate TC.Compiler lp:{{ @@ -72,7 +72,7 @@ End m1''. Module m2. Elpi Accumulate TC.Compiler lp:{{ - :after "is-class-C" is-class-C (tc-C X (app[_,W]) :- [canstr-car X W]) :- !, name X. + :after "is-class-C" is-class-C (tc-C X (app[_,W]) :- [tc.link.proj CAR X W]) :- !, const CAR = {{:gref car}}, name X. }}. (* cannot reduce the projection: c is quantified *) @@ -176,40 +176,22 @@ End M. Module M1. Class C (T : Type) := {f : T -> Prop}. - Instance i x : C (car x). Admitted. - Elpi Accumulate TC.Solver lp:{{ - tc.print-compiled-goal. - }}. + Local Instance i x : C (car x). Admitted. Check (_ : C (car _)). End M1. +Module M2. + Inductive to_prop (T: Type) : Prop := tp : T -> to_prop T. + Record r1 := mkr1 {car : Type; #[canonical=no] rf : C car}. + Local Instance i : C bool. Admitted. + Local Canonical Structure c1 := mkr1 bool i. + Elpi cs default (r1). + Elpi cs cs (c1). -(* Module tc. - Class Cx (t: Type) := mkC {op : t -> t -> bool}. - Record Rx := mkR {car : Type; class_of : Cx car}. - - Set Printing All. - - Instance Ic : Cx bool := mkC _ (fun (x:bool) y => if x then y else negb y). - Canonical Structure Ir := mkR bool Ic. - - Elpi cs class (Rx). - Elpi cs cs (Ir). - Elpi Print TC.Compiler "elpi.apps.derive.tests/xxx". - - From elpi.apps.tc.elpi Extra Dependency "tc_aux.elpi" as tc_aux. - From elpi.apps.tc.elpi Extra Dependency "cs.elpi" as cs. - - Elpi Tactic solve_cs. - Elpi Accumulate Db tc.db. - Elpi Accumulate File tc_aux. - Elpi Accumulate File cs. - - Elpi Accumulate lp:{{ - solve (goal _ _ Ty _ _ as G) GL :- - coq.say Ty. - }}. - - Definition op_of (T: Rx) := @op _ (class_of T). *) - \ No newline at end of file + Goal exists x, to_prop (C (car x)). + Proof. + eexists; constructor. + apply _. + Qed. +End M2. \ No newline at end of file diff --git a/apps/tc/theories/db.v b/apps/tc/theories/db.v index 4f370b64d..72b36a6e6 100644 --- a/apps/tc/theories/db.v +++ b/apps/tc/theories/db.v @@ -99,7 +99,8 @@ Elpi Db tc.db lp:{{ func link.eta term, term ->. func link.llam term, term ->. func link.unif-eq term, term ->. - func link.proj term, term ->. + :index (1 5) + func link.proj constant, term -> term. } }}. From 17fa7d910c44ff1d29829053e3dc910f84e1821b Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Sun, 21 Jun 2026 22:32:11 +0200 Subject: [PATCH 52/62] check-pname --- apps/tc/elpi/tc_aux.elpi | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/apps/tc/elpi/tc_aux.elpi b/apps/tc/elpi/tc_aux.elpi index 5a4fefb3b..6dfe2cc57 100644 --- a/apps/tc/elpi/tc_aux.elpi +++ b/apps/tc/elpi/tc_aux.elpi @@ -104,6 +104,12 @@ namespace tc { get-TC-of-inst-type T Hd, coq.TC.class? Hd. + func check-pname string, gref ->. + check-pname N _ :- coq.elpi.predicate? N, !. + check-pname _ G :- + MSG is "Found an undeclared class in Elpi.\nPlease add it via: Elpi TC.AddClasses " ^ {coq.gref->id G}, + coq.say MSG, coq.error MSG. + % [gref->pred-name P G S] % takes a prefix P and a gref G % returns S = P-[PATH_TO_G].P-[TC-Name] @@ -148,6 +154,7 @@ namespace tc { get-TC-of-inst-type Class ClassGR, gref->pred-name "tc" ClassGR ClassStr, std.append Args [Sol] ArgsSol, + tc.check-pname ClassStr ClassGR, coq.elpi.predicate ClassStr ArgsSol RuleHead, make-tc.aux IsPositive Sol RuleHead RuleBody Rule. From 723720f70faa45433e87717d04ade30dc2e1c676 Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Mon, 22 Jun 2026 09:46:17 +0200 Subject: [PATCH 53/62] simpl decompile of proj link --- apps/tc/elpi/ho_compile.elpi | 8 ++------ apps/tc/elpi/ho_precompile.elpi | 1 + apps/tc/tests/prim_proj.v | 2 +- 3 files changed, 4 insertions(+), 7 deletions(-) diff --git a/apps/tc/elpi/ho_compile.elpi b/apps/tc/elpi/ho_compile.elpi index 9c0143651..2f509891a 100644 --- a/apps/tc/elpi/ho_compile.elpi +++ b/apps/tc/elpi/ho_compile.elpi @@ -69,9 +69,7 @@ namespace tc.compile { decompile-term-aux (primitive _ as P) A L P A L :- !. :name "decompile-inst-maybe-proj" - decompile-term-aux (tc.maybe-proj P _ _ T S) [X|XS] L1 Y XS [NL|L1] :- !, - name Y X S, - cs.compiler.cs.compiler ff (pr 0 P) T (app[_, Y]) [] [] NL. + decompile-term-aux (tc.maybe-proj P _ _ T S) [X|XS] L1 Y XS [tc.link.proj P Y T|L1] :- !, name Y X S. decompile-term-aux (tc.maybe-eta-tm T S) [X|XS] L1 Y XS' [NL | L2] :- !, name Y X S, @@ -378,9 +376,7 @@ namespace tc.compile { decomp-term (tc.maybe-eta-tm T S) L V [tc.link.eta V T' | L2] :- prune V S, !, decomp-term T L T' L2. - decomp-term (tc.maybe-proj P _ Ag T S) L X [NL|L] :- !, - prune X S, - cs.compiler.cs.compiler ff (pr 0 P) T (app[_, X]) [] [] NL. + decomp-term (tc.maybe-proj P _ _ T S) L Y [tc.link.proj P Y T|L] :- !, prune Y S. decomp-term (tc.prod-range T _) A T' A' :- !, decomp-term T A T' A'. diff --git a/apps/tc/elpi/ho_precompile.elpi b/apps/tc/elpi/ho_precompile.elpi index a110eba6f..9ab4d854b 100644 --- a/apps/tc/elpi/ho_precompile.elpi +++ b/apps/tc/elpi/ho_precompile.elpi @@ -130,6 +130,7 @@ namespace tc.precomp { :name "precomp-proj-inst" precompile-aux _ T N T' N' :- tc.maybe-projection T P PN Ag R, !, + % TODO: should precompile Ag? work-proj free-var P PN Ag R N T' N'. % Detect maybe-eta term diff --git a/apps/tc/tests/prim_proj.v b/apps/tc/tests/prim_proj.v index 414dc44db..f1e2b32bf 100644 --- a/apps/tc/tests/prim_proj.v +++ b/apps/tc/tests/prim_proj.v @@ -4,7 +4,7 @@ Set Primitive Projections. Record S := { sort :> Type }. Unset Primitive Projections. -Elpi cs class (S). +Elpi cs default (S). Class C (s : Type) := {}. From 0bc4e80e9f93957a1a4b767fd60b6142d10b2c5b Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Tue, 23 Jun 2026 09:56:45 +0200 Subject: [PATCH 54/62] cs start plug with tc --- apps/tc/elpi/cs.elpi | 31 ++++++++++++++++++++++++++----- 1 file changed, 26 insertions(+), 5 deletions(-) diff --git a/apps/tc/elpi/cs.elpi b/apps/tc/elpi/cs.elpi index a7e97b761..031de134a 100644 --- a/apps/tc/elpi/cs.elpi +++ b/apps/tc/elpi/cs.elpi @@ -156,23 +156,44 @@ namespace cs { % CS is the instance of the structure % Ag is the term being consumed for compilation (i.e. the implementation of CS) % L is the list of premises (TODO: should be removed?) + % PT is the list of pi-quantified variables for problematic subterms % A is the list of abstractions: the arguments of CS % C is the final rule - func compiler bool, (pair int constant), term, term, list prop, list term -> prop. - compiler B (pr N P) CS (app[_|Ag]) L A Rs :- !, + % NOTE: differently from type-class compilation, we are not compiling + % types of terms, but their implementation. That is we need to cross + % fun instead of prod + :index (_ _ _ 1) + func compiler bool, (pair int constant), term, term, list prop, list term, list term -> prop. + compiler B (pr N P) CS (app[_|Ag]) L _ A Rs :- coq.mk-app CS {std.rev A} CS', std.nth N Ag I, precompile I z I' NPb, load-nestedp NPb B P I' CS' [] Rs. - compiler B P CS (fun N Ty Bo') L A (pi x\ R x) :- + compiler B P CS (fun N Ty Bo') L PT A (pi x\ R x) :- @pi-decl N Ty x\ (is-uvar x :- !) ==> - compiler B P CS (Bo' x) L [x|A] (R x). + compiler B P CS (Bo' x) L [x|A] PT (R x). + + func compiler-pt nat, (pair int constant), term, term, list term -> prop. + compiler-pt z IC CS T L R :- compiler tt IC CS T [] L [] R. + compiler-pt (s N) IC CS T L (pi x\ R x) :- + pi x\ is-uvar x => compiler-pt N IC CS T [x|L] (R x). + + :index (_ _ _ _ 1 1) + func compiler-univ nat, (pair int constant), term, term, list univ, list univ-instance -> prop. + compiler-univ N IC CS T [] [] R :- compiler-pt N IC CS T [] R. + compiler-univ N IC CS T [X|Xs] L (pi x\ R x) :- + pi x\ (copy (sort (typ X)) (sort (typ x)) :- !) => + compiler-univ N IC CS T Xs L (R x). + compiler-univ N IC CS T [] [X|Xs] (pi x\ R x) :- + pi x\ (copy (pglobal A UnivInst) (pglobal A x) :- !) => + compiler-univ N IC CS T [] Xs (R x). func main term ->. main (global (const C) as T) :- coq.env.const C (some Bo) Ty, get-proj Ty P, - std.forall P (x\ sigma R\ compiler tt x T Bo [] [] R, tc.add-tc-db _ _ R). + % tc.precomp.instance T T' N UnivConstL UnivInstL, + std.forall P (x\ sigma R\ compiler tt x T Bo [] [] [] R, tc.add-tc-db _ _ R). } namespace default { From 31981100408a209e4bf3b46cb7657d7bc5c34e6c Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Tue, 23 Jun 2026 11:12:08 +0200 Subject: [PATCH 55/62] remove prod-range --- apps/tc/elpi/cs.elpi | 29 ++++++++++++++--------------- apps/tc/elpi/ho_compile.elpi | 20 +++++--------------- apps/tc/elpi/ho_link.elpi | 3 +++ apps/tc/elpi/ho_precompile.elpi | 21 +++++++-------------- apps/tc/elpi/tc_aux.elpi | 5 ----- apps/tc/tests/test_proj.v | 4 ++-- apps/tc/theories/db.v | 4 ++-- 7 files changed, 33 insertions(+), 53 deletions(-) diff --git a/apps/tc/elpi/cs.elpi b/apps/tc/elpi/cs.elpi index 031de134a..f85622083 100644 --- a/apps/tc/elpi/cs.elpi +++ b/apps/tc/elpi/cs.elpi @@ -69,7 +69,7 @@ namespace cs { % compile P I CS R :- % proj-to-pname P PN, % coq.elpi.predicate PN [I, CS] R. - compile P I CS (tc.link.proj P I CS :- !). + compile P I CS (tc.link.proj P CS I :- !). func mk-rule bool, prop, list prop -> prop. mk-rule _ P [] P :- !. @@ -147,7 +147,7 @@ namespace cs { load-nestedp z B C T P L R :- decompile T (pr L []) T' (pr _ Pm), % coq.elpi.predicate C [T', P] Hd, - mk-rule B (tc.link.proj C T' P) {std.rev Pm} R. + mk-rule B (tc.link.proj C P T') {std.rev Pm} R. load-nestedp (s N) B C T P L (pi x\ R x) :- pi x\ load-nestedp N B C T P [x|L] (R x). % [compiler B IC CS Ag P L C] @@ -193,20 +193,20 @@ namespace cs { coq.env.const C (some Bo) Ty, get-proj Ty P, % tc.precomp.instance T T' N UnivConstL UnivInstL, - std.forall P (x\ sigma R\ compiler tt x T Bo [] [] [] R, tc.add-tc-db _ _ R). + std.forall P (x\ sigma R\ compiler tt x T Bo [] [] [] R, tc.add-tc-db _ (after "0") R). } - namespace default { - func build-default constant ->. - build-default D :- - R = (pi x y z \ tc.link.proj D (uvar as x) y :- declare_constraint (tc.link.proj D x y) [x,z]), - tc.add-tc-db _ _ R. + % namespace default { + % func build-default constant ->. + % build-default D :- + % R = (pi x y z \ tc.link.proj D (uvar as x) y :- declare_constraint (tc.link.proj D x y) [x,z]), + % tc.add-tc-db _ _ R. - func main term ->. - main (global (indt C)) :- - coq.env.projections C P, - cs.compiler.forall-ocan build-default P. - } + % func main term ->. + % main (global (indt C)) :- + % coq.env.projections C P, + % cs.compiler.forall-ocan build-default P. + % } } namespace solver { @@ -217,11 +217,10 @@ namespace cs { :name "cs-main" % main [str "class", trm T] :- !, std.assert! (cs.compiler.record.create-cs-pred T) "Cannot compile record projection". main [str "cs", trm T] :- !, std.assert! (cs.compiler.cs.main T) "Cannot compile canonical structure". - main [str "default", trm T] :- !, std.assert! (cs.compiler.default.main T) "Cannot compile canonical structure". + % main [str "default", trm T] :- !, std.assert! (cs.compiler.default.main T) "Cannot compile canonical structure". main L :- coq.error " Invalid input for command cs\n Expected:\n \tElpi cs cs (CANSTR)\n - \tElpi default (CANSTR)\n" L. % \tElpi class (STRU)\n } \ No newline at end of file diff --git a/apps/tc/elpi/ho_compile.elpi b/apps/tc/elpi/ho_compile.elpi index 2f509891a..7b71271a3 100644 --- a/apps/tc/elpi/ho_compile.elpi +++ b/apps/tc/elpi/ho_compile.elpi @@ -69,16 +69,13 @@ namespace tc.compile { decompile-term-aux (primitive _ as P) A L P A L :- !. :name "decompile-inst-maybe-proj" - decompile-term-aux (tc.maybe-proj P _ _ T S) [X|XS] L1 Y XS [tc.link.proj P Y T|L1] :- !, name Y X S. + decompile-term-aux (tc.maybe-proj P _ _ T S) [X|XS] L1 Y XS [tc.link.proj P T Y|L1] :- !, name Y X S. decompile-term-aux (tc.maybe-eta-tm T S) [X|XS] L1 Y XS' [NL | L2] :- !, name Y X S, decompile-term-aux T XS L1 T' XS' L2, NL = tc.link.eta Y T'. - decompile-term-aux (tc.prod-range T _) A L T' A' L' :- !, - decompile-term-aux T A L T' A' L'. - % Maybe-llam when H is a coq unif variable quantified in the instance type % In the following instance, X is a HO variable applied to a constant (not a name) % Instance i : forall (X : T1 -> T2) (a : T1), c (X a). @@ -165,7 +162,6 @@ namespace tc.compile { clean-term A B :- (pi c n a s sc r \ copy (tc.maybe-proj c n a s sc) r :- !, sigma X\ std.append a [s] X, copy (app[global(const c) | X]) r) => (pi t s r \ copy (tc.maybe-eta-tm t s) r :- !, copy t r, !) => - (pi t s r \ copy (tc.prod-range t s) r :- !, copy t r, !) => (pi t s r \ copy (tc.maybe-llam-tm t s) r :- !, copy t r, !) => std.assert! (copy A B) "[TC] clean-term error". @@ -216,9 +212,6 @@ namespace tc.compile { name A' A {std.rev L}, Link = tc.link.eta A' (fun Name Ty' B'), pi x\ sigma L'\ std.rev [x|L] L', name (B' x) B L'. - % Going under prod-range - make-eta-link-aux A (tc.prod-range Prod _) BN L Link Ty' Bo :- !, - make-eta-link-aux A Prod BN L Link Ty' Bo. % The type of a higher order variable can be hidden behind a definition % In this case we unfold this definition to get the prod constructor make-eta-link-aux A T BN L Link Ty' Bo :- @@ -267,8 +260,7 @@ namespace tc.compile { i:list prop, % Pr : the premises of the rule o:prop. % C : the final clause corresponding to the compilation of I compile-premise L L2 P PTy ProofHd IsPositive ITy ProofTlR PremR Clause :- - ((pi a b c\ tc.get-TC-of-inst-type (tc.prod-range a c) b :- !, tc.get-TC-of-inst-type a b) => - tc.get-TC-of-inst-type PTy TC), !, + tc.get-TC-of-inst-type PTy TC, !, compile-ty L L1 P {neg IsPositive} PTy [] [] NewPrem, if (tc.class TC _ tc.deterministic _) (NewPrem' = std.once NewPrem) @@ -287,8 +279,9 @@ namespace tc.compile { list term, % Ag : the arguments of I that will be part of the proof list prop % Pr : the premises of the rule -> prop. % C : the final clause corresponding to the compilation of I - compile-ty L L1 ProofHd IsPositive (tc.prod-range (prod N Ty Bo) Arity) ProofTlR PremR Clause :- !, + compile-ty L L1 ProofHd IsPositive (prod N Ty Bo) ProofTlR PremR Clause :- !, std.do![ + std.assert! (pi x\ tc.precomp.instance.get-max-arity x Ty (Bo x) Arity) "[TC] get-max-arity should not fail", if (IsPositive = tt) (Clause = (pi x\ C x), E = is-uvar) (clean-term Ty Ty', Clause = (pi x\ decl x N Ty' => C x), E = is-name), @@ -376,10 +369,7 @@ namespace tc.compile { decomp-term (tc.maybe-eta-tm T S) L V [tc.link.eta V T' | L2] :- prune V S, !, decomp-term T L T' L2. - decomp-term (tc.maybe-proj P _ _ T S) L Y [tc.link.proj P Y T|L] :- !, prune Y S. - - decomp-term (tc.prod-range T _) A T' A' :- !, - decomp-term T A T' A'. + decomp-term (tc.maybe-proj P _ _ T S) L Y [tc.link.proj P T Y|L] :- !, prune Y S. decomp-term (tc.maybe-llam-tm (app [app[H|S] | NPF]) Sc) L Z [NL|L'] :- !, prune Z Sc, diff --git a/apps/tc/elpi/ho_link.elpi b/apps/tc/elpi/ho_link.elpi index d037bce07..e5b5dca7f 100644 --- a/apps/tc/elpi/ho_link.elpi +++ b/apps/tc/elpi/ho_link.elpi @@ -147,12 +147,15 @@ namespace tc.link { constraint decl def ?- solve-proj tc.link.proj force-unify { % TODO: should add a dedup constraint + % TODO: the term (app[global(const C), A]) is wrong since C can have parameters... rule solve-proj \ (Ctx ?- tc.link.proj C A B) <=> (force-unify Ctx (app[global (const C), A]) B). % rule solve-proj \ (Ctx ?- proj A B) <=> (A = B). rule \ solve-proj. } } + proj C (app[global(const C)| Ag]) L :- !, std.last Ag L. + namespace unif-eq { func unif-eq term, term. unif-eq T1 (uvar as T2) :- !, declare_constraint (unif-eq T1 T2) [_,T2]. diff --git a/apps/tc/elpi/ho_precompile.elpi b/apps/tc/elpi/ho_precompile.elpi index 9ab4d854b..3e6d3c7dc 100644 --- a/apps/tc/elpi/ho_precompile.elpi +++ b/apps/tc/elpi/ho_precompile.elpi @@ -84,6 +84,11 @@ namespace tc.precomp { :index (_ 1) func get-max-arity-aux term, term -> nat. get-max-arity-aux _ N z :- name N, !. + get-max-arity-aux _ (tc.maybe-proj _ _ _ _ _) z :- !. + get-max-arity-aux X (tc.maybe-llam-tm (app[app[H|PF]|NPF]) _) R :- !, + std.append PF NPF L, + get-max-arity-aux X (app[H|L]) R. + get-max-arity-aux X (tc.maybe-eta-tm T _) R :- !, get-max-arity-aux X T R. get-max-arity-aux T (app [H|L]) R :- !, if (T == H) (length-nat L Len) (Len = z), std.fold L Len (x\y\w\ sigma M\ get-max-arity-aux T x M, max-nat y M w) R. @@ -147,9 +152,7 @@ namespace tc.precomp { free-var Scope, std.fold-map NPF N (precompile-aux is_neg_fix) NPF1 M. - % Charge if we work with unification variable or local name - % And returns the subterms is a prod-range - precompile-aux IsP (prod Name Ty B) N (tc.prod-range (prod Name Ty' B') MaxAr) P :- !, + precompile-aux IsP (prod Name Ty B) N (prod Name Ty' B') P :- !, std.assert! (pi x\ get-max-arity x Ty (B x) MaxAr) "[TC] get-max-arity should not fail", if (IsP = is_pos) (C = x\ is-uvar x) (C = x\ is-name x), std.assert! (pi x\ C x => decl x Name Ty => precompile-aux IsP (B x) N (B' x) M) "[TC] should not fail", @@ -190,15 +193,6 @@ namespace tc.precomp { T' is obtained by the replacement of - all maybe-eta term `t1` with (tc.maybe-eta-tm `t1` `s`) where `s` = FV(`t1`) ==> This helps knowing if a subterm should be replaced with a `eta-link` - - all `prod _ Ty (x\ Bo x)` with (tc.prod-range (prod _ Ty (x\ Bo x)) N), - where N is represent the "maximal" application of `x` in `Bo` - for example: - let Ty = {{Type -> Type -> Type -> Type -> Type}}, - and Bo = x\ c1 (x nat bool) (x nat) (x nat nat bool) - the term `prod _ Ty Bo` is replaced with - (tc.prod-range (prod _ T Bo) 3) - since x is applied at most 3 times in Bo - ==> This helps charging the right number of `eta-link` for map-deduplication rule N is the number of problematic terms in T */ func instance term -> term, nat, list univ, list univ-instance. @@ -232,8 +226,7 @@ namespace tc.precomp { names Scope1, std.fold-map NPF N precompile-aux NPF1 M. - precompile-aux (prod Name Ty B) N (tc.prod-range (prod Name Ty' B') MaxAr) P :- !, - count-prod Ty MaxAr, + precompile-aux (prod Name Ty B) N (prod Name Ty' B') P :- !, std.assert! (pi x\ decl x Name Ty => precompile-aux (B x) N (B' x) M) "[TC] should not fail", precompile-aux Ty M Ty' P. diff --git a/apps/tc/elpi/tc_aux.elpi b/apps/tc/elpi/tc_aux.elpi index 6dfe2cc57..26f5bac00 100644 --- a/apps/tc/elpi/tc_aux.elpi +++ b/apps/tc/elpi/tc_aux.elpi @@ -298,11 +298,6 @@ namespace tc { proj-reducer-aux R P N O TyAg T. proj-reducer P _ Ag X T :- name X, !, build-proj-term P Ag X T. - type prod-range - term -> % The current qunatified uvar - nat -> % Its maximal application of the term - term. - type maybe-eta-tm term -> % The current precompiled subterm list term -> % The list of FV in the precomp subterm diff --git a/apps/tc/tests/test_proj.v b/apps/tc/tests/test_proj.v index 0bbd34cec..6dd7c1807 100644 --- a/apps/tc/tests/test_proj.v +++ b/apps/tc/tests/test_proj.v @@ -72,7 +72,7 @@ End m1''. Module m2. Elpi Accumulate TC.Compiler lp:{{ - :after "is-class-C" is-class-C (tc-C X (app[_,W]) :- [tc.link.proj CAR X W]) :- !, const CAR = {{:gref car}}, name X. + :after "is-class-C" is-class-C (tc-C X (app[_,W]) :- [tc.link.proj CAR W X]) :- !, const CAR = {{:gref car}}, name X. }}. (* cannot reduce the projection: c is quantified *) @@ -162,7 +162,7 @@ Module M. solve (goal _ _ {{@eq lp:T_ lp:P lp:T}} _ _ as G) GL :- % coq.say "The goal is"G, P = app [global (const Proj), A], - cs.compiler.cs.compiler ff (pr 0 Proj) A (app[_, T]) [] [] R, + cs.compiler.cs.compiler ff (pr 0 Proj) A (app[_, T]) [] [] [] R, % R, coq.say "The rule is"R, @no-tc! => refine {{eq_refl}} G GL. }}. diff --git a/apps/tc/theories/db.v b/apps/tc/theories/db.v index 72b36a6e6..6d1a53ca1 100644 --- a/apps/tc/theories/db.v +++ b/apps/tc/theories/db.v @@ -99,8 +99,8 @@ Elpi Db tc.db lp:{{ func link.eta term, term ->. func link.llam term, term ->. func link.unif-eq term, term ->. - :index (1 5) - func link.proj constant, term -> term. + :index (1 2 2) + func link.proj constant -> term, term. } }}. From daddcf5fe2fe9dbaff7eb68dc81b48bed26bee3c Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Tue, 23 Jun 2026 11:14:05 +0200 Subject: [PATCH 56/62] fix lex error --- apps/tc/elpi/cs.elpi | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/apps/tc/elpi/cs.elpi b/apps/tc/elpi/cs.elpi index f85622083..9f440449a 100644 --- a/apps/tc/elpi/cs.elpi +++ b/apps/tc/elpi/cs.elpi @@ -220,7 +220,6 @@ namespace cs { % main [str "default", trm T] :- !, std.assert! (cs.compiler.default.main T) "Cannot compile canonical structure". main L :- coq.error " Invalid input for command cs\n - Expected:\n - \tElpi cs cs (CANSTR)\n + Expected:\n \tElpi cs cs (CANSTR)". % \tElpi class (STRU)\n } \ No newline at end of file From 8ab0a771d645bef04bd99a161e9a154a298229be Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Tue, 23 Jun 2026 15:23:26 +0200 Subject: [PATCH 57/62] kill cs default + clean tc.maybe-llam --- apps/tc/elpi/cs.elpi | 8 +++++--- apps/tc/elpi/ho_compile.elpi | 8 ++++---- apps/tc/elpi/ho_link.elpi | 2 +- apps/tc/elpi/ho_precompile.elpi | 11 ++++++----- apps/tc/elpi/tc_aux.elpi | 11 ++++++++++- apps/tc/tests/prim_proj.v | 2 -- apps/tc/tests/test.v | 6 +++--- apps/tc/tests/test_proj.v | 3 +-- 8 files changed, 30 insertions(+), 21 deletions(-) diff --git a/apps/tc/elpi/cs.elpi b/apps/tc/elpi/cs.elpi index 9f440449a..3ba8a4ba8 100644 --- a/apps/tc/elpi/cs.elpi +++ b/apps/tc/elpi/cs.elpi @@ -71,9 +71,11 @@ namespace cs { % coq.elpi.predicate PN [I, CS] R. compile P I CS (tc.link.proj P CS I :- !). + :index (1 _ 1) func mk-rule bool, prop, list prop -> prop. - mk-rule _ P [] P :- !. - mk-rule tt P R (P :- R). + mk-rule tt P [] (P :- !) :- !. + mk-rule ff P [] P :- !. + mk-rule tt P R (P :- !, R). mk-rule ff P R (R => P). func work-proj constant, int, list term, term, nat -> term, nat. @@ -193,7 +195,7 @@ namespace cs { coq.env.const C (some Bo) Ty, get-proj Ty P, % tc.precomp.instance T T' N UnivConstL UnivInstL, - std.forall P (x\ sigma R\ compiler tt x T Bo [] [] [] R, tc.add-tc-db _ (after "0") R). + std.forall P (x\ sigma R\ compiler tt x T Bo [] [] [] R, coq.say "Adding R"R, tc.add-tc-db _ (after "0") R). } % namespace default { diff --git a/apps/tc/elpi/ho_compile.elpi b/apps/tc/elpi/ho_compile.elpi index 7b71271a3..d031291f8 100644 --- a/apps/tc/elpi/ho_compile.elpi +++ b/apps/tc/elpi/ho_compile.elpi @@ -79,7 +79,7 @@ namespace tc.compile { % Maybe-llam when H is a coq unif variable quantified in the instance type % In the following instance, X is a HO variable applied to a constant (not a name) % Instance i : forall (X : T1 -> T2) (a : T1), c (X a). - decompile-term-aux (tc.maybe-llam-tm (app[app[H | PF] | NPF]) S) [X|XS] L1 Y XS' [NL | L2] :- + decompile-term-aux (tc.maybe-llam-tm H PF NPF S) [X|XS] L1 Y XS' [NL | L2] :- not (var H), !, % is-uvar H, holds name Y X S, length-nat PF Len, @@ -92,7 +92,7 @@ namespace tc.compile { % This happens when the instance to be compiled comes from the context % Example: Goal exists (X : T1 -> T2), forall a, c (X a) -> ... % intros; eexists. (* In the context we have the instance `H: c (?X a)` *) - decompile-term-aux (tc.maybe-llam-tm (app[app[H | PF] | NPF]) S) A L Z XS' [NL | L3] :- !, + decompile-term-aux (tc.maybe-llam-tm H PF NPF S) A L Z XS' [NL | L3] :- !, var H _ Scope, !, std.append Scope S S', prune Z S', @@ -162,7 +162,7 @@ namespace tc.compile { clean-term A B :- (pi c n a s sc r \ copy (tc.maybe-proj c n a s sc) r :- !, sigma X\ std.append a [s] X, copy (app[global(const c) | X]) r) => (pi t s r \ copy (tc.maybe-eta-tm t s) r :- !, copy t r, !) => - (pi t s r \ copy (tc.maybe-llam-tm t s) r :- !, copy t r, !) => + (pi a p n s r \ copy (tc.maybe-llam-tm a p n s) r :- !, sigma X\ std.append p n X, copy (app[a|X]) r, !) => std.assert! (copy A B) "[TC] clean-term error". func main @@ -371,7 +371,7 @@ namespace tc.compile { decomp-term (tc.maybe-proj P _ _ T S) L Y [tc.link.proj P T Y|L] :- !, prune Y S. - decomp-term (tc.maybe-llam-tm (app [app[H|S] | NPF]) Sc) L Z [NL|L'] :- !, + decomp-term (tc.maybe-llam-tm H S NPF Sc) L Z [NL|L'] :- !, prune Z Sc, get-uva-pair-arity H S Y, std.fold-map NPF L decomp-term Tl L', diff --git a/apps/tc/elpi/ho_link.elpi b/apps/tc/elpi/ho_link.elpi index e5b5dca7f..ad605d8c3 100644 --- a/apps/tc/elpi/ho_link.elpi +++ b/apps/tc/elpi/ho_link.elpi @@ -154,7 +154,7 @@ namespace tc.link { } } - proj C (app[global(const C)| Ag]) L :- !, std.last Ag L. + proj C L (app[global(const C)| Ag]) :- !, std.last Ag L. namespace unif-eq { func unif-eq term, term. diff --git a/apps/tc/elpi/ho_precompile.elpi b/apps/tc/elpi/ho_precompile.elpi index 3e6d3c7dc..95a753598 100644 --- a/apps/tc/elpi/ho_precompile.elpi +++ b/apps/tc/elpi/ho_precompile.elpi @@ -85,9 +85,10 @@ namespace tc.precomp { func get-max-arity-aux term, term -> nat. get-max-arity-aux _ N z :- name N, !. get-max-arity-aux _ (tc.maybe-proj _ _ _ _ _) z :- !. - get-max-arity-aux X (tc.maybe-llam-tm (app[app[H|PF]|NPF]) _) R :- !, - std.append PF NPF L, - get-max-arity-aux X (app[H|L]) R. + get-max-arity-aux X (tc.maybe-llam-tm H PF NPF _) R :- !, + if (H == X) (length-nat {std.append PF NPF} Len) (Len = z), + std.fold PF Len (x\y\w\ sigma M\ get-max-arity-aux X x M, max-nat y M w) R', + std.fold NPF R' (x\y\w\ sigma M\ get-max-arity-aux X x M, max-nat y M w) R. get-max-arity-aux X (tc.maybe-eta-tm T _) R :- !, get-max-arity-aux X T R. get-max-arity-aux T (app [H|L]) R :- !, if (T == H) (length-nat L Len) (Len = z), @@ -146,7 +147,7 @@ namespace tc.precomp { precompile-aux is_neg_fix Ty N _ N', (pi x\ is-name x => decl x Name Ty => precompile-aux is_neg_fix (B x) N' (B' x) M). - precompile-aux _ (app [X|XS]) N (tc.maybe-llam-tm (app [app[X | PF] | NPF1]) Scope) (s M) :- + precompile-aux _ (app [X|XS]) N (tc.maybe-llam-tm X PF NPF1 Scope) (s M) :- if (is-uvar X) (Sc = []) (var X _ Sc), split-pf is-name XS Sc PF NPF, not (NPF = []), !, % else XS is a list of distinct names, i.e. `app [X|XS]` is in PF free-var Scope, @@ -220,7 +221,7 @@ namespace tc.precomp { precompile-aux Ty M' Ty' M. % Detect maybe-beta term - precompile-aux (app [X|XS]) N (tc.maybe-llam-tm (app [app[X | PF] | NPF1]) Scope1) [X|M] :- + precompile-aux (app [X|XS]) N (tc.maybe-llam-tm X PF NPF1 Scope1) [X|M] :- var X _ Scope, split-pf name XS Scope PF NPF, not (NPF = []), !, % else XS is a list of distinct names, i.e. `app [X|XS]` is in PF names Scope1, diff --git a/apps/tc/elpi/tc_aux.elpi b/apps/tc/elpi/tc_aux.elpi index 26f5bac00..bfc84e42b 100644 --- a/apps/tc/elpi/tc_aux.elpi +++ b/apps/tc/elpi/tc_aux.elpi @@ -303,8 +303,17 @@ namespace tc { list term -> % The list of FV in the precomp subterm term. + % [maybe-llam-tm H PF NPF L] + % the original term is (app[H|{append PF NPF}]) + % H is a variable, PF is a list of distinct names and NPF is a list of terms + % a maybe-llam-tm is (F x y (H z) (K w)) when H and K become both (x\x) + % in this case the term becomes (maybe-llam F [x,y] [H z,K w] [V3,V4]) + % where V3 and V4 are elpi variables of arity 3 and 4, used to represent the + % term when applied to 3 or 4 arguments type maybe-llam-tm - term -> % The current precompiled subterm: shape is app[app[X,PF],NPF] + term -> % The head of the term + list term -> % The list of arguments in the PF + list term -> % The list of argument not in the PF list term -> % The eta-expanded version of X, from X^{len(PF)} to X^{len(PF)+len(NPF)} term. diff --git a/apps/tc/tests/prim_proj.v b/apps/tc/tests/prim_proj.v index f1e2b32bf..16d102eb6 100644 --- a/apps/tc/tests/prim_proj.v +++ b/apps/tc/tests/prim_proj.v @@ -4,8 +4,6 @@ Set Primitive Projections. Record S := { sort :> Type }. Unset Primitive Projections. -Elpi cs default (S). - Class C (s : Type) := {}. Instance SC (s : S) : C s := Build_C s. diff --git a/apps/tc/tests/test.v b/apps/tc/tests/test.v index aab23e495..20ab61f84 100644 --- a/apps/tc/tests/test.v +++ b/apps/tc/tests/test.v @@ -338,7 +338,7 @@ Module Llam_1. @pi-decl `x` {{Type -> Type}} g\ tc.precomp.is-uvar g => sigma T\ tc.precomp.instance {{A (fun x => lp:f (lp:g x))}} T N _ _, - std.assert! (T = app[{{A}}, tc.maybe-eta-tm (fun _ _ (x\ tc.maybe-llam-tm _ _)) _]) "[TC] invalid precomp". + std.assert! (T = app[{{A}}, tc.maybe-eta-tm (fun _ _ (x\ tc.maybe-llam-tm _ _ _ _)) _]) "[TC] invalid precomp". }}. Instance I1: forall F G, B G -> A (fun x => F (G x)). Qed. @@ -515,7 +515,7 @@ Module CoqUvar3. tc.precomp.goal {{c1 (fun x y => lp:X (lp:A x y) y)}} C _, Expected = app [{{c1}}, tc.maybe-eta-tm (fun _ _ Body1) _], Body1 = (x\ tc.maybe-eta-tm (fun _ _ (Body2 x)) [x]), - Body2 = (x\y\ tc.maybe-llam-tm (app [app [X], (Y x y), y]) [x,y]), + Body2 = (x\y\ tc.maybe-llam-tm X [] [Y x y, y] [x,y]), std.assert! (C = Expected) "[TC] invalid compilation". }}. @@ -555,7 +555,7 @@ Module CoqUvar4. tc.precomp.instance {{c1 (fun x y => lp:X (lp:A x y) y)}} C _ _ _, Expected = app [{{c1}}, tc.maybe-eta-tm (fun _ _ Body1) _], Body1 = (x\ tc.maybe-eta-tm (fun _ _ (Body2 x)) [x]), - Body2 = (x\y\ tc.maybe-llam-tm (app [app [X], (Y x y), y]) [y,x]), + Body2 = (x\y\ tc.maybe-llam-tm X [] [Y x y, y] [y,x]), std.assert! (C = Expected) "[TC] invalid compilation". }}. diff --git a/apps/tc/tests/test_proj.v b/apps/tc/tests/test_proj.v index 6dd7c1807..40c832d87 100644 --- a/apps/tc/tests/test_proj.v +++ b/apps/tc/tests/test_proj.v @@ -10,7 +10,7 @@ Canonical Structure c := mkr nat (fun x => x). Elpi Query TC.Solver lp:{{ true. }}. -Elpi cs default (r). +(* Elpi cs default (r). *) Elpi cs cs (c). Elpi Accumulate TC.Compiler lp:{{ @@ -186,7 +186,6 @@ Module M2. Record r1 := mkr1 {car : Type; #[canonical=no] rf : C car}. Local Instance i : C bool. Admitted. Local Canonical Structure c1 := mkr1 bool i. - Elpi cs default (r1). Elpi cs cs (c1). Goal exists x, to_prop (C (car x)). From a10fff721c0e04e94748417dd79d5c99e9bf9bc5 Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Wed, 24 Jun 2026 08:52:37 +0200 Subject: [PATCH 58/62] add tc prems to cs --- apps/tc/elpi/cs.elpi | 49 +++++++++++++++++---------------- apps/tc/tests/test_proj.v | 26 +++++++++++++++-- apps/tc/theories/add_commands.v | 2 +- apps/tc/theories/db.v | 2 +- apps/tc/theories/tc.v | 8 ++++-- 5 files changed, 57 insertions(+), 30 deletions(-) diff --git a/apps/tc/elpi/cs.elpi b/apps/tc/elpi/cs.elpi index 3ba8a4ba8..7fea7c17e 100644 --- a/apps/tc/elpi/cs.elpi +++ b/apps/tc/elpi/cs.elpi @@ -53,6 +53,7 @@ namespace cs { func get-proj term -> list (pair int constant). get-proj (prod _ _ B) Pg :- !, pi x\ get-proj (B x) Pg. + get-proj (app [X|_]) Pg :- !, get-proj X Pg. get-proj (global (indt R)) Pg :- coq.env.indt R _ N _ _ _ _, coq.env.projections R P, get-projn N P Pg. @@ -75,7 +76,7 @@ namespace cs { func mk-rule bool, prop, list prop -> prop. mk-rule tt P [] (P :- !) :- !. mk-rule ff P [] P :- !. - mk-rule tt P R (P :- !, R). + mk-rule tt P R (P :- [! | R]). mk-rule ff P R (R => P). func work-proj constant, int, list term, term, nat -> term, nat. @@ -144,13 +145,14 @@ namespace cs { % T is the argument (with N problematic subterms) % P is the instance of the record to be used % L is the list of pi accumulated terms + % Pr is the list of premises accumulated so far % R is the created clause - func load-nestedp nat, bool, constant, term, term, list term -> prop. - load-nestedp z B C T P L R :- + func load-nestedp nat, bool, constant, term, term, list term, list prop -> prop. + load-nestedp z B C T P L Pr R :- decompile T (pr L []) T' (pr _ Pm), % coq.elpi.predicate C [T', P] Hd, - mk-rule B (tc.link.proj C P T') {std.rev Pm} R. - load-nestedp (s N) B C T P L (pi x\ R x) :- pi x\ load-nestedp N B C T P [x|L] (R x). + mk-rule B (tc.link.proj C P T') {std.rev.aux Pm Pr} R. + load-nestedp (s N) B C T P L Pr (pi x\ R x) :- pi x\ load-nestedp N B C T P [x|L] Pr (R x). % [compiler B IC CS Ag P L C] % B is the pos/neg position of the term @@ -170,32 +172,33 @@ namespace cs { coq.mk-app CS {std.rev A} CS', std.nth N Ag I, precompile I z I' NPb, - load-nestedp NPb B P I' CS' [] Rs. + load-nestedp NPb B P I' CS' [] L Rs. compiler B P CS (fun N Ty Bo') L PT A (pi x\ R x) :- @pi-decl N Ty x\ (is-uvar x :- !) ==> - compiler B P CS (Bo' x) L [x|A] PT (R x). - - func compiler-pt nat, (pair int constant), term, term, list term -> prop. - compiler-pt z IC CS T L R :- compiler tt IC CS T [] L [] R. - compiler-pt (s N) IC CS T L (pi x\ R x) :- - pi x\ is-uvar x => compiler-pt N IC CS T [x|L] (R x). - - :index (_ _ _ _ 1 1) - func compiler-univ nat, (pair int constant), term, term, list univ, list univ-instance -> prop. - compiler-univ N IC CS T [] [] R :- compiler-pt N IC CS T [] R. - compiler-univ N IC CS T [X|Xs] L (pi x\ R x) :- - pi x\ (copy (sort (typ X)) (sort (typ x)) :- !) => - compiler-univ N IC CS T Xs L (R x). - compiler-univ N IC CS T [] [X|Xs] (pi x\ R x) :- - pi x\ (copy (pglobal A UnivInst) (pglobal A x) :- !) => - compiler-univ N IC CS T [] Xs (R x). + compiler B P CS (Bo' x) L PT [x|A] (R x). + + % func compiler-pt nat, (pair int constant), term, term, list term -> prop. + % compiler-pt z IC CS T L R :- compiler tt IC CS T [] L [] R. + % compiler-pt (s N) IC CS T L (pi x\ R x) :- + % pi x\ is-uvar x => compiler-pt N IC CS T [x|L] (R x). + + % :index (_ _ _ _ 1 1) + % func compiler-univ nat, (pair int constant), term, term, list univ, list univ-instance -> prop. + % compiler-univ N IC CS T [] [] R :- compiler-pt N IC CS T [] R. + % compiler-univ N IC CS T [X|Xs] L (pi x\ R x) :- + % pi x\ (copy (sort (typ X)) (sort (typ x)) :- !) => + % compiler-univ N IC CS T Xs L (R x). + % compiler-univ N IC CS T [] [X|Xs] (pi x\ R x) :- + % pi x\ (copy (pglobal A UnivInst) (pglobal A x) :- !) => + % compiler-univ N IC CS T [] Xs (R x). func main term ->. + :name "cs.compiler.main" main (global (const C) as T) :- coq.env.const C (some Bo) Ty, get-proj Ty P, % tc.precomp.instance T T' N UnivConstL UnivInstL, - std.forall P (x\ sigma R\ compiler tt x T Bo [] [] [] R, coq.say "Adding R"R, tc.add-tc-db _ (after "0") R). + std.forall P (x\ sigma R\ compiler tt x T Bo [] [] [] R, tc.add-tc-db _ (after "0") R). } % namespace default { diff --git a/apps/tc/tests/test_proj.v b/apps/tc/tests/test_proj.v index 40c832d87..c67168dce 100644 --- a/apps/tc/tests/test_proj.v +++ b/apps/tc/tests/test_proj.v @@ -8,7 +8,6 @@ Class E (T : nat) := {ge : unit}. Record r := mkr {car : Type; #[canonical=no] rf : car -> car}. Canonical Structure c := mkr nat (fun x => x). -Elpi Query TC.Solver lp:{{ true. }}. (* Elpi cs default (r). *) Elpi cs cs (c). @@ -143,7 +142,7 @@ Module m4. Goal forall x y, C (@ofe_car2 x y x). apply _. Qed. End m4. -Elpi Accumulate TC.Compiler lp:{{ :after "is-class-C" is-class-C _ :- !. }}. +(* Elpi Accumulate TC.Compiler lp:{{ :after "is-class-C" is-class-C _ :- !. }}. *) Set Printing All. Module M. @@ -193,4 +192,25 @@ Module M2. eexists; constructor. apply _. Qed. -End M2. \ No newline at end of file +End M2. + +Module M3. + + Structure set (T : Type) := MkSet { + set_to_pred : T -> Prop + }. + Arguments set_to_pred : simpl never. + + Class mem T X (x : T) := mkMem { IsMem : set_to_pred _ X x }. + + (* memType is the type of elements of a given set. *) + Module Mem. + Record type T (X : set T) := Pack { elt : T; memP : mem _ X elt }. + End Mem. + + Canonical Structure s T X E (I: @mem T X E) := Mem.Pack _ _ _ I. + Elpi cs cs (s). + Elpi Print TC.Compiler "elpi.apps.derive.tests/xxx". + + +End M3. \ No newline at end of file diff --git a/apps/tc/theories/add_commands.v b/apps/tc/theories/add_commands.v index 5a5b88f8b..6f9ad9dcf 100644 --- a/apps/tc/theories/add_commands.v +++ b/apps/tc/theories/add_commands.v @@ -24,10 +24,10 @@ Elpi Accumulate File tc_aux. Elpi Accumulate File ho_precompile. Elpi Accumulate File unif. Elpi Accumulate File ho_link. -Elpi Accumulate File cs. Elpi Accumulate File ho_compile. Elpi Accumulate File compiler1. Elpi Accumulate File modes. +Elpi Accumulate File cs. Elpi Accumulate lp:{{ main L :- args->str-list L L1, diff --git a/apps/tc/theories/db.v b/apps/tc/theories/db.v index 6d1a53ca1..5caeef854 100644 --- a/apps/tc/theories/db.v +++ b/apps/tc/theories/db.v @@ -100,7 +100,7 @@ Elpi Db tc.db lp:{{ func link.llam term, term ->. func link.unif-eq term, term ->. :index (1 2 2) - func link.proj constant -> term, term. + pred link.proj constant -> term, term. } }}. diff --git a/apps/tc/theories/tc.v b/apps/tc/theories/tc.v index d28b5473e..0d7cccbb1 100644 --- a/apps/tc/theories/tc.v +++ b/apps/tc/theories/tc.v @@ -51,13 +51,13 @@ Elpi Accumulate Db tc_options.db. Elpi Accumulate File tc_aux. Elpi Accumulate File unif. Elpi Accumulate File ho_link. -Elpi Accumulate File cs. Elpi Accumulate File ho_precompile. Elpi Accumulate File ho_compile. Elpi Accumulate File compiler1. Elpi Accumulate File modes. Elpi Accumulate File create_tc_predicate. Elpi Accumulate File solver. +Elpi Accumulate File cs. Elpi Query lp:{{ sigma Options\ tc.all-options Options, @@ -80,7 +80,6 @@ Elpi Command TC.Compiler. Elpi Accumulate Db tc.db. Elpi Accumulate Db tc_options.db. Elpi Accumulate File tc_aux. -Elpi Accumulate File cs. Elpi Accumulate File modes. Elpi Accumulate File create_tc_predicate. Elpi Accumulate File ho_precompile. @@ -88,6 +87,7 @@ Elpi Accumulate File ho_compile. Elpi Accumulate File unif. Elpi Accumulate File ho_link. Elpi Accumulate File compiler1. +Elpi Accumulate File cs. Elpi Accumulate lp:{{ /* @@ -207,6 +207,8 @@ Elpi Tactic cs. Elpi Accumulate Db tc_options.db. Elpi Accumulate Db tc.db. Elpi Accumulate File tc_aux. +Elpi Accumulate File ho_precompile. +Elpi Accumulate File ho_compile. Elpi Accumulate File cs. Elpi Accumulate lp:{{ main L :- cs.main L. @@ -216,6 +218,8 @@ Elpi Tactic solve_cs. Elpi Accumulate Db tc_options.db. Elpi Accumulate Db tc.db. Elpi Accumulate File tc_aux. +Elpi Accumulate File ho_precompile. +Elpi Accumulate File ho_compile. Elpi Accumulate File cs. (* Elpi Accumulate lp:{{ main L :- cs.main L. From 3d31cb41aa921ed78f13eb27d8ea72b57a99328f Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Wed, 24 Jun 2026 09:45:27 +0200 Subject: [PATCH 59/62] record constructor compiler for cs --- apps/tc/elpi/cs.elpi | 32 +++++++++++++++++++++++++++++--- apps/tc/elpi/ho_compile.elpi | 5 +++-- apps/tc/elpi/ho_link.elpi | 2 +- apps/tc/tests/test_proj.v | 23 ++++++++++++++++++----- 4 files changed, 51 insertions(+), 11 deletions(-) diff --git a/apps/tc/elpi/cs.elpi b/apps/tc/elpi/cs.elpi index 7fea7c17e..36978854d 100644 --- a/apps/tc/elpi/cs.elpi +++ b/apps/tc/elpi/cs.elpi @@ -70,7 +70,7 @@ namespace cs { % compile P I CS R :- % proj-to-pname P PN, % coq.elpi.predicate PN [I, CS] R. - compile P I CS (tc.link.proj P CS I :- !). + compile P I CS (tc.link.proj P I CS :- !). :index (1 _ 1) func mk-rule bool, prop, list prop -> prop. @@ -113,7 +113,7 @@ namespace cs { func decompile term, pair (list term) (list prop) -> term, pair (list term) (list prop). :name "cs-decompile" - decompile (tc.maybe-proj C _ _ R S) (pr [X|XS] L1) Y (pr XS [tc.link.proj C R Y|L1]) :- !, + decompile (tc.maybe-proj C _ _ R S) (pr [X|XS] L1) Y (pr XS [tc.link.proj C Y R|L1]) :- !, name Y X S. % proj-to-pname C PN, % coq.elpi.predicate PN [R, Y] NL. @@ -151,7 +151,7 @@ namespace cs { load-nestedp z B C T P L Pr R :- decompile T (pr L []) T' (pr _ Pm), % coq.elpi.predicate C [T', P] Hd, - mk-rule B (tc.link.proj C P T') {std.rev.aux Pm Pr} R. + mk-rule B (tc.link.proj C T' P) {std.rev.aux Pm Pr} R. load-nestedp (s N) B C T P L Pr (pi x\ R x) :- pi x\ load-nestedp N B C T P [x|L] Pr (R x). % [compiler B IC CS Ag P L C] @@ -173,9 +173,29 @@ namespace cs { std.nth N Ag I, precompile I z I' NPb, load-nestedp NPb B P I' CS' [] L Rs. + compiler B P CS (fun N Ty Bo') L PT A (pi x\ R x) :- tc.get-TC-of-inst-type Ty TC, !, + @pi-decl N Ty x\ (is-uvar x :- !) ==> + tc.compile.instance Ty x (Pr x), + compiler B P CS (Bo' x) [Pr x|L] PT [x|A] (R x). compiler B P CS (fun N Ty Bo') L PT A (pi x\ R x) :- @pi-decl N Ty x\ (is-uvar x :- !) ==> compiler B P CS (Bo' x) L PT [x|A] (R x). + + :index (_ _ _ 1) + func compiler-record bool, (pair int constant), term, term, list prop, list term, list term -> prop. + compiler-record B P CS (prod N Ty Bo') L PT A (pi x\ R x) :- tc.get-TC-of-inst-type Ty TC, !, + @pi-decl N Ty x\ (is-uvar x :- !) ==> + tc.compile.instance Ty x (Pr x), + compiler-record B P CS (Bo' x) [Pr x|L] PT [x|A] (R x). + compiler-record B P CS (prod N Ty Bo') L PT A (pi x\ R x) :- !, + @pi-decl N Ty x\ (is-uvar x :- !) ==> + compiler-record B P CS (Bo' x) L PT [x|A] (R x). + compiler-record B (pr N P) CS _ L _ A Rs :- + std.rev A Ar, + coq.mk-app CS Ar CS', + std.nth N Ar I, + precompile I z I' NPb, + load-nestedp NPb B P I' CS' [] L Rs. % func compiler-pt nat, (pair int constant), term, term, list term -> prop. % compiler-pt z IC CS T L R :- compiler tt IC CS T [] L [] R. @@ -192,6 +212,7 @@ namespace cs { % pi x\ (copy (pglobal A UnivInst) (pglobal A x) :- !) => % compiler-univ N IC CS T [] Xs (R x). + :index (4) func main term ->. :name "cs.compiler.main" main (global (const C) as T) :- @@ -199,6 +220,11 @@ namespace cs { get-proj Ty P, % tc.precomp.instance T T' N UnivConstL UnivInstL, std.forall P (x\ sigma R\ compiler tt x T Bo [] [] [] R, tc.add-tc-db _ (after "0") R). + main (global (indc C) as T) :- + coq.typecheck T Ty ok, + get-proj Ty P, + % tc.precomp.instance T T' N UnivConstL UnivInstL, + std.forall P (x\ sigma R\ compiler-record tt x T Ty [] [] [] R, tc.add-tc-db _ (after "0") R). } % namespace default { diff --git a/apps/tc/elpi/ho_compile.elpi b/apps/tc/elpi/ho_compile.elpi index d031291f8..403c2d753 100644 --- a/apps/tc/elpi/ho_compile.elpi +++ b/apps/tc/elpi/ho_compile.elpi @@ -69,7 +69,7 @@ namespace tc.compile { decompile-term-aux (primitive _ as P) A L P A L :- !. :name "decompile-inst-maybe-proj" - decompile-term-aux (tc.maybe-proj P _ _ T S) [X|XS] L1 Y XS [tc.link.proj P T Y|L1] :- !, name Y X S. + decompile-term-aux (tc.maybe-proj P _ _ T S) [X|XS] L1 Y XS [tc.link.proj P Y T|L1] :- !, name Y X S. decompile-term-aux (tc.maybe-eta-tm T S) [X|XS] L1 Y XS' [NL | L2] :- !, name Y X S, @@ -165,6 +165,7 @@ namespace tc.compile { (pi a p n s r \ copy (tc.maybe-llam-tm a p n s) r :- !, sigma X\ std.append p n X, copy (app[a|X]) r, !) => std.assert! (copy A B) "[TC] clean-term error". + :index (_ _ _ 1 1) func main nat, % the number of problematic terms term, % the type of the instance @@ -369,7 +370,7 @@ namespace tc.compile { decomp-term (tc.maybe-eta-tm T S) L V [tc.link.eta V T' | L2] :- prune V S, !, decomp-term T L T' L2. - decomp-term (tc.maybe-proj P _ _ T S) L Y [tc.link.proj P T Y|L] :- !, prune Y S. + decomp-term (tc.maybe-proj P _ _ T S) L Y [tc.link.proj P Y T|L] :- !, prune Y S. decomp-term (tc.maybe-llam-tm H S NPF Sc) L Z [NL|L'] :- !, prune Z Sc, diff --git a/apps/tc/elpi/ho_link.elpi b/apps/tc/elpi/ho_link.elpi index ad605d8c3..3cfc9fa98 100644 --- a/apps/tc/elpi/ho_link.elpi +++ b/apps/tc/elpi/ho_link.elpi @@ -148,7 +148,7 @@ namespace tc.link { constraint decl def ?- solve-proj tc.link.proj force-unify { % TODO: should add a dedup constraint % TODO: the term (app[global(const C), A]) is wrong since C can have parameters... - rule solve-proj \ (Ctx ?- tc.link.proj C A B) <=> (force-unify Ctx (app[global (const C), A]) B). + rule solve-proj \ (Ctx ?- tc.link.proj C B A) <=> (force-unify Ctx (app[global (const C), A]) B). % rule solve-proj \ (Ctx ?- proj A B) <=> (A = B). rule \ solve-proj. } diff --git a/apps/tc/tests/test_proj.v b/apps/tc/tests/test_proj.v index c67168dce..5c093fd0a 100644 --- a/apps/tc/tests/test_proj.v +++ b/apps/tc/tests/test_proj.v @@ -19,7 +19,12 @@ Elpi Accumulate TC.Compiler lp:{{ is-class-C (tc.instance _ _ _ _) :- !. :name "is-class-C" is-class-C (tc.class _ _ _ _) :- !. - is-class-C C :- coq.error "FAIL" C. + is-class-C C :- + coq.error + "Fail to verify the shape of compiled instance." + "Received:\n" C + "\nTo fix the issue either the class is compiled wrongly\n" + "or you forgot to load. A is-class-C rule in the database". :before "tc-adder" tc.add-tc-db _I _G C :- % coq.say "Compiled term is" C, @@ -71,7 +76,7 @@ End m1''. Module m2. Elpi Accumulate TC.Compiler lp:{{ - :after "is-class-C" is-class-C (tc-C X (app[_,W]) :- [tc.link.proj CAR W X]) :- !, const CAR = {{:gref car}}, name X. + :after "is-class-C" is-class-C (tc-C X (app[_,W]) :- [tc.link.proj CAR X W]) :- !, const CAR = {{:gref car}}, name X. }}. (* cannot reduce the projection: c is quantified *) @@ -196,6 +201,7 @@ End M2. Module M3. + Set Printing All. Structure set (T : Type) := MkSet { set_to_pred : T -> Prop }. @@ -208,9 +214,16 @@ Module M3. Record type T (X : set T) := Pack { elt : T; memP : mem _ X elt }. End Mem. - Canonical Structure s T X E (I: @mem T X E) := Mem.Pack _ _ _ I. - Elpi cs cs (s). + (* Canonical Structure s T X E (I: @mem T X E) := Mem.Pack _ _ _ I. *) + Elpi cs cs (Mem.Pack). + + Elpi Accumulate TC.Compiler lp:{{ + :after "is-class-C" is-class-C (tc-mem Ty S T {{@Mem.memP lp:Ty lp:S lp:Z}} :- [tc.link.proj X T Z]) :- !, + const X = {{:gref Mem.elt}}. + }}. + + Existing Instance Mem.memP. + Elpi Print TC.Compiler "elpi.apps.derive.tests/xxx". - End M3. \ No newline at end of file From 399a41515d7c100b48bad6328bcc2b83df9d3fbf Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Wed, 24 Jun 2026 10:31:44 +0200 Subject: [PATCH 60/62] add tests in test_proj --- apps/tc/elpi/ho_link.elpi | 2 +- apps/tc/tests/test_proj.v | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/apps/tc/elpi/ho_link.elpi b/apps/tc/elpi/ho_link.elpi index 3cfc9fa98..faa0abc11 100644 --- a/apps/tc/elpi/ho_link.elpi +++ b/apps/tc/elpi/ho_link.elpi @@ -154,7 +154,7 @@ namespace tc.link { } } - proj C L (app[global(const C)| Ag]) :- !, std.last Ag L. + proj C (app[global(const C)| Ag]) L :- !, std.last Ag L. namespace unif-eq { func unif-eq term, term. diff --git a/apps/tc/tests/test_proj.v b/apps/tc/tests/test_proj.v index 5c093fd0a..12f0051df 100644 --- a/apps/tc/tests/test_proj.v +++ b/apps/tc/tests/test_proj.v @@ -181,7 +181,7 @@ End M. Module M1. Class C (T : Type) := {f : T -> Prop}. Local Instance i x : C (car x). Admitted. - Check (_ : C (car _)). + Goal forall x, C (car x). apply _. Qed. End M1. Module M2. @@ -224,6 +224,6 @@ Module M3. Existing Instance Mem.memP. - Elpi Print TC.Compiler "elpi.apps.derive.tests/xxx". + (* Elpi Print TC.Compiler "elpi.apps.derive.tests/xxx". *) End M3. \ No newline at end of file From 334a0e7db1fdf3fc19d26b15ca5f44d67a42307f Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Wed, 24 Jun 2026 13:25:21 +0200 Subject: [PATCH 61/62] link.proj is a func (not pred) + add build-proj-app --- apps/tc/elpi/cs.elpi | 15 +++++++---- apps/tc/elpi/ho_link.elpi | 13 +++++++-- apps/tc/tests/test_proj.v | 55 ++++++++++++++++++++++++++++++++++++++- apps/tc/theories/db.v | 9 +++++-- 4 files changed, 82 insertions(+), 10 deletions(-) diff --git a/apps/tc/elpi/cs.elpi b/apps/tc/elpi/cs.elpi index 36978854d..d62d4c5f3 100644 --- a/apps/tc/elpi/cs.elpi +++ b/apps/tc/elpi/cs.elpi @@ -151,7 +151,7 @@ namespace cs { load-nestedp z B C T P L Pr R :- decompile T (pr L []) T' (pr _ Pm), % coq.elpi.predicate C [T', P] Hd, - mk-rule B (tc.link.proj C T' P) {std.rev.aux Pm Pr} R. + mk-rule B (tc.link.proj C T' P) {std.rev.aux Pm {std.rev [!|Pr]}} R. load-nestedp (s N) B C T P L Pr (pi x\ R x) :- pi x\ load-nestedp N B C T P [x|L] Pr (R x). % [compiler B IC CS Ag P L C] @@ -212,19 +212,24 @@ namespace cs { % pi x\ (copy (pglobal A UnivInst) (pglobal A x) :- !) => % compiler-univ N IC CS T [] Xs (R x). + func main.aux + (func bool, (pair int constant), term, term, list prop, list term, list term -> prop), + (pair int constant), term, term -> . + main.aux F IC I T :- + F tt IC I T [] [] [] R, + tc.add-tc-db _ (after "0") R. + :index (4) func main term ->. :name "cs.compiler.main" main (global (const C) as T) :- coq.env.const C (some Bo) Ty, get-proj Ty P, - % tc.precomp.instance T T' N UnivConstL UnivInstL, - std.forall P (x\ sigma R\ compiler tt x T Bo [] [] [] R, tc.add-tc-db _ (after "0") R). + std.forall P (x\ main.aux compiler x T Bo). main (global (indc C) as T) :- coq.typecheck T Ty ok, get-proj Ty P, - % tc.precomp.instance T T' N UnivConstL UnivInstL, - std.forall P (x\ sigma R\ compiler-record tt x T Ty [] [] [] R, tc.add-tc-db _ (after "0") R). + std.forall P (x\ main.aux compiler-record x T Ty). } % namespace default { diff --git a/apps/tc/elpi/ho_link.elpi b/apps/tc/elpi/ho_link.elpi index faa0abc11..d8b630a64 100644 --- a/apps/tc/elpi/ho_link.elpi +++ b/apps/tc/elpi/ho_link.elpi @@ -138,6 +138,15 @@ namespace tc.link { % :name "proj-unif" % proj T R :- coq.unify-eq T R ok. + % TODO: this recreates the application of C to T adding the record arguments + % as unification variables (via the _ symbol), we could pass them as a + % parameter of tc.link.proj + func build-proj-app constant, term -> term. + build-proj-app C T (app[global(const C) | L']) :- + coq.env.projection? C N, + std.list.make N _ L, + std.append L [T] L'. + func force-unify list prop, term, term ->. :name "force-proj" % If B is a variale we launch elpi unification @@ -147,14 +156,14 @@ namespace tc.link { constraint decl def ?- solve-proj tc.link.proj force-unify { % TODO: should add a dedup constraint - % TODO: the term (app[global(const C), A]) is wrong since C can have parameters... - rule solve-proj \ (Ctx ?- tc.link.proj C B A) <=> (force-unify Ctx (app[global (const C), A]) B). + rule solve-proj \ (Ctx ?- tc.link.proj C B A) <=> (build-proj-app C A T, force-unify Ctx T B). % rule solve-proj \ (Ctx ?- proj A B) <=> (A = B). rule \ solve-proj. } } proj C (app[global(const C)| Ag]) L :- !, std.last Ag L. + proj C (uvar as T) X :- declare_constraint (proj C T X) [T, _]. namespace unif-eq { func unif-eq term, term. diff --git a/apps/tc/tests/test_proj.v b/apps/tc/tests/test_proj.v index 12f0051df..196e3f24e 100644 --- a/apps/tc/tests/test_proj.v +++ b/apps/tc/tests/test_proj.v @@ -184,6 +184,14 @@ Module M1. Goal forall x, C (car x). apply _. Qed. End M1. +Module M1'. + Record r A := mkr {car1 : A}. + + Class C (T : Type) := {f : T -> Prop}. + Local Instance i x : C (car1 _ x). Admitted. + Goal forall x, C (car1 _ x). apply _. Qed. +End M1'. + Module M2. Inductive to_prop (T: Type) : Prop := tp : T -> to_prop T. @@ -195,6 +203,7 @@ Module M2. Goal exists x, to_prop (C (car x)). Proof. eexists; constructor. + apply _. Qed. End M2. @@ -226,4 +235,48 @@ Module M3. (* Elpi Print TC.Compiler "elpi.apps.derive.tests/xxx". *) -End M3. \ No newline at end of file +End M3. + +(* from stdpp/definitions.v *) +Module bv_bool. + Axiom N Z : Type. + Axiom zero : Z. + Axiom two one : N. + Axiom leq lt : Z -> Z -> bool. + Axiom pow : N -> Z -> Z. + Axiom ZofN : N -> Z. + Axiom Is_true : bool -> Prop. + Axiom Zeqdec : forall (x y:Z), sumbool (x = y) (not (x = y)). + + Class Decision (P : Prop) := decide : sumbool P (not P). + + Elpi Accumulate TC.Compiler lp:{{ :after "is-class-C" is-class-C _ :- !. }}. + + Class EqDecision A := + decide_rel x y :: Decision (@eq A x y). + + Definition bool_decide (P : Prop) {dec : Decision P} : bool := + if dec then true else false. + + Definition bv_modulus (n : N) : Z := pow two (ZofN n). + + Class BvWf (n : N) (z : Z) : Prop := + bv_wf : Is_true (andb (leq zero z) (lt z (bv_modulus n))). + + Record bv (n : N) := BV { + bv_unsigned : Z; + bv_is_wf : BvWf n bv_unsigned; + }. + + Axiom bool_to_bv : forall (n : N) (b : bool), bv n. + + Global Instance eq_dec: EqDecision Z := Zeqdec. + + Goal forall x b, Decision (@eq Z (bv_unsigned x (bool_to_bv x b)) zero). + Proof. intros. apply _. Qed. + + Lemma bool_decide_bool_to_bv_0 b: + bool_decide (bv_unsigned _ (bool_to_bv one b) = zero) = negb b. + Abort. + +End bv_bool. diff --git a/apps/tc/theories/db.v b/apps/tc/theories/db.v index 5caeef854..78fd2919b 100644 --- a/apps/tc/theories/db.v +++ b/apps/tc/theories/db.v @@ -99,8 +99,13 @@ Elpi Db tc.db lp:{{ func link.eta term, term ->. func link.llam term, term ->. func link.unif-eq term, term ->. - :index (1 2 2) - pred link.proj constant -> term, term. + + % a goal `p ?X = A` is translated into link.proj «p» X A + % link.proj is deterministic: this unification is deterministic. + % note that link.proj may have tc premises, that can be non deterministic. + % to avoid this issue, we wrap the non-deterministic call in std.once + :index (1 2) + func link.proj constant, term -> term. } }}. From a32364a88f7a7710f565326c3e35cde01ddeecc8 Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Wed, 24 Jun 2026 17:05:04 +0200 Subject: [PATCH 62/62] add solve to cs --- apps/tc/elpi/cs.elpi | 6 +++++- apps/tc/tests/dune | 2 +- apps/tc/tests/test_proj.v | 25 ++++++++++++++++++------- apps/tc/theories/tc.v | 3 +++ 4 files changed, 27 insertions(+), 9 deletions(-) diff --git a/apps/tc/elpi/cs.elpi b/apps/tc/elpi/cs.elpi index d62d4c5f3..a40d6ab18 100644 --- a/apps/tc/elpi/cs.elpi +++ b/apps/tc/elpi/cs.elpi @@ -246,7 +246,11 @@ namespace cs { } namespace solver { - + func solve goal ->. + solve (goal Ctx _ _ T [trm P, trm R] as G) :- + tc.compile.context Ctx CtxR, + coq.safe-dest-app P (global (const H)) _, + CtxR => tc.link.proj H R T. } pred main list argument. diff --git a/apps/tc/tests/dune b/apps/tc/tests/dune index aa17dd497..8f3390bff 100644 --- a/apps/tc/tests/dune +++ b/apps/tc/tests/dune @@ -2,7 +2,7 @@ (name elpi.apps.tc.tests) (flags :standard -async-proofs-cache force) (package rocq-elpi-tests) - (theories elpi elpi.apps.tc)) + (theories elpi elpi.apps.tc elpi.apps.cs)) (include_subdirs qualified) (dirs :standard \ WIP) diff --git a/apps/tc/tests/test_proj.v b/apps/tc/tests/test_proj.v index 196e3f24e..87f96ec35 100644 --- a/apps/tc/tests/test_proj.v +++ b/apps/tc/tests/test_proj.v @@ -208,6 +208,10 @@ Module M2. Qed. End M2. +From elpi Require Import cs. + +Elpi CS cs. + Module M3. Set Printing All. @@ -226,15 +230,22 @@ Module M3. (* Canonical Structure s T X E (I: @mem T X E) := Mem.Pack _ _ _ I. *) Elpi cs cs (Mem.Pack). - Elpi Accumulate TC.Compiler lp:{{ - :after "is-class-C" is-class-C (tc-mem Ty S T {{@Mem.memP lp:Ty lp:S lp:Z}} :- [tc.link.proj X T Z]) :- !, - const X = {{:gref Mem.elt}}. - }}. + Section X. + Parameter SN : set nat. + Elpi Trace Browser. + Time Check ((fun x => eq_refl _) : (forall (x : mem nat SN 0), Mem.elt _ SN _ = 0)). + End X. + (* checking valididy of built rule *) + Elpi Accumulate TC.Compiler lp:{{ :after "is-class-C" is-class-C (tc-mem Ty S T {{@Mem.memP lp:Ty lp:S lp:Z}} :- [tc.link.proj X T Z]) :- !, const X = {{:gref Mem.elt}}. }}. Existing Instance Mem.memP. - - (* Elpi Print TC.Compiler "elpi.apps.derive.tests/xxx". *) - + (* Goal forall SN, + mem nat SN 0 -> exists X, Mem.elt _ SN X = 0. + Proof. + intros SN I. + eexists. + (* eexists (Mem.Pack _ _ _ I). *) + apply eq_refl. *) End M3. (* from stdpp/definitions.v *) diff --git a/apps/tc/theories/tc.v b/apps/tc/theories/tc.v index 0d7cccbb1..2342b4f39 100644 --- a/apps/tc/theories/tc.v +++ b/apps/tc/theories/tc.v @@ -212,6 +212,9 @@ Elpi Accumulate File ho_compile. Elpi Accumulate File cs. Elpi Accumulate lp:{{ main L :- cs.main L. + + solve G _ :- + cs.solver.solve G. }}. Elpi Tactic solve_cs.