4
4
5
5
namespace derive.eqType.ast {
6
6
7
- pred translate-indt i:inductive, o:eqType, o:diagnostic.
7
+ pred translate-indt i:inductive, o:eqb. eqType, o:diagnostic.
8
8
translate-indt I O D :-
9
9
coq.env.indt-decl I Decl,
10
10
coq.env.indt I _ _ _ _ KN _,
11
11
translate-param Decl I KN O D.
12
12
13
- pred translate-param i:indt-decl, i:inductive, i:list constructor, o:eqType, o:diagnostic.
14
- translate-param (parameter ID _ Ty F) I KS (type-param F1) D :- whd Ty [] {{ Type }} _, !,
13
+ pred translate-param i:indt-decl, i:inductive, i:list constructor, o:eqb. eqType, o:diagnostic.
14
+ translate-param (parameter ID _ Ty F) I KS (eqb. type-param F1) D :- whd Ty [] {{ Type }} _, !,
15
15
@pi-parameter ID Ty x\ pi y\ term->trm x y ok => translate-param (F x) I KS (F1 y) D.
16
- translate-param (parameter ID _ Ty F) I KS (value-param Ty1 F1) D :- term->trm Ty Ty1 ok, !,
16
+ translate-param (parameter ID _ Ty F) I KS (eqb. value-param Ty1 F1) D :- term->trm Ty Ty1 ok, !,
17
17
@pi-parameter ID Ty x\ pi y\ term->trm x y ok => translate-param (F x) I KS (F1 y) D.
18
18
translate-param (parameter ID _ _ _) _ _ _ (error S) :- S is "unsupported parameter " ^ ID.
19
19
20
- translate-param (inductive ID tt (arity (sort S)) F) I KS (inductive I F1) D :-
20
+ translate-param (inductive ID tt (arity (sort S)) F) I KS (eqb. inductive I F1) D :-
21
21
@pi-inductive ID (arity (sort S)) x\ pi y\ term->trm x y ok => translate-constructors (F x) KS (F1 y) D.
22
- translate-param (record _ _ _ F) I [K] (inductive I (y\ [constructor K (F1 y)])) D :- !,
22
+ translate-param (record _ _ _ F) I [K] (eqb. inductive I (y\ [eqb. constructor K (F1 y)])) D :- !,
23
23
pi y\ self y => translate-record-constructor F (F1 y) D.
24
24
translate-param _ _ _ _ (error S) :- S is "unsupported inductive arity".
25
25
26
- pred translate-constructors i:list indc-decl, i:list constructor, o:list constructor, o:diagnostic.
26
+ pred translate-constructors i:list indc-decl, i:list constructor, o:list eqb. constructor, o:diagnostic.
27
27
translate-constructors [] [] [] ok.
28
- translate-constructors [constructor _ A|KS] [K|KK] [constructor K Args|KS1] D :- std.do-ok! D [
28
+ translate-constructors [constructor _ A|KS] [K|KK] [eqb. constructor K Args|KS1] D :- std.do-ok! D [
29
29
translate-arguments {coq.arity->term A} Args,
30
30
translate-constructors KS KK KS1,
31
31
].
32
32
33
- pred translate-arguments i:term, o:arguments, o:diagnostic.
33
+ pred translate-arguments i:term, o:eqb. arguments, o:diagnostic.
34
34
translate-arguments T T2 D :- whd1 T T1, !, translate-arguments T1 T2 D.
35
- translate-arguments (prod N Ty F) (irrelevant Ty1 F1) D :- not(pi x\ occurs x (F x)), irrelevant? Ty Ty1 ok, !,
35
+ translate-arguments (prod N Ty F) (eqb. irrelevant Ty1 F1) D :- not(pi x\ occurs x (F x)), irrelevant? Ty Ty1 ok, !,
36
36
@pi-decl N Ty x\ translate-arguments (F x) F1 D.
37
- translate-arguments (prod N Ty F) (regular Ty1 F1) D :- not(pi x\ occurs x (F x)), !, std.do-ok! D [
37
+ translate-arguments (prod N Ty F) (eqb. regular Ty1 F1) D :- not(pi x\ occurs x (F x)), !, std.do-ok! D [
38
38
term->trm Ty Ty1,
39
39
(d\ @pi-decl N Ty x\ translate-arguments (F x) F1 d),
40
40
].
41
- translate-arguments (prod N Ty F) (dependent Ty1 F1) D :- !, std.do-ok! D [
41
+ translate-arguments (prod N Ty F) (eqb. dependent Ty1 F1) D :- !, std.do-ok! D [
42
42
term->trm Ty Ty1,
43
43
(d\ @pi-decl N Ty x\ pi y\ term->trm x y ok => translate-arguments (F x) (F1 y) d),
44
44
].
45
- translate-arguments Ty (stop Ty1) D :- name Ty, term->trm Ty Ty1 D.
46
- translate-arguments (app [N|_] as Ty) (stop Ty1) D :- name N, term->trm Ty Ty1 D.
45
+ translate-arguments Ty (eqb. stop Ty1) D :- name Ty, term->trm Ty Ty1 D.
46
+ translate-arguments (app [N|_] as Ty) (eqb. stop Ty1) D :- name N, term->trm Ty Ty1 D.
47
47
translate-arguments T _ (error S) :- S is "unsupported argument " ^ {coq.term->string T}.
48
48
49
- pred translate-record-constructor i:record-decl, o:arguments, o:diagnostic.
50
- translate-record-constructor end-record (stop X) ok :- self X.
51
- translate-record-constructor (field _ ID Ty F) (irrelevant Ty1 F1) D :- not(pi x\ occurs x (F x)), irrelevant? Ty Ty1 ok, !,
49
+ pred translate-record-constructor i:record-decl, o:eqb. arguments, o:diagnostic.
50
+ translate-record-constructor end-record (eqb. stop X) ok :- self X.
51
+ translate-record-constructor (field _ ID Ty F) (eqb. irrelevant Ty1 F1) D :- not(pi x\ occurs x (F x)), irrelevant? Ty Ty1 ok, !,
52
52
@pi-parameter ID Ty x\ translate-record-constructor (F x) F1 D.
53
- translate-record-constructor (field _ ID Ty F) (regular Ty1 F1) D :- not(pi x\ occurs x (F x)), !, std.do-ok! D [
53
+ translate-record-constructor (field _ ID Ty F) (eqb. regular Ty1 F1) D :- not(pi x\ occurs x (F x)), !, std.do-ok! D [
54
54
term->trm Ty Ty1,
55
55
(d\ @pi-parameter ID Ty x\ translate-record-constructor (F x) F1 d),
56
56
].
57
- translate-record-constructor (field _ ID Ty F) (dependent Ty1 F1) D :- !, std.do-ok! D [
57
+ translate-record-constructor (field _ ID Ty F) (eqb. dependent Ty1 F1) D :- !, std.do-ok! D [
58
58
term->trm Ty Ty1,
59
59
(d\ @pi-parameter ID Ty x\ pi y\ term->trm x y ok => translate-record-constructor (F x) (F1 y) d),
60
60
].
61
61
translate-record-constructor (field _ ID _ _) _ (error S) :- S is "unsupported record field " ^ ID.
62
62
63
- pred self o:trm.
63
+ pred self o:eqb. trm.
64
64
65
- pred valid i:trm, o:diagnostic.
66
- valid {{ PrimInt63.int }} ok :- !.
67
- valid (global (indt I)) ok :- eqType I _, !.
68
- valid (app (indt I) A Args) D :- eqType I EQT, !, valid-eqType EQT [A|Args] D.
65
+ pred valid i:eqb. trm, o:diagnostic.
66
+ valid (eqb.global X) ok :- global X = {{ PrimInt63.int }}, !.
67
+ valid (eqb. global (indt I)) ok :- eqType I _, !.
68
+ valid (eqb. app (indt I) A Args) D :- eqType I EQT, !, valid-eqType EQT [A|Args] D.
69
69
valid T (error S) :- S is "not an eqType: " ^ {std.any->string T}.
70
70
71
- pred valid-eqType i:eqType, i:list trm, o:diagnostic.
72
- valid-eqType (inductive _ _) [] ok.
73
- valid-eqType (type-param F) [T|TS] D :- std.do-ok! D [
71
+ pred valid-eqType i:eqb. eqType, i:list eqb. trm, o:diagnostic.
72
+ valid-eqType (eqb. inductive _ _) [] ok.
73
+ valid-eqType (eqb. type-param F) [T|TS] D :- std.do-ok! D [
74
74
valid T,
75
75
(d\ pi x\ valid-eqType (F x) TS d),
76
76
].
77
- valid-eqType (value-param _ F) [_|TS] D :- std.do-ok! D [
77
+ valid-eqType (eqb. value-param _ F) [_|TS] D :- std.do-ok! D [
78
78
(d\ pi x\ valid-eqType (F x) TS d),
79
79
].
80
80
81
- pred irrelevant? i:term, o:trm, o:diagnostic.
82
- irrelevant? (app [{{ @eq }}, global (indt EqType), A, B]) (app EQ EQTYPE [A1,B1]) D :- std.do-ok! D [
81
+ pred irrelevant? i:term, o:eqb. trm, o:diagnostic.
82
+ irrelevant? (app [{{ @eq }}, global (indt EqType), A, B]) (eqb. app EQ EQTYPE [A1,B1]) D :- std.do-ok! D [
83
83
std.lift-ok (eqType EqType _) "Not an eqType", %eqb-for Bool Bool _,
84
84
std.lift-ok ({{ @eq }} = global EQ) "",
85
85
term->trm (global (indt EqType)) EQTYPE,
@@ -88,17 +88,17 @@ irrelevant? (app [{{ @eq }}, global (indt EqType), A, B]) (app EQ EQTYPE [A1,B1]
88
88
].
89
89
irrelevant? T R D :- whd1 T T1, coq.say "whd" T T1, irrelevant? T1 R D.
90
90
91
- pred term->trm i:term, o:trm, o:diagnostic.
92
- term->trm (global GR) (global GR) ok :- !.
93
- term->trm (app [global GRF,A|As]) (app GRF A1 As1) D :- !, std.do-ok! D [
91
+ pred term->trm i:term, o:eqb. trm, o:diagnostic.
92
+ term->trm (global GR) (eqb. global GR) ok :- !.
93
+ term->trm (app [global GRF,A|As]) (eqb. app GRF A1 As1) D :- !, std.do-ok! D [
94
94
term->trm A A1,
95
95
map-ok! As term->trm As1,
96
96
].
97
- term->trm {{ lp:A -> lp:B }} (app {{:gref lib:elpi.derive.arrow }} A1 [B1]) D :- std.do-ok! D [
97
+ term->trm {{ lp:A -> lp:B }} (eqb. app {{:gref lib:elpi.derive.arrow }} A1 [B1]) D :- std.do-ok! D [
98
98
term->trm A A1,
99
99
term->trm B B1,
100
100
].
101
- term->trm (app [N|As]) (app {{:gref lib:elpi.derive.apply }} N1 As1) D :- name N, !, std.do-ok! D [
101
+ term->trm (app [N|As]) (eqb. app {{:gref lib:elpi.derive.apply }} N1 As1) D :- name N, !, std.do-ok! D [
102
102
term->trm N N1,
103
103
map-ok! As term->trm As1,
104
104
].
@@ -108,28 +108,28 @@ pred map-ok! i:list A, i:(A -> B -> diagnostic -> prop), o:list B, o:diagnostic.
108
108
map-ok! [] _ [] ok.
109
109
map-ok! [X|XS] F [Y|YS] D :- F X Y D1, if (D1 = ok) (map-ok! XS F YS D) (D = D1).
110
110
111
- pred validate-eqType i:eqType, o:diagnostic.
112
- validate-eqType (type-param F) D :- pi x\ valid x ok => validate-eqType (F x) D.
113
- validate-eqType (value-param _ F) D :-
111
+ pred validate-eqType i:eqb. eqType, o:diagnostic.
112
+ validate-eqType (eqb. type-param F) D :- pi x\ valid x ok => validate-eqType (F x) D.
113
+ validate-eqType (eqb. value-param _ F) D :-
114
114
pi x\ validate-eqType (F x) D.
115
- validate-eqType (inductive _ F) D :-
115
+ validate-eqType (eqb. inductive _ F) D :-
116
116
pi x\ valid x ok => validate-constructors (F x) D.
117
117
118
- pred validate-constructors i:list constructor, o:diagnostic.
118
+ pred validate-constructors i:list eqb. constructor, o:diagnostic.
119
119
validate-constructors [] ok.
120
- validate-constructors [constructor _ Args|Ks] D :- std.do-ok! D [
120
+ validate-constructors [eqb. constructor _ Args|Ks] D :- std.do-ok! D [
121
121
validate-arguments Args,
122
122
validate-constructors Ks
123
123
].
124
124
125
- pred validate-arguments i:arguments, o:diagnostic.
126
- validate-arguments (stop _) ok.
127
- validate-arguments (regular T Args) D :- std.do-ok! D [
125
+ pred validate-arguments i:eqb. arguments, o:diagnostic.
126
+ validate-arguments (eqb. stop _) ok.
127
+ validate-arguments (eqb. regular T Args) D :- std.do-ok! D [
128
128
valid T,
129
129
validate-arguments Args,
130
130
].
131
- validate-arguments (irrelevant _ Args) D :- validate-arguments Args D.
132
- validate-arguments (dependent T Args) D :- std.do-ok! D [
131
+ validate-arguments (eqb. irrelevant _ Args) D :- validate-arguments Args D.
132
+ validate-arguments (eqb. dependent T Args) D :- std.do-ok! D [
133
133
valid T,
134
134
(d\ pi x\ validate-arguments (Args x) d),
135
135
].
@@ -145,9 +145,9 @@ main I [C] :-
145
145
146
146
namespace feqb {
147
147
148
- pred trm->term i:trm, o:term.
149
- trm->term (global GR) (global GR) :- !.
150
- trm->term (app GR A AS) (app[global GR,A1|AS1]) :- !,
148
+ pred trm->term i:eqb. trm, o:term.
149
+ trm->term (eqb. global GR) (global GR) :- !.
150
+ trm->term (eqb. app GR A AS) (app[global GR,A1|AS1]) :- !,
151
151
trm->term A A1,
152
152
std.map AS trm->term AS1.
153
153
trm->term T _ :- coq.error "cannot translate trm" T "to term, did you forget to assume feqb.trm->term ?".
0 commit comments