184 |
184 |
185 |
185 |
186 fun unify_types thy TU env = |
186 fun unify_types thy TU env = |
187 Pattern.unify_types thy TU env handle Pattern.Unif => raise CANTUNIFY; |
187 Pattern.unify_types thy TU env handle Pattern.Unif => raise CANTUNIFY; |
188 |
188 |
189 fun unify_types_of thy (rbinder, t, u) env = |
|
190 unify_types thy (fastype env (rbinder, t), fastype env (rbinder, u)) env; |
|
191 |
|
192 fun test_unify_types thy (T, U) env = |
189 fun test_unify_types thy (T, U) env = |
193 let |
190 let |
194 val str_of = Syntax.string_of_typ_global thy; |
191 val str_of = Syntax.string_of_typ_global thy; |
195 fun warn () = tracing ("Potential loss of completeness: " ^ str_of U ^ " = " ^ str_of T); |
192 fun warn () = tracing ("Potential loss of completeness: " ^ str_of U ^ " = " ^ str_of T); |
196 val env' = unify_types thy (T, U) env; |
193 val env' = unify_types thy (T, U) env; |
197 in if is_TVar T orelse is_TVar U then warn () else (); env' end; |
194 in if is_TVar T orelse is_TVar U then warn () else (); env' end; |
198 |
195 |
199 (*Is the term eta-convertible to a single variable with the given rbinder? |
196 (*Is the term eta-convertible to a single variable with the given rbinder? |
200 Examples: ?a ?f(B.0) ?g(B.1,B.0) |
197 Examples: ?a ?f(B.0) ?g(B.1,B.0) |
201 Result is var a for use in SIMPL. *) |
198 Result is var a for use in SIMPL. *) |
202 fun get_eta_var [] n (Var vT) = (n, vT) |
199 fun get_eta_var ([], _, Var vT) = vT |
203 | get_eta_var (_ :: rbinder) n (f $ Bound i) = |
200 | get_eta_var (_::rbinder, n, f $ Bound i) = |
204 if n = i then get_eta_var rbinder (n + 1) f |
201 if n = i then get_eta_var (rbinder, n + 1, f) |
205 else raise ASSIGN |
202 else raise ASSIGN |
206 | get_eta_var _ _ _ = raise ASSIGN; |
203 | get_eta_var _ = raise ASSIGN; |
207 |
204 |
208 |
205 |
209 (*Solve v=u by assignment -- "fixedpoint" to Huet -- if v not in u. |
206 (*Solve v=u by assignment -- "fixedpoint" to Huet -- if v not in u. |
210 If v occurs rigidly then nonunifiable. |
207 If v occurs rigidly then nonunifiable. |
211 If v occurs nonrigidly then must use full algorithm. *) |
208 If v occurs nonrigidly then must use full algorithm. *) |
212 fun assignment thy (rbinder, t, u) env = |
209 fun assignment thy (rbinder, t, u) env = |
213 let val (n, (v, T)) = get_eta_var rbinder 0 t in |
210 let val vT as (v,T) = get_eta_var (rbinder, 0, t) in |
214 (case rigid_occurs_term (Unsynchronized.ref [], env, v, u) of |
211 (case rigid_occurs_term (Unsynchronized.ref [], env, v, u) of |
215 NoOcc => |
212 NoOcc => |
216 let val env = unify_types thy (Envir.body_type env n T, fastype env (rbinder, u)) env |
213 let val env = unify_types thy (Envir.body_type env ~1 T, fastype env (rbinder, u)) env |
217 in Envir.update ((v, T), Logic.rlist_abs (rbinder, u)) env end |
214 in Envir.update (vT, Logic.rlist_abs (rbinder, u)) env end |
218 | Nonrigid => raise ASSIGN |
215 | Nonrigid => raise ASSIGN |
219 | Rigid => raise CANTUNIFY) |
216 | Rigid => raise CANTUNIFY) |
220 end; |
217 end; |
221 |
218 |
222 |
219 |
223 (*Extends an rbinder with a new disagreement pair, if both are abstractions. |
220 (*Extends an rbinder with a new disagreement pair, if both are abstractions. |
|
221 Tries to unify types of the bound variables! |
224 Checks that binders have same length, since terms should be eta-normal; |
222 Checks that binders have same length, since terms should be eta-normal; |
225 if not, raises TERM, probably indicating type mismatch. |
223 if not, raises TERM, probably indicating type mismatch. |
226 Uses variable a (unless the null string) to preserve user's naming.*) |
224 Uses variable a (unless the null string) to preserve user's naming.*) |
227 fun new_dpair thy (rbinder, Abs (a, T, body1), Abs (b, U, body2)) env = |
225 fun new_dpair thy (rbinder, Abs (a, T, body1), Abs (b, U, body2)) env = |
228 let val c = if a = "" then b else a |
226 let |
229 in new_dpair thy ((c, T) :: rbinder, body1, body2) env end |
227 val env' = unify_types thy (T, U) env; |
|
228 val c = if a = "" then b else a; |
|
229 in new_dpair thy ((c,T) :: rbinder, body1, body2) env' end |
230 | new_dpair _ (_, Abs _, _) _ = raise TERM ("new_dpair", []) |
230 | new_dpair _ (_, Abs _, _) _ = raise TERM ("new_dpair", []) |
231 | new_dpair _ (_, _, Abs _) _ = raise TERM ("new_dpair", []) |
231 | new_dpair _ (_, _, Abs _) _ = raise TERM ("new_dpair", []) |
232 | new_dpair _ (rbinder, t1, t2) env = ((rbinder, t1, t2), env); |
232 | new_dpair _ (rbinder, t1, t2) env = ((rbinder, t1, t2), env); |
|
233 |
233 |
234 |
234 fun head_norm_dpair thy (env, (rbinder, t, u)) : dpair * Envir.env = |
235 fun head_norm_dpair thy (env, (rbinder, t, u)) : dpair * Envir.env = |
235 new_dpair thy (rbinder, |
236 new_dpair thy (rbinder, |
236 eta_norm env (rbinder, Envir.head_norm env t), |
237 eta_norm env (rbinder, Envir.head_norm env t), |
237 eta_norm env (rbinder, Envir.head_norm env u)) env; |
238 eta_norm env (rbinder, Envir.head_norm env u)) env; |
|
239 |
238 |
240 |
239 |
241 |
240 (*flexflex: the flex-flex pairs, flexrigid: the flex-rigid pairs |
242 (*flexflex: the flex-flex pairs, flexrigid: the flex-rigid pairs |
241 Does not perform assignments for flex-flex pairs: |
243 Does not perform assignments for flex-flex pairs: |
242 may create nonrigid paths, which prevent other assignments. |
244 may create nonrigid paths, which prevent other assignments. |
243 Does not even identify Vars in dpairs such as ?a =?= ?b; an attempt to |
245 Does not even identify Vars in dpairs such as ?a =?= ?b; an attempt to |
244 do so caused numerous problems with no compensating advantage. |
246 do so caused numerous problems with no compensating advantage. |
245 *) |
247 *) |
246 fun SIMPL0 thy dp0 (env,flexflex,flexrigid) : Envir.env * dpair list * dpair list = |
248 fun SIMPL0 thy dp0 (env,flexflex,flexrigid) : Envir.env * dpair list * dpair list = |
247 let |
249 let |
248 val (dp as (rbinder, t, u), env) = |
250 val (dp as (rbinder, t, u), env) = head_norm_dpair thy (env, dp0); |
249 head_norm_dpair thy (unify_types_of thy dp0 env, dp0); |
|
250 fun SIMRANDS (f $ t, g $ u, env) = |
251 fun SIMRANDS (f $ t, g $ u, env) = |
251 SIMPL0 thy (rbinder, t, u) (SIMRANDS (f, g, env)) |
252 SIMPL0 thy (rbinder, t, u) (SIMRANDS (f, g, env)) |
252 | SIMRANDS (t as _$_, _, _) = |
253 | SIMRANDS (t as _$_, _, _) = |
253 raise TERM ("SIMPL: operands mismatch", [t, u]) |
254 raise TERM ("SIMPL: operands mismatch", [t, u]) |
254 | SIMRANDS (t, u as _ $ _, _) = |
255 | SIMRANDS (t, u as _ $ _, _) = |
255 raise TERM ("SIMPL: operands mismatch", [t, u]) |
256 raise TERM ("SIMPL: operands mismatch", [t, u]) |
256 | SIMRANDS (_, _, env) = (env, flexflex, flexrigid); |
257 | SIMRANDS (_, _, env) = (env, flexflex, flexrigid); |
257 in |
258 in |
258 (case (head_of t, head_of u) of |
259 (case (head_of t, head_of u) of |
259 (Var (v, T), Var (w, U)) => |
260 (Var (_, T), Var (_, U)) => |
260 let val env' = if v = w then unify_types thy (T, U) env else env |
261 let |
261 in (env', dp :: flexflex, flexrigid) end |
262 val T' = Envir.body_type env ~1 T and U' = Envir.body_type env ~1 U; |
|
263 val env = unify_types thy (T', U') env; |
|
264 in (env, dp :: flexflex, flexrigid) end |
262 | (Var _, _) => |
265 | (Var _, _) => |
263 ((assignment thy (rbinder,t,u) env, flexflex, flexrigid) |
266 ((assignment thy (rbinder,t,u) env, flexflex, flexrigid) |
264 handle ASSIGN => (env, flexflex, dp :: flexrigid)) |
267 handle ASSIGN => (env, flexflex, dp :: flexrigid)) |
265 | (_, Var _) => |
268 | (_, Var _) => |
266 ((assignment thy (rbinder, u, t) env, flexflex, flexrigid) |
269 ((assignment thy (rbinder, u, t) env, flexflex, flexrigid) |