1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
|
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
(* $Id$ *)
open Util
open Names
open Term
open Reductionops
open Environ
open Typeops
open Pretype_errors
open Classops
open Recordops
open Evarutil
open Evarconv
open Retyping
open Evd
(* Typing operations dealing with coercions *)
let class_of1 env sigma t = class_of env sigma (nf_evar sigma t)
(* Here, funj is a coercion therefore already typed in global context *)
let apply_coercion_args env argl funj =
let rec apply_rec acc typ = function
| [] -> { uj_val = applist (j_val funj,argl);
uj_type = typ }
| h::restl ->
(* On devrait pouvoir s'arranger pour qu'on n'ait pas à faire hnf_constr *)
match kind_of_term (whd_betadeltaiota env Evd.empty typ) with
| Prod (_,c1,c2) ->
(* Typage garanti par l'appel à app_coercion*)
apply_rec (h::acc) (subst1 h c2) restl
| _ -> anomaly "apply_coercion_args"
in
apply_rec [] funj.uj_type argl
exception NoCoercion
(* appliquer le chemin de coercions de patterns p *)
let apply_pattern_coercion loc pat p =
List.fold_left
(fun pat (co,n) ->
let f i = if i<n then Rawterm.PatVar (loc, Anonymous) else pat in
Rawterm.PatCstr (loc, co, list_tabulate f (n+1), Anonymous))
pat p
(* raise Not_found if no coercion found *)
let inh_pattern_coerce_to loc pat ind1 ind2 =
let i1 = inductive_class_of ind1 in
let i2 = inductive_class_of ind2 in
let p = lookup_pattern_path_between (i1,i2) in
apply_pattern_coercion loc pat p
(* appliquer le chemin de coercions p à hj *)
let apply_coercion env p hj typ_cl =
try
fst (List.fold_left
(fun (ja,typ_cl) i ->
let fv,isid = coercion_value i in
let argl = (class_args_of typ_cl)@[ja.uj_val] in
let jres = apply_coercion_args env argl fv in
(if isid then
{ uj_val = ja.uj_val; uj_type = jres.uj_type }
else
jres),
jres.uj_type)
(hj,typ_cl) p)
with _ -> anomaly "apply_coercion"
let inh_app_fun env isevars j =
let t = whd_betadeltaiota env (evars_of isevars) j.uj_type in
match kind_of_term t with
| Prod (_,_,_) -> (isevars,j)
| Evar ev when not (is_defined_evar isevars ev) ->
let (isevars',t) = define_evar_as_arrow isevars ev in
(isevars',{ uj_val = j.uj_val; uj_type = t })
| _ ->
(try
let t,i1 = class_of1 env (evars_of isevars) j.uj_type in
let p = lookup_path_to_fun_from i1 in
(isevars,apply_coercion env p j t)
with Not_found -> (isevars,j))
let inh_tosort_force env isevars j =
try
let t,i1 = class_of1 env (evars_of isevars) j.uj_type in
let p = lookup_path_to_sort_from i1 in
apply_coercion env p j t
with Not_found ->
j
let inh_coerce_to_sort env isevars j =
let typ = whd_betadeltaiota env (evars_of isevars) j.uj_type in
match kind_of_term typ with
| Sort s -> (isevars,{ utj_val = j.uj_val; utj_type = s })
| Evar ev when not (is_defined_evar isevars ev) ->
let (isevars',s) = define_evar_as_sort isevars ev in
(isevars',{ utj_val = j.uj_val; utj_type = s })
| _ ->
let j1 = inh_tosort_force env isevars j in
(isevars,type_judgment env (j_nf_evar (evars_of isevars) j1))
let inh_coerce_to_fail env isevars c1 hj =
let hj' =
try
let t1,i1 = class_of1 env (evars_of isevars) c1 in
let t2,i2 = class_of1 env (evars_of isevars) hj.uj_type in
let p = lookup_path_between (i2,i1) in
apply_coercion env p hj t2
with Not_found -> raise NoCoercion
in
try (the_conv_x_leq env hj'.uj_type c1 isevars, hj')
with Reduction.NotConvertible -> raise NoCoercion
let rec inh_conv_coerce_to_fail env isevars hj c1 =
let {uj_val = v; uj_type = t} = hj in
try (the_conv_x_leq env t c1 isevars, hj)
with Reduction.NotConvertible ->
(try
inh_coerce_to_fail env isevars c1 hj
with NoCoercion ->
(match kind_of_term (whd_betadeltaiota env (evars_of isevars) t),
kind_of_term (whd_betadeltaiota env (evars_of isevars) c1) with
| Prod (_,t1,t2), Prod (name,u1,u2) ->
let v' = whd_betadeltaiota env (evars_of isevars) v in
let (evd',b) =
match kind_of_term v' with
| Lambda (_,v1,v2) ->
(try the_conv_x env v1 u1 isevars, true (* leq v1 u1? *)
with Reduction.NotConvertible -> (isevars, false))
| _ -> (isevars,false) in
if b
then
let (x,v1,v2) = destLambda v' in
let env1 = push_rel (x,None,v1) env in
let (evd'',h2) = inh_conv_coerce_to_fail env1 evd'
{uj_val = v2; uj_type = t2 } u2 in
(evd'',{ uj_val = mkLambda (x, v1, h2.uj_val);
uj_type = mkProd (x, v1, h2.uj_type) })
else
(* Mismatch on t1 and u1 or not a lambda: we eta-expand *)
(* we look for a coercion c:u1->t1 s.t. [name:u1](v' (c x)) *)
(* has type (name:u1)u2 (with v' recursively obtained) *)
let name = (match name with
| Anonymous -> Name (id_of_string "x")
| _ -> name) in
let env1 = push_rel (name,None,u1) env in
let (evd',h1) =
inh_conv_coerce_to_fail env1 isevars
{uj_val = mkRel 1; uj_type = (lift 1 u1) }
(lift 1 t1) in
let (evd'',h2) = inh_conv_coerce_to_fail env1 evd'
{ uj_val = mkApp (lift 1 v, [|h1.uj_val|]);
uj_type = subst1 h1.uj_val t2 }
u2
in
(evd'',
{ uj_val = mkLambda (name, u1, h2.uj_val);
uj_type = mkProd (name, u1, h2.uj_type) })
| _ -> raise NoCoercion))
(* Look for cj' obtained from cj by inserting coercions, s.t. cj'.typ = t *)
let inh_conv_coerce_to loc env isevars cj t =
let (evd',cj') =
try
inh_conv_coerce_to_fail env isevars cj t
with NoCoercion ->
let sigma = evars_of isevars in
error_actual_type_loc loc env sigma cj t
in
(evd',{ uj_val = cj'.uj_val; uj_type = t })
|
