Skip to content

Commit a8897b0

Browse files
FissoreDFissoreD
committed
[TC] link small refactor
1 parent 638a947 commit a8897b0

File tree

1 file changed

+38
-30
lines changed

1 file changed

+38
-30
lines changed

‎apps/tc/elpi/link.elpi‎

Lines changed: 38 additions & 30 deletions
Original file line numberDiff line numberDiff line change
@@ -17,17 +17,17 @@ namespace tc {
1717
% [build-eta-llam-links.aux LHS Scope Ty Names PF NPF OldLinks NewVar NewLinks]
1818
:index(_ _ _ _ 3)
1919
pred build-eta-llam-links.aux i:term, i:list term, o:term, i:list term, i:list term, i:list term, i:list prop, o:term, o:list prop.
20+
build-eta-llam-links.aux _ _ _ _ [] [] _ _ _ :-coq.error "MH?".
2021
build-eta-llam-links.aux LHS _ _ Names [] NPF OL HD [llam T (app [LHS | NPF]) | OL] :- !,
21-
std.assert! (not (NPF = [])) "[TC] NPF List should not be empty",
22-
prune T Names,
23-
var T HD _.
22+
prune T Names, var T HD _.
2423
build-eta-llam-links.aux LHS SC (prod _ Ty _) _ [X] [] OL HD [eta LHS (fun `_` Ty (x\ V x)) | OL] :- !,
2524
prune V SC, var (V X) HD _.
2625
build-eta-llam-links.aux LHS SC (prod _ Ty Bo) Names [X|XS] NPF OL HD [eta LHS (fun `_` Ty (x\ LHS' x)) | L] :- !,
27-
% TODO: unfold Ty if needed...
2826
std.append SC [X] SC',
2927
prune LHS' SC, build-eta-llam-links.aux (LHS' X) SC' (Bo X) Names XS NPF OL HD L.
3028
build-eta-llam-links.aux LHS SC Ty Names ([_|_] as PF) NPF OL HD L :-
29+
% Ty is expected to be of (forall x, ...), however, this can be hidden
30+
% under a definition to be unfolded. The unify-eq below is to perform the unfold
3131
Ty' = prod _ _ _, coq.unify-eq Ty Ty' ok, !,
3232
build-eta-llam-links.aux LHS SC Ty' Names PF NPF OL HD L.
3333

@@ -73,22 +73,23 @@ namespace tc {
7373
:index (_ _ 1)
7474
pred may-contract-to i:list term, i:term, i:term.
7575
may-contract-to _ N N :- name N, !.
76-
may-contract-to L N V :- var V _ S, !,
76+
may-contract-to L N (uvar _ S) :- !,
7777
std.forall [N|L] (x\ exists! S (may-contract-to [] x)).
7878
may-contract-to L N (app [N|A]) :-
7979
std.length A {std.length L},
8080
std.forall2 {std.rev L} A (may-contract-to []).
8181
may-contract-to L N (fun _ _ B) :-
8282
pi x\ may-contract-to [x|L] N (B x).
8383

84+
:index (_ 1)
8485
pred occurs-rigidly i:term, i:term.
8586
occurs-rigidly N N :- name N, !.
86-
occurs-rigidly _ V :- var V, !, fail.
87+
occurs-rigidly _ (uvar _) :- !, fail.
8788
occurs-rigidly N (app A) :- exists! A (occurs-rigidly N).
8889
occurs-rigidly N (fun _ _ B) :- pi x\ occurs-rigidly N (B x).
8990

9091
pred maybe-eta-aux i:term, i:list term.
91-
maybe-eta-aux V L :- var V _ S, std.forall L (std.mem! S).
92+
maybe-eta-aux (uvar _ S) L :- std.forall L (std.mem! S).
9293
maybe-eta-aux (app [_|A]) L :-
9394
SplitLen is {std.length A} - {std.length L},
9495
split-at-not-fatal SplitLen A HD TL,
@@ -106,7 +107,7 @@ namespace tc {
106107
unify-left-right A A' :- A = A'.
107108

108109
pred progress-eta-left i:term, o:term.
109-
progress-eta-left A _ :- var A, !, fail.
110+
progress-eta-left (uvar _) _ :- !, fail.
110111
progress-eta-left (fun _ _ A) (fun _ _ A).
111112
progress-eta-left A A' :- (name A; is-coq-term A), !, eta-expand A A'.
112113

@@ -118,12 +119,6 @@ namespace tc {
118119
pred scope-check i:term, i:term.
119120
scope-check (uvar _ L) T :- prune A L, A = T, !.
120121

121-
pred collect-store o:list prop.
122-
pred collect-store-aux i:list prop, o:list prop.
123-
124-
collect-store L :- collect-store-aux [] L.
125-
collect-store-aux X L :- declare_constraint (collect-store-aux X L) [_].
126-
127122
pred unify-eta i:term, i:term.
128123
% unify-eta A B :- coq.say "Unify-eta" "A"A"B"B, fail.
129124
unify-eta (uvar _ _ as A) B :- !, A = B, !.
@@ -132,33 +127,39 @@ namespace tc {
132127
unify-eta A B :- A = B.
133128

134129
constraint eta solve-eta {
135-
rule solve-eta \ (eta A B) <=> (unify-eta A B).
130+
rule solve-eta \ (eta A B _) <=> (unify-eta A B).
136131
rule \ solve-eta.
137132
% If two eta links have same lhs they rhs should unify
138-
rule (N1 : G1 ?- eta (uvar X L1) (fun _ T1 B1))
139-
\ (N2 : G2 ?- eta (uvar X L2) (fun _ T2 B2))
140-
| (pi x\ relocate L1 L2 (B2 x) (B2' x))
133+
rule (N1 : G1 ?- eta (uvar X L1) (fun _ T1 B1) _)
134+
\ (N2 : G2 ?- eta (uvar X L2) (fun _ T2 B2) _)
135+
| (pi x\ relocate L1 L2 (B2 x) (B2' x))
141136
<=> (N1 : G1 ?- B1 = B2').
142137
}
143138

144-
pred eta i:term, i:term.
145-
eta _ B :- var B, coq.error "[TC] link.eta error, flexible rhs".
146-
eta A (fun _ _ B as T) :- not (var A), not (var B), !, unify-left-right A T.
147-
eta A B :- progress-eta-right B B', !, A = B'.
148-
eta A B :- progress-eta-left A A', !, A' = B.
149-
eta A B :- scope-check A B, get-vars B Vars, declare_constraint (eta A B) [_,A|Vars].
139+
:index (0 1)
140+
pred eta i:term, i:term, i:list term.
141+
eta _ uvar _ :- coq.error "[TC] link.eta error, flexible rhs".
142+
eta A (fun _ _ B as T) _ :- not (var A), not (var B), !, unify-left-right A T.
143+
eta A B _ :- progress-eta-right B B', !, A = B'.
144+
eta A B _ :- progress-eta-left A A', !, A' = B.
145+
eta (uvar _ as A) B Vars :-
146+
scope-check A B, std.filter Vars (x\ var x) Vars',
147+
declare_constraint (eta A B Vars') [_,A|Vars'].
150148
}
151149

152150
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
153151
% LLAM LINK %
154152
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
155153
namespace llam {
154+
% A llam link is suspended on its lhs and the head of its rhs
155+
% Note: to avoid not pf elpi variable, the coq term `app[A, x, t]` where
156+
% A is a uvar, x a name and t a term, is represented with the llam rhs:
157+
% app[A' x, t] instead of (A' x t).
156158
pred llam i:term, i:term.
157159
llam A (uvar _ S as T) :- distinct_names S, !, A = T.
158-
llam A (app [H|L] as T) :- var A, var H, !, get-vars T Vars,
159-
declare_constraint (llam A (app [H|L])) [_,A|Vars].
160-
llam (fun _ _ _ as F) (app [H | TL]) :-
161-
var H _ Scope, !,
160+
llam (uvar _ as A) (app [(uvar HD _)|_] as T) :- !,
161+
declare_constraint (llam A T) [_,A,HD].
162+
llam (fun _ _ _ as F) (app [(uvar _ Scope as H) | TL]) :- !,
162163
std.drop-last 1 TL TL',
163164
H = fun _ _Ty (x\ Bo'), % TODO give a valid _Ty: should be: (Ty of dropped -> Ty of F)
164165
prune H' Scope,
@@ -177,6 +178,9 @@ namespace tc {
177178
}
178179
}
179180

181+
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
182+
% CS LINK %
183+
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
180184
namespace cs {
181185
pred reduce-cs i:term, i:term, i:term, i:constant.
182186
reduce-cs V (app [ProjT, T]) Record Proj :-
@@ -216,8 +220,12 @@ namespace tc {
216220
}
217221
}
218222

219-
pred eta i:term, o:term.
220-
eta A B :- eta.eta A B.
223+
% The last argument contain the list of vars on which the link is
224+
% suspended. In order to avoid a call to get-vars if the link is to be
225+
% re-suspended, we explicetely pass this list once when the link is
226+
% created
227+
pred eta i:term, i:term.
228+
eta A B :- !, get-vars B V, eta.eta A B [A|V].
221229

222230
pred solve-eta.
223231
solve-eta :- declare_constraint solve-eta [_].

0 commit comments

Comments
 (0)