205 | hnorm (Abs (_, _, body) $ t) = |
205 | hnorm (Abs (_, _, body) $ t) = |
206 head_norm env (subst_bound (t, body)) |
206 head_norm env (subst_bound (t, body)) |
207 | hnorm (f $ t) = (case hnorm f of |
207 | hnorm (f $ t) = (case hnorm f of |
208 Abs (_, _, body) => head_norm env (subst_bound (t, body)) |
208 Abs (_, _, body) => head_norm env (subst_bound (t, body)) |
209 | nf => nf $ t) |
209 | nf => nf $ t) |
210 | hnorm _ = raise SAME |
210 | hnorm _ = raise SAME |
211 in hnorm t handle SAME => t end; |
211 in hnorm t handle SAME => t end; |
212 |
212 |
213 |
213 |
214 (*Eta-contract a term (fully)*) |
214 (*Eta-contract a term (fully)*) |
215 |
215 |
216 fun eta_contract t = |
216 fun eta_contract t = |
217 let |
217 let |
218 exception SAME; |
218 fun decr lev (Bound i) = if i >= lev then Bound (i - 1) else raise SAME |
|
219 | decr lev (Abs (a, T, body)) = Abs (a, T, decr (lev + 1) body) |
|
220 | decr lev (t $ u) = (decr lev t $ decrh lev u handle SAME => t $ decr lev u) |
|
221 | decr _ _ = raise SAME |
|
222 and decrh lev t = (decr lev t handle SAME => t); |
|
223 |
219 fun eta (Abs (a, T, body)) = |
224 fun eta (Abs (a, T, body)) = |
220 ((case eta body of |
225 ((case eta body of |
221 body' as (f $ Bound 0) => |
226 body' as (f $ Bound 0) => |
222 if loose_bvar1 (f, 0) then Abs(a, T, body') |
227 if loose_bvar1 (f, 0) then Abs (a, T, body') |
223 else incr_boundvars ~1 f |
228 else decrh 0 f |
224 | body' => Abs (a, T, body')) handle SAME => |
229 | body' => Abs (a, T, body')) handle SAME => |
225 (case body of |
230 (case body of |
226 (f $ Bound 0) => |
231 f $ Bound 0 => |
227 if loose_bvar1 (f, 0) then raise SAME |
232 if loose_bvar1 (f, 0) then raise SAME |
228 else incr_boundvars ~1 f |
233 else decrh 0 f |
229 | _ => raise SAME)) |
234 | _ => raise SAME)) |
230 | eta (f $ t) = |
235 | eta (t $ u) = (eta t $ etah u handle SAME => t $ eta u) |
231 (let val f' = eta f |
|
232 in f' $ etah t end handle SAME => f $ eta t) |
|
233 | eta _ = raise SAME |
236 | eta _ = raise SAME |
234 and etah t = (eta t handle SAME => t) |
237 and etah t = (eta t handle SAME => t); |
235 in etah t end; |
238 in etah t end; |
236 |
239 |
237 val beta_eta_contract = eta_contract o beta_norm; |
240 val beta_eta_contract = eta_contract o beta_norm; |
238 |
241 |
239 |
242 |
240 (*finds type of term without checking that combinations are consistent |
243 (*finds type of term without checking that combinations are consistent |
241 Ts holds types of bound variables*) |
244 Ts holds types of bound variables*) |
242 fun fastype (Envir {iTs, ...}) = |
245 fun fastype (Envir {iTs, ...}) = |
243 let val funerr = "fastype: expected function type"; |
246 let val funerr = "fastype: expected function type"; |
244 fun fast Ts (f $ u) = |
247 fun fast Ts (f $ u) = |
245 (case fast Ts f of |
248 (case fast Ts f of |
246 Type ("fun", [_, T]) => T |
249 Type ("fun", [_, T]) => T |
247 | TVar ixnS => |
250 | TVar ixnS => |
248 (case Type.lookup (iTs, ixnS) of |
251 (case Type.lookup (iTs, ixnS) of |
249 SOME (Type ("fun", [_, T])) => T |
252 SOME (Type ("fun", [_, T])) => T |
250 | _ => raise TERM (funerr, [f $ u])) |
253 | _ => raise TERM (funerr, [f $ u])) |
251 | _ => raise TERM (funerr, [f $ u])) |
254 | _ => raise TERM (funerr, [f $ u])) |
252 | fast Ts (Const (_, T)) = T |
255 | fast Ts (Const (_, T)) = T |
253 | fast Ts (Free (_, T)) = T |
256 | fast Ts (Free (_, T)) = T |
254 | fast Ts (Bound i) = |
257 | fast Ts (Bound i) = |
255 (List.nth (Ts, i) |
258 (List.nth (Ts, i) |
256 handle Subscript => raise TERM ("fastype: Bound", [Bound i])) |
259 handle Subscript => raise TERM ("fastype: Bound", [Bound i])) |
257 | fast Ts (Var (_, T)) = T |
260 | fast Ts (Var (_, T)) = T |
258 | fast Ts (Abs (_, T, u)) = T --> fast (T :: Ts) u |
261 | fast Ts (Abs (_, T, u)) = T --> fast (T :: Ts) u |
259 in fast end; |
262 in fast end; |
260 |
263 |
261 |
264 |
262 (*Substitute for type Vars in a type*) |
265 (*Substitute for type Vars in a type*) |