6 since they may change the identity of a variable. |
6 since they may change the identity of a variable. |
7 *) |
7 *) |
8 |
8 |
9 signature ENVIR = |
9 signature ENVIR = |
10 sig |
10 sig |
11 type tenv |
11 type tenv = (typ * term) Vartab.table |
12 datatype env = Envir of {asol: tenv, iTs: Type.tyenv, maxidx: int} |
12 datatype env = Envir of {asol: tenv, iTs: Type.tyenv, maxidx: int} |
13 val type_env: env -> Type.tyenv |
13 val type_env: env -> Type.tyenv |
14 val insert_sorts: env -> sort list -> sort list |
14 val insert_sorts: env -> sort list -> sort list |
15 exception SAME |
|
16 val genvars: string -> env * typ list -> env * term list |
15 val genvars: string -> env * typ list -> env * term list |
17 val genvar: string -> env * typ -> env * term |
16 val genvar: string -> env * typ -> env * term |
18 val lookup: env * (indexname * typ) -> term option |
17 val lookup: env * (indexname * typ) -> term option |
19 val lookup': tenv * (indexname * typ) -> term option |
18 val lookup': tenv * (indexname * typ) -> term option |
20 val update: ((indexname * typ) * term) * env -> env |
19 val update: ((indexname * typ) * term) * env -> env |
21 val empty: int -> env |
20 val empty: int -> env |
22 val is_empty: env -> bool |
21 val is_empty: env -> bool |
23 val above: env -> int -> bool |
22 val above: env -> int -> bool |
24 val vupdate: ((indexname * typ) * term) * env -> env |
23 val vupdate: ((indexname * typ) * term) * env -> env |
25 val alist_of: env -> (indexname * (typ * term)) list |
24 val alist_of: env -> (indexname * (typ * term)) list |
|
25 val norm_type_same: Type.tyenv -> typ Same.operation |
|
26 val norm_types_same: Type.tyenv -> typ list Same.operation |
|
27 val norm_type: Type.tyenv -> typ -> typ |
|
28 val norm_term_same: env -> term Same.operation |
26 val norm_term: env -> term -> term |
29 val norm_term: env -> term -> term |
27 val norm_term_same: env -> term -> term |
|
28 val norm_type: Type.tyenv -> typ -> typ |
|
29 val norm_type_same: Type.tyenv -> typ -> typ |
|
30 val norm_types_same: Type.tyenv -> typ list -> typ list |
|
31 val beta_norm: term -> term |
30 val beta_norm: term -> term |
32 val head_norm: env -> term -> term |
31 val head_norm: env -> term -> term |
33 val eta_contract: term -> term |
32 val eta_contract: term -> term |
34 val beta_eta_contract: term -> term |
33 val beta_eta_contract: term -> term |
35 val fastype: env -> typ list -> term -> typ |
34 val fastype: env -> typ list -> term -> typ |
46 struct |
45 struct |
47 |
46 |
48 (*updating can destroy environment in 2 ways!! |
47 (*updating can destroy environment in 2 ways!! |
49 (1) variables out of range (2) circular assignments |
48 (1) variables out of range (2) circular assignments |
50 *) |
49 *) |
51 type tenv = (typ * term) Vartab.table |
50 type tenv = (typ * term) Vartab.table; |
52 |
51 |
53 datatype env = Envir of |
52 datatype env = Envir of |
54 {maxidx: int, (*maximum index of vars*) |
53 {maxidx: int, (*maximum index of vars*) |
55 asol: tenv, (*table of assignments to Vars*) |
54 asol: tenv, (*assignments to Vars*) |
56 iTs: Type.tyenv} (*table of assignments to TVars*) |
55 iTs: Type.tyenv}; (*assignments to TVars*) |
57 |
56 |
58 fun type_env (Envir {iTs, ...}) = iTs; |
57 fun type_env (Envir {iTs, ...}) = iTs; |
59 |
58 |
60 (*NB: type unification may invent new sorts*) |
59 (*NB: type unification may invent new sorts*) |
61 val insert_sorts = Vartab.fold (fn (_, (_, T)) => Sorts.insert_typ T) o type_env; |
60 val insert_sorts = Vartab.fold (fn (_, (_, T)) => Sorts.insert_typ T) o type_env; |
62 |
61 |
63 (*Generate a list of distinct variables. |
62 (*Generate a list of distinct variables. |
64 Increments index to make them distinct from ALL present variables. *) |
63 Increments index to make them distinct from ALL present variables. *) |
65 fun genvars name (Envir{maxidx, asol, iTs}, Ts) : env * term list = |
64 fun genvars name (Envir{maxidx, asol, iTs}, Ts) : env * term list = |
66 let fun genvs (_, [] : typ list) : term list = [] |
65 let |
67 | genvs (n, [T]) = [ Var((name, maxidx+1), T) ] |
66 fun genvs (_, [] : typ list) : term list = [] |
68 | genvs (n, T::Ts) = |
67 | genvs (n, [T]) = [Var ((name, maxidx + 1), T)] |
69 Var((name ^ radixstring(26,"a",n), maxidx+1), T) |
68 | genvs (n, T :: Ts) = |
70 :: genvs(n+1,Ts) |
69 Var ((name ^ radixstring (26, "a" , n), maxidx + 1), T) |
71 in (Envir{maxidx=maxidx+1, asol=asol, iTs=iTs}, genvs (0,Ts)) end; |
70 :: genvs (n + 1, Ts); |
|
71 in (Envir {maxidx = maxidx + 1, asol = asol, iTs = iTs}, genvs (0, Ts)) end; |
72 |
72 |
73 (*Generate a variable.*) |
73 (*Generate a variable.*) |
74 fun genvar name (env,T) : env * term = |
74 fun genvar name (env, T) : env * term = |
75 let val (env',[v]) = genvars name (env,[T]) |
75 let val (env', [v]) = genvars name (env, [T]) |
76 in (env',v) end; |
76 in (env', v) end; |
77 |
77 |
78 fun var_clash ixn T T' = raise TYPE ("Variable " ^ |
78 fun var_clash ixn T T' = raise TYPE ("Variable " ^ |
79 quote (Term.string_of_vname ixn) ^ " has two distinct types", |
79 quote (Term.string_of_vname ixn) ^ " has two distinct types", |
80 [T', T], []); |
80 [T', T], []); |
81 |
81 |
82 fun gen_lookup f asol (xname, T) = |
82 fun gen_lookup f asol (xname, T) = |
83 (case Vartab.lookup asol xname of |
83 (case Vartab.lookup asol xname of |
84 NONE => NONE |
84 NONE => NONE |
85 | SOME (U, t) => if f (T, U) then SOME t |
85 | SOME (U, t) => if f (T, U) then SOME t else var_clash xname T U); |
86 else var_clash xname T U); |
|
87 |
86 |
88 (* When dealing with environments produced by matching instead *) |
87 (* When dealing with environments produced by matching instead *) |
89 (* of unification, there is no need to chase assigned TVars. *) |
88 (* of unification, there is no need to chase assigned TVars. *) |
90 (* In this case, we can simply ignore the type substitution *) |
89 (* In this case, we can simply ignore the type substitution *) |
91 (* and use = instead of eq_type. *) |
90 (* and use = instead of eq_type. *) |
130 |
129 |
131 (*** Beta normal form for terms (not eta normal form). |
130 (*** Beta normal form for terms (not eta normal form). |
132 Chases variables in env; Does not exploit sharing of variable bindings |
131 Chases variables in env; Does not exploit sharing of variable bindings |
133 Does not check types, so could loop. ***) |
132 Does not check types, so could loop. ***) |
134 |
133 |
135 (*raised when norm has no effect on a term, to do sharing instead of copying*) |
134 local |
136 exception SAME; |
135 |
137 |
136 fun norm_type0 iTs : typ Same.operation = |
138 fun norm_term1 same (asol,t) : term = |
137 let |
139 let fun norm (Var wT) = |
138 fun norm (Type (a, Ts)) = Type (a, Same.map norm Ts) |
140 (case lookup' (asol, wT) of |
139 | norm (TFree _) = raise Same.SAME |
141 SOME u => (norm u handle SAME => u) |
140 | norm (TVar v) = |
142 | NONE => raise SAME) |
141 (case Type.lookup iTs v of |
143 | norm (Abs(a,T,body)) = Abs(a, T, norm body) |
142 SOME U => Same.commit norm U |
144 | norm (Abs(_,_,body) $ t) = normh(subst_bound (t, body)) |
143 | NONE => raise Same.SAME); |
145 | norm (f $ t) = |
144 in norm end; |
146 ((case norm f of |
145 |
147 Abs(_,_,body) => normh(subst_bound (t, body)) |
146 fun norm_term1 asol : term Same.operation = |
148 | nf => nf $ (norm t handle SAME => t)) |
147 let |
149 handle SAME => f $ norm t) |
148 fun norm (Var v) = |
150 | norm _ = raise SAME |
149 (case lookup' (asol, v) of |
151 and normh t = norm t handle SAME => t |
150 SOME u => Same.commit norm u |
152 in (if same then norm else normh) t end |
151 | NONE => raise Same.SAME) |
153 |
152 | norm (Abs (a, T, body)) = Abs (a, T, norm body) |
154 fun normT iTs (Type (a, Ts)) = Type (a, normTs iTs Ts) |
153 | norm (Abs (_, _, body) $ t) = Same.commit norm (subst_bound (t, body)) |
155 | normT iTs (TFree _) = raise SAME |
154 | norm (f $ t) = |
156 | normT iTs (TVar vS) = (case Type.lookup iTs vS of |
155 ((case norm f of |
157 SOME U => normTh iTs U |
156 Abs (_, _, body) => Same.commit norm (subst_bound (t, body)) |
158 | NONE => raise SAME) |
157 | nf => nf $ Same.commit norm t) |
159 and normTh iTs T = ((normT iTs T) handle SAME => T) |
158 handle Same.SAME => f $ norm t) |
160 and normTs iTs [] = raise SAME |
159 | norm _ = raise Same.SAME; |
161 | normTs iTs (T :: Ts) = |
160 in norm end; |
162 ((normT iTs T :: (normTs iTs Ts handle SAME => Ts)) |
161 |
163 handle SAME => T :: normTs iTs Ts); |
162 fun norm_term2 asol iTs : term Same.operation = |
164 |
163 let |
165 fun norm_term2 same (asol, iTs, t) : term = |
164 val normT = norm_type0 iTs; |
166 let fun norm (Const (a, T)) = Const(a, normT iTs T) |
165 fun norm (Const (a, T)) = Const (a, normT T) |
167 | norm (Free (a, T)) = Free(a, normT iTs T) |
166 | norm (Free (a, T)) = Free (a, normT T) |
168 | norm (Var (w, T)) = |
167 | norm (Var (xi, T)) = |
169 (case lookup2 (iTs, asol) (w, T) of |
168 (case lookup2 (iTs, asol) (xi, T) of |
170 SOME u => normh u |
169 SOME u => Same.commit norm u |
171 | NONE => Var(w, normT iTs T)) |
170 | NONE => Var (xi, normT T)) |
172 | norm (Abs (a, T, body)) = |
171 | norm (Abs (a, T, body)) = |
173 (Abs (a, normT iTs T, normh body) handle SAME => Abs (a, T, norm body)) |
172 (Abs (a, normT T, Same.commit norm body) |
174 | norm (Abs(_, _, body) $ t) = normh (subst_bound (t, body)) |
173 handle Same.SAME => Abs (a, T, norm body)) |
175 | norm (f $ t) = |
174 | norm (Abs (_, _, body) $ t) = Same.commit norm (subst_bound (t, body)) |
176 ((case norm f of |
175 | norm (f $ t) = |
177 Abs(_, _, body) => normh (subst_bound (t, body)) |
176 ((case norm f of |
178 | nf => nf $ normh t) |
177 Abs (_, _, body) => Same.commit norm (subst_bound (t, body)) |
179 handle SAME => f $ norm t) |
178 | nf => nf $ Same.commit norm t) |
180 | norm _ = raise SAME |
179 handle Same.SAME => f $ norm t) |
181 and normh t = (norm t) handle SAME => t |
180 | norm _ = raise Same.SAME; |
182 in (if same then norm else normh) t end; |
181 in norm end; |
183 |
182 |
184 fun gen_norm_term same (env as Envir{asol,iTs,...}) t : term = |
183 in |
185 if Vartab.is_empty iTs then norm_term1 same (asol, t) |
184 |
186 else norm_term2 same (asol, iTs, t); |
185 fun norm_type_same iTs T = |
187 |
186 if Vartab.is_empty iTs then raise Same.SAME |
188 val norm_term = gen_norm_term false; |
187 else norm_type0 iTs T; |
189 val norm_term_same = gen_norm_term true; |
188 |
190 |
189 fun norm_types_same iTs Ts = |
|
190 if Vartab.is_empty iTs then raise Same.SAME |
|
191 else Same.map (norm_type0 iTs) Ts; |
|
192 |
|
193 fun norm_type iTs T = norm_type_same iTs T handle Same.SAME => T; |
|
194 |
|
195 fun norm_term_same (Envir {asol, iTs, ...}) = |
|
196 if Vartab.is_empty iTs then norm_term1 asol |
|
197 else norm_term2 asol iTs; |
|
198 |
|
199 fun norm_term envir t = norm_term_same envir t handle Same.SAME => t; |
191 fun beta_norm t = if Term.has_abs t then norm_term (empty 0) t else t; |
200 fun beta_norm t = if Term.has_abs t then norm_term (empty 0) t else t; |
192 |
201 |
193 fun norm_type iTs = normTh iTs; |
202 end; |
194 fun norm_type_same iTs = |
|
195 if Vartab.is_empty iTs then raise SAME else normT iTs; |
|
196 |
|
197 fun norm_types_same iTs = |
|
198 if Vartab.is_empty iTs then raise SAME else normTs iTs; |
|
199 |
203 |
200 |
204 |
201 (*Put a term into head normal form for unification.*) |
205 (*Put a term into head normal form for unification.*) |
202 |
206 |
203 fun head_norm env t = |
207 fun head_norm env = |
204 let |
208 let |
205 fun hnorm (Var vT) = (case lookup (env, vT) of |
209 fun norm (Var v) = |
|
210 (case lookup (env, v) of |
206 SOME u => head_norm env u |
211 SOME u => head_norm env u |
207 | NONE => raise SAME) |
212 | NONE => raise Same.SAME) |
208 | hnorm (Abs (a, T, body)) = Abs (a, T, hnorm body) |
213 | norm (Abs (a, T, body)) = Abs (a, T, norm body) |
209 | hnorm (Abs (_, _, body) $ t) = |
214 | norm (Abs (_, _, body) $ t) = Same.commit norm (subst_bound (t, body)) |
210 head_norm env (subst_bound (t, body)) |
215 | norm (f $ t) = |
211 | hnorm (f $ t) = (case hnorm f of |
216 (case norm f of |
212 Abs (_, _, body) => head_norm env (subst_bound (t, body)) |
217 Abs (_, _, body) => Same.commit norm (subst_bound (t, body)) |
213 | nf => nf $ t) |
218 | nf => nf $ t) |
214 | hnorm _ = raise SAME |
219 | norm _ = raise Same.SAME; |
215 in hnorm t handle SAME => t end; |
220 in Same.commit norm end; |
216 |
221 |
217 |
222 |
218 (*Eta-contract a term (fully)*) |
223 (*Eta-contract a term (fully)*) |
219 |
224 |
220 local |
225 local |
221 |
226 |
222 fun decr lev (Bound i) = if i >= lev then Bound (i - 1) else raise SAME |
227 fun decr lev (Bound i) = if i >= lev then Bound (i - 1) else raise Same.SAME |
223 | decr lev (Abs (a, T, body)) = Abs (a, T, decr (lev + 1) body) |
228 | decr lev (Abs (a, T, body)) = Abs (a, T, decr (lev + 1) body) |
224 | decr lev (t $ u) = (decr lev t $ decrh lev u handle SAME => t $ decr lev u) |
229 | decr lev (t $ u) = (decr lev t $ decrh lev u handle Same.SAME => t $ decr lev u) |
225 | decr _ _ = raise SAME |
230 | decr _ _ = raise Same.SAME |
226 and decrh lev t = (decr lev t handle SAME => t); |
231 and decrh lev t = (decr lev t handle Same.SAME => t); |
227 |
232 |
228 fun eta (Abs (a, T, body)) = |
233 fun eta (Abs (a, T, body)) = |
229 ((case eta body of |
234 ((case eta body of |
230 body' as (f $ Bound 0) => |
235 body' as (f $ Bound 0) => |
231 if loose_bvar1 (f, 0) then Abs (a, T, body') |
236 if loose_bvar1 (f, 0) then Abs (a, T, body') |
232 else decrh 0 f |
237 else decrh 0 f |
233 | body' => Abs (a, T, body')) handle SAME => |
238 | body' => Abs (a, T, body')) handle Same.SAME => |
234 (case body of |
239 (case body of |
235 f $ Bound 0 => |
240 f $ Bound 0 => |
236 if loose_bvar1 (f, 0) then raise SAME |
241 if loose_bvar1 (f, 0) then raise Same.SAME |
237 else decrh 0 f |
242 else decrh 0 f |
238 | _ => raise SAME)) |
243 | _ => raise Same.SAME)) |
239 | eta (t $ u) = (eta t $ etah u handle SAME => t $ eta u) |
244 | eta (t $ u) = (eta t $ Same.commit eta u handle Same.SAME => t $ eta u) |
240 | eta _ = raise SAME |
245 | eta _ = raise Same.SAME; |
241 and etah t = (eta t handle SAME => t); |
|
242 |
246 |
243 in |
247 in |
244 |
248 |
245 fun eta_contract t = |
249 fun eta_contract t = |
246 if Term.has_abs t then etah t else t; |
250 if Term.has_abs t then Same.commit eta t else t; |
247 |
251 |
248 val beta_eta_contract = eta_contract o beta_norm; |
252 val beta_eta_contract = eta_contract o beta_norm; |
249 |
253 |
250 end; |
254 end; |
251 |
255 |