55 val t' = f t; |
55 val t' = f t; |
56 in if t aconv t' then NONE else SOME (t, t') end; |
56 in if t aconv t' then NONE else SOME (t, t') end; |
57 |
57 |
58 in |
58 in |
59 |
59 |
60 fun read_termTs ctxt ss Ts = |
60 fun read_termTs ctxt schematic ss Ts = |
61 let |
61 let |
62 fun parse T = if T = propT then Syntax.parse_prop ctxt else Syntax.parse_term ctxt; |
62 fun parse T = if T = propT then Syntax.parse_prop ctxt else Syntax.parse_term ctxt; |
63 val ts = map2 parse Ts ss; |
63 val ts = map2 parse Ts ss; |
64 val ts' = |
64 val ts' = |
65 map2 (TypeInfer.constrain o TypeInfer.paramify_vars) Ts ts |
65 map2 (TypeInfer.constrain o TypeInfer.paramify_vars) Ts ts |
66 |> Syntax.check_terms (ProofContext.set_mode ProofContext.mode_schematic ctxt) (* FIXME !? *) |
66 |> Syntax.check_terms ((schematic ? ProofContext.set_mode ProofContext.mode_schematic) ctxt) |
67 |> Variable.polymorphic ctxt; |
67 |> Variable.polymorphic ctxt; |
68 val Ts' = map Term.fastype_of ts'; |
68 val Ts' = map Term.fastype_of ts'; |
69 val tyenv = fold Type.raw_match (Ts ~~ Ts') Vartab.empty; |
69 val tyenv = fold Type.raw_match (Ts ~~ Ts') Vartab.empty; |
70 in (ts', map (apsnd snd) (Vartab.dest tyenv)) end; |
70 in (ts', map (apsnd snd) (Vartab.dest tyenv)) end; |
71 |
71 |
115 |
115 |
116 (* external term instantiations *) |
116 (* external term instantiations *) |
117 |
117 |
118 val (xs, strs) = split_list external_insts; |
118 val (xs, strs) = split_list external_insts; |
119 val Ts = map (the_type vars2) xs; |
119 val Ts = map (the_type vars2) xs; |
120 val (ts, inferred) = read_termTs ctxt strs Ts; |
120 val (ts, inferred) = read_termTs ctxt true (* FIXME false *) strs Ts; |
121 |
121 |
122 val instT3 = Term.typ_subst_TVars inferred; |
122 val instT3 = Term.typ_subst_TVars inferred; |
123 val vars3 = map (apsnd instT3) vars2; |
123 val vars3 = map (apsnd instT3) vars2; |
124 val internal_insts3 = map (apsnd (map_types instT3)) internal_insts2; |
124 val internal_insts3 = map (apsnd (map_types instT3)) internal_insts2; |
125 val external_insts3 = xs ~~ ts; |
125 val external_insts3 = xs ~~ ts; |
234 (* Separate type and term insts *) |
234 (* Separate type and term insts *) |
235 fun has_type_var ((x, _), _) = (case Symbol.explode x of |
235 fun has_type_var ((x, _), _) = (case Symbol.explode x of |
236 "'"::cs => true | cs => false); |
236 "'"::cs => true | cs => false); |
237 val Tinsts = List.filter has_type_var insts; |
237 val Tinsts = List.filter has_type_var insts; |
238 val tinsts = filter_out has_type_var insts; |
238 val tinsts = filter_out has_type_var insts; |
|
239 |
239 (* Tactic *) |
240 (* Tactic *) |
240 fun tac i st = |
241 fun tac i st = |
241 let |
242 let |
242 (* Preprocess state: extract environment information: |
243 val (_, _, Bi, _) = Thm.dest_state (st, i); |
243 - variables and their types |
244 val params = Logic.strip_params Bi; (*params of subgoal i as string typ pairs*) |
244 - type variables and their sorts |
245 val params = rev (Term.rename_wrt_term Bi params) |
245 - parameters and their types *) |
246 (*as they are printed: bound variables with*) |
246 val (types, sorts) = types_sorts st; |
247 (*the same name are renamed during printing*) |
247 (* Process type insts: Tinsts_env *) |
248 |
248 fun absent xi = error |
249 val (param_names, ctxt') = ctxt |
249 ("No such variable in theorem: " ^ Term.string_of_vname xi); |
250 |> Variable.declare_thm thm |
250 val (rtypes, rsorts) = types_sorts thm; |
251 |> Thm.fold_terms Variable.declare_constraints st |
251 fun readT (xi, s) = |
252 |> ProofContext.add_fixes_i (map (fn (x, T) => (x, SOME T, NoSyn)) params); |
252 let val S = case rsorts xi of SOME S => S | NONE => absent xi; |
253 |
253 val T = Sign.read_def_typ (thy, sorts) s; |
254 (* Process type insts: Tinsts_env *) |
254 val U = TVar (xi, S); |
255 fun absent xi = error |
255 in if Sign.typ_instance thy (T, U) then (U, T) |
256 ("No such variable in theorem: " ^ Term.string_of_vname xi); |
256 else error ("Instantiation of " ^ Term.string_of_vname xi ^ " fails") |
257 val (rtypes, rsorts) = Drule.types_sorts thm; |
257 end; |
258 fun readT (xi, s) = |
258 val Tinsts_env = map readT Tinsts; |
259 let val S = case rsorts xi of SOME S => S | NONE => absent xi; |
259 (* Preprocess rule: extract vars and their types, apply Tinsts *) |
260 val T = Syntax.read_typ ctxt' s; |
260 fun get_typ xi = |
261 val U = TVar (xi, S); |
261 (case rtypes xi of |
262 in if Sign.typ_instance thy (T, U) then (U, T) |
262 SOME T => typ_subst_atomic Tinsts_env T |
263 else error ("Instantiation of " ^ Term.string_of_vname xi ^ " fails") |
263 | NONE => absent xi); |
264 end; |
264 val (xis, ss) = Library.split_list tinsts; |
265 val Tinsts_env = map readT Tinsts; |
265 val Ts = map get_typ xis; |
266 (* Preprocess rule: extract vars and their types, apply Tinsts *) |
266 val (_, _, Bi, _) = dest_state(st,i) |
267 fun get_typ xi = |
267 val params = Logic.strip_params Bi |
268 (case rtypes xi of |
268 (* params of subgoal i as string typ pairs *) |
269 SOME T => typ_subst_atomic Tinsts_env T |
269 val params = rev(Term.rename_wrt_term Bi params) |
270 | NONE => absent xi); |
270 (* as they are printed: bound variables with *) |
271 val (xis, ss) = Library.split_list tinsts; |
271 (* the same name are renamed during printing *) |
272 val Ts = map get_typ xis; |
272 fun types' (a, ~1) = (case AList.lookup (op =) params a of |
273 |
273 NONE => types (a, ~1) |
274 val (ts, envT) = read_termTs ctxt' true ss Ts; |
274 | some => some) |
|
275 | types' xi = types xi; |
|
276 fun internal x = is_some (types' (x, ~1)); |
|
277 val used = Drule.add_used thm (Drule.add_used st []); |
|
278 val (ts, envT) = |
|
279 ProofContext.read_termTs_schematic ctxt internal types' sorts used (ss ~~ Ts); |
|
280 val envT' = map (fn (ixn, T) => |
275 val envT' = map (fn (ixn, T) => |
281 (TVar (ixn, the (rsorts ixn)), T)) envT @ Tinsts_env; |
276 (TVar (ixn, the (rsorts ixn)), T)) envT @ Tinsts_env; |
282 val cenv = |
277 val cenv = |
283 map |
278 map |
284 (fn (xi, t) => |
279 (fn (xi, t) => |
292 and inc = maxidx+1 |
287 and inc = maxidx+1 |
293 fun liftvar (Var ((a,j), T)) = |
288 fun liftvar (Var ((a,j), T)) = |
294 Var((a, j+inc), paramTs ---> Logic.incr_tvar inc T) |
289 Var((a, j+inc), paramTs ---> Logic.incr_tvar inc T) |
295 | liftvar t = raise TERM("Variable expected", [t]); |
290 | liftvar t = raise TERM("Variable expected", [t]); |
296 fun liftterm t = list_abs_free |
291 fun liftterm t = list_abs_free |
297 (params, Logic.incr_indexes(paramTs,inc) t) |
292 (param_names ~~ paramTs, Logic.incr_indexes(paramTs,inc) t) |
298 fun liftpair (cv,ct) = |
293 fun liftpair (cv,ct) = |
299 (cterm_fun liftvar cv, cterm_fun liftterm ct) |
294 (cterm_fun liftvar cv, cterm_fun liftterm ct) |
300 val lifttvar = pairself (ctyp_of thy o Logic.incr_tvar inc); |
295 val lifttvar = pairself (ctyp_of thy o Logic.incr_tvar inc); |
301 val rule = Drule.instantiate |
296 val rule = Drule.instantiate |
302 (map lifttvar envT', map liftpair cenv) |
297 (map lifttvar envT', map liftpair cenv) |