100 val (iTs', maxidx') = Type.unify (Sign.tsig_of sg) maxidx iTs (T, U) |
100 val (iTs', maxidx') = Type.unify (Sign.tsig_of sg) maxidx iTs (T, U) |
101 in Envir.Envir {asol=asol, iTs=iTs', maxidx=maxidx'} end |
101 in Envir.Envir {asol=asol, iTs=iTs', maxidx=maxidx'} end |
102 handle Type.TUNIFY => error ("Non-unifiable types:\n" ^ |
102 handle Type.TUNIFY => error ("Non-unifiable types:\n" ^ |
103 Sign.string_of_typ sg T ^ "\n\n" ^ Sign.string_of_typ sg U); |
103 Sign.string_of_typ sg T ^ "\n\n" ^ Sign.string_of_typ sg U); |
104 |
104 |
105 fun decompose sg env Ts |
105 fun decompose sg env Ts t u = case (Envir.head_norm env t, Envir.head_norm env u) of |
106 (Const ("all", _) $ t) (Const ("all", _) $ u) = decompose sg env Ts t u |
106 (Const ("all", _) $ t, Const ("all", _) $ u) => decompose sg env Ts t u |
107 | decompose sg env Ts |
107 | (Const ("==>", _) $ t1 $ t2, Const ("==>", _) $ u1 $ u2) => |
108 (Const ("==>", _) $ t1 $ t2) (Const ("==>", _) $ u1 $ u2) = |
|
109 let val (env', cs) = decompose sg env Ts t1 u1 |
108 let val (env', cs) = decompose sg env Ts t1 u1 |
110 in apsnd (curry op @ cs) (decompose sg env' Ts t2 u2) end |
109 in apsnd (curry op @ cs) (decompose sg env' Ts t2 u2) end |
111 | decompose sg env Ts (Abs (_, T, t)) (Abs (_, U, u)) = |
110 | (Abs (_, T, t), Abs (_, U, u)) => |
112 decompose sg (unifyT sg env T U) (T::Ts) t u |
111 decompose sg (unifyT sg env T U) (T::Ts) t u |
113 | decompose sg env Ts t u = (env, [(mk_abs Ts t, mk_abs Ts u)]); |
112 | (t, u) => (env, [(mk_abs Ts t, mk_abs Ts u)]); |
114 |
113 |
115 fun cantunify sg t u = error ("Non-unifiable terms:\n" ^ |
114 fun cantunify sg t u = error ("Non-unifiable terms:\n" ^ |
116 Sign.string_of_term sg t ^ "\n\n" ^ Sign.string_of_term sg u); |
115 Sign.string_of_term sg t ^ "\n\n" ^ Sign.string_of_term sg u); |
117 |
|
118 (*finds type of term without checking that combinations are consistent |
|
119 rbinder holds types of bound variables*) |
|
120 fun fastype (Envir.Envir {iTs, ...}) = |
|
121 let |
|
122 fun devar (T as TVar (ixn, _)) = (case Vartab.lookup (iTs, ixn) of |
|
123 None => T | Some U => devar U) |
|
124 | devar T = T; |
|
125 fun fast Ts (f $ u) = (case devar (fast Ts f) of |
|
126 Type("fun",[_,T]) => T |
|
127 | _ => raise TERM ("fastype: expected function type", [f $ u])) |
|
128 | fast Ts (Const (_, T)) = T |
|
129 | fast Ts (Free (_, T)) = T |
|
130 | fast Ts (Bound i) = |
|
131 (nth_elem (i, Ts) |
|
132 handle LIST _=> raise TERM("fastype: Bound", [Bound i])) |
|
133 | fast Ts (Var (_, T)) = T |
|
134 | fast Ts (Abs (_, T, u)) = T --> fast (T :: Ts) u |
|
135 in fast end; |
|
136 |
116 |
137 fun make_constraints_cprf sg env ts cprf = |
117 fun make_constraints_cprf sg env ts cprf = |
138 let |
118 let |
139 fun add_cnstrt Ts prop prf cs env ts (t, u) = |
119 fun add_cnstrt Ts prop prf cs env ts (t, u) = |
140 let |
120 let |
141 val t' = mk_abs Ts t; |
121 val t' = mk_abs Ts t; |
142 val u' = mk_abs Ts u; |
122 val u' = mk_abs Ts u |
143 val nt = Envir.beta_norm t'; |
|
144 val nu = Envir.beta_norm u' |
|
145 |
|
146 in |
123 in |
147 ((prop, prf, cs, Pattern.unify (sg, env, [(nt, nu)]), ts) |
124 (prop, prf, cs, Pattern.unify (sg, env, [(t', u')]), ts) |
148 handle Pattern.Pattern => |
125 handle Pattern.Pattern => |
149 let |
126 let val (env', cs') = decompose sg env [] t' u' |
150 val nt' = Envir.norm_term env nt; |
127 in (prop, prf, cs @ cs', env', ts) end |
151 val nu' = Envir.norm_term env nu |
128 | Pattern.Unif => |
152 in |
129 cantunify sg (Envir.norm_term env t') (Envir.norm_term env u') |
153 (prop, prf, cs, Pattern.unify (sg, env, [(nt', nu')]), ts) |
|
154 handle Pattern.Pattern => |
|
155 let val (env', cs') = decompose sg env [] nt' nu' |
|
156 in (prop, prf, cs @ cs', env', ts) end |
|
157 end) handle Pattern.Unif => |
|
158 cantunify sg (Envir.norm_term env t') (Envir.norm_term env u') |
|
159 end; |
130 end; |
160 |
131 |
161 fun mk_cnstrts_atom env ts prop opTs mk_prf = |
132 fun mk_cnstrts_atom env ts prop opTs mk_prf = |
162 let |
133 let |
163 val tvars = term_tvars prop; |
134 val tvars = term_tvars prop; |
200 | mk_cnstrts env Ts Hs (t::ts) (cprf % Some _) = |
171 | mk_cnstrts env Ts Hs (t::ts) (cprf % Some _) = |
201 let val t' = strip_abs Ts t |
172 let val t' = strip_abs Ts t |
202 in (case mk_cnstrts env Ts Hs ts cprf of |
173 in (case mk_cnstrts env Ts Hs ts cprf of |
203 (Const ("all", Type ("fun", [Type ("fun", [T, _]), _])) $ f, |
174 (Const ("all", Type ("fun", [Type ("fun", [T, _]), _])) $ f, |
204 prf, cnstrts, env', ts') => |
175 prf, cnstrts, env', ts') => |
205 let val env'' = unifyT sg env' T (fastype env' Ts t') |
176 let val env'' = unifyT sg env' T (Envir.fastype env' Ts t') |
206 in (betapply (f, t'), prf % Some t', cnstrts, env'', ts') |
177 in (betapply (f, t'), prf % Some t', cnstrts, env'', ts') |
207 end |
178 end |
208 | (u, prf, cnstrts, env', ts') => |
179 | (u, prf, cnstrts, env', ts') => |
209 let |
180 let |
210 val T = fastype env' Ts t'; |
181 val T = Envir.fastype env' Ts t'; |
211 val (env'', v) = mk_var env' Ts (T --> propT); |
182 val (env'', v) = mk_var env' Ts (T --> propT); |
212 in |
183 in |
213 add_cnstrt Ts (v $ t') (prf % Some t') cnstrts env'' ts' |
184 add_cnstrt Ts (v $ t') (prf % Some t') cnstrts env'' ts' |
214 (u, Const ("all", (T --> propT) --> propT) $ v) |
185 (u, Const ("all", (T --> propT) --> propT) $ v) |
215 end) |
186 end) |