128 val mx = (case vars of [] => NoSyn | [((x', _), mx)] => |
128 val mx = (case vars of [] => NoSyn | [((x', _), mx)] => |
129 if x = x' then mx |
129 if x = x' then mx |
130 else error ("Head of definition " ^ quote x ^ " differs from declaration " ^ quote x')); |
130 else error ("Head of definition " ^ quote x ^ " differs from declaration " ^ quote x')); |
131 val ((lhs, (_, th)), lthy2) = lthy1 |
131 val ((lhs, (_, th)), lthy2) = lthy1 |
132 (* |> LocalTheory.def ((x, mx), ((name ^ "_raw", []), rhs)); FIXME *) |
132 (* |> LocalTheory.def ((x, mx), ((name ^ "_raw", []), rhs)); FIXME *) |
133 |> LocalTheory.def ((x, mx), ((name, []), rhs)); |
133 |> LocalTheory.def Thm.definitionK ((x, mx), ((name, []), rhs)); |
134 val ((b, [th']), lthy3) = lthy2 |
134 val ((b, [th']), lthy3) = lthy2 |
135 |> LocalTheory.note ((name, atts), [prove lthy2 th]); |
135 |> LocalTheory.note Thm.definitionK ((name, atts), [prove lthy2 th]); |
136 in (((x, T), (lhs, (b, th'))), LocalTheory.restore lthy3) end; |
136 in (((x, T), (lhs, (b, th'))), LocalTheory.restore lthy3) end; |
137 |
137 |
138 val ((cs, defs), lthy') = lthy |> fold_map define args |>> split_list; |
138 val ((cs, defs), lthy') = lthy |> fold_map define args |>> split_list; |
139 val def_frees = member (op =) (fold (Term.add_frees o fst) defs []); |
139 val def_frees = member (op =) (fold (Term.add_frees o fst) defs []); |
140 val _ = print_consts lthy' def_frees cs; |
140 val _ = print_consts lthy' def_frees cs; |
183 |
183 |
184 (* fact statements *) |
184 (* fact statements *) |
185 |
185 |
186 fun gen_theorems prep_thms prep_att kind raw_facts lthy = |
186 fun gen_theorems prep_thms prep_att kind raw_facts lthy = |
187 let |
187 let |
188 val k = if kind = "" then [] else [Attrib.kind kind]; |
|
189 val attrib = prep_att (ProofContext.theory_of lthy); |
188 val attrib = prep_att (ProofContext.theory_of lthy); |
190 val facts = raw_facts |> map (fn ((name, atts), bs) => |
189 val facts = raw_facts |> map (fn ((name, atts), bs) => |
191 ((name, map attrib atts), |
190 ((name, map attrib atts), |
192 bs |> map (fn (b, more_atts) => (prep_thms lthy b, map attrib more_atts @ k)))); |
191 bs |> map (fn (b, more_atts) => (prep_thms lthy b, map attrib more_atts)))); |
193 val (res, lthy') = lthy |> LocalTheory.notes facts; |
192 val (res, lthy') = lthy |> LocalTheory.notes kind facts; |
194 val _ = present_results' lthy' kind res; |
193 val _ = present_results' lthy' kind res; |
195 in (res, lthy') end; |
194 in (res, lthy') end; |
196 |
195 |
197 val theorems = gen_theorems ProofContext.get_thms Attrib.intern_src; |
196 val theorems = gen_theorems ProofContext.get_thms Attrib.intern_src; |
198 val theorems_i = gen_theorems (K I) (K I); |
197 val theorems_i = gen_theorems (K I) (K I); |
244 val stmt = [(("", atts), [(thesis, [])])]; |
243 val stmt = [(("", atts), [(thesis, [])])]; |
245 |
244 |
246 val (facts, goal_ctxt) = elems_ctxt |
245 val (facts, goal_ctxt) = elems_ctxt |
247 |> (snd o ProofContext.add_fixes_i [(AutoBind.thesisN, NONE, NoSyn)]) |
246 |> (snd o ProofContext.add_fixes_i [(AutoBind.thesisN, NONE, NoSyn)]) |
248 |> fold_map assume_case (obtains ~~ propp) |
247 |> fold_map assume_case (obtains ~~ propp) |
249 |-> (fn ths => |
248 |-> (fn ths => ProofContext.note_thmss_i Thm.assumptionK |
250 ProofContext.note_thmss_i [((Obtain.thatN, []), [(ths, [])])] #> #2 #> pair ths); |
249 [((Obtain.thatN, []), [(ths, [])])] #> #2 #> pair ths); |
251 in ((stmt, facts), goal_ctxt) end); |
250 in ((stmt, facts), goal_ctxt) end); |
252 |
251 |
253 fun gen_theorem prep_att prep_stmt |
252 fun gen_theorem prep_att prep_stmt |
254 kind before_qed after_qed (name, raw_atts) raw_elems raw_concl lthy0 = |
253 kind before_qed after_qed (name, raw_atts) raw_elems raw_concl lthy0 = |
255 let |
254 let |
256 val _ = LocalTheory.assert lthy0; |
255 val _ = LocalTheory.assert lthy0; |
257 val thy = ProofContext.theory_of lthy0; |
256 val thy = ProofContext.theory_of lthy0; |
258 val attrib = prep_att thy; |
|
259 |
257 |
260 val (loc, ctxt, lthy) = |
258 val (loc, ctxt, lthy) = |
261 (case (TheoryTarget.peek lthy0, exists (fn Locale.Expr _ => true | _ => false) raw_elems) of |
259 (case (TheoryTarget.peek lthy0, exists (fn Locale.Expr _ => true | _ => false) raw_elems) of |
262 (SOME loc, true) => (* workaround non-modularity of in/includes *) (* FIXME *) |
260 (SOME loc, true) => (* workaround non-modularity of in/includes *) (* FIXME *) |
263 (SOME loc, ProofContext.init thy, LocalTheory.restore lthy0) |
261 (SOME loc, ProofContext.init thy, LocalTheory.restore lthy0) |
264 | _ => (NONE, lthy0, lthy0)); |
262 | _ => (NONE, lthy0, lthy0)); |
265 |
263 |
|
264 val attrib = prep_att thy; |
|
265 val atts = map attrib raw_atts; |
|
266 |
266 val elems = raw_elems |> (map o Locale.map_elem) |
267 val elems = raw_elems |> (map o Locale.map_elem) |
267 (Element.map_ctxt {name = I, var = I, typ = I, term = I, fact = I, attrib = attrib}); |
268 (Element.map_ctxt {name = I, var = I, typ = I, term = I, fact = I, attrib = attrib}); |
268 val ((stmt, facts), goal_ctxt) = prep_statement attrib (prep_stmt loc) elems raw_concl ctxt; |
269 val ((stmt, facts), goal_ctxt) = prep_statement attrib (prep_stmt loc) elems raw_concl ctxt; |
269 |
270 |
270 val k = if kind = "" then [] else [Attrib.kind kind]; |
|
271 val names = map (fst o fst) stmt; |
|
272 val attss = map (fn ((_, atts), _) => atts @ k) stmt; |
|
273 val atts = map attrib raw_atts @ k; |
|
274 |
|
275 fun after_qed' results goal_ctxt' = |
271 fun after_qed' results goal_ctxt' = |
276 let val results' = burrow (ProofContext.export_standard goal_ctxt' lthy) results in |
272 let val results' = burrow (ProofContext.export_standard goal_ctxt' lthy) results in |
277 lthy |
273 lthy |
278 |> LocalTheory.notes ((names ~~ attss) ~~ map (fn ths => [(ths, [])]) results') |
274 |> LocalTheory.notes kind (map2 (fn (a, _) => fn ths => (a, [(ths, [])])) stmt results') |
279 |> (fn (res, lthy') => |
275 |> (fn (res, lthy') => |
280 (present_results lthy' ((kind, name), res); |
276 (present_results lthy' ((kind, name), res); |
281 if name = "" andalso null raw_atts then lthy' |
277 if name = "" andalso null atts then lthy' |
282 else #2 (LocalTheory.notes [((name, atts), [(maps #2 res, [])])] lthy'))) |
278 else #2 (LocalTheory.notes kind [((name, atts), [(maps #2 res, [])])] lthy'))) |
283 |> after_qed results' |
279 |> after_qed results' |
284 end; |
280 end; |
285 in |
281 in |
286 goal_ctxt |
282 goal_ctxt |
287 |> Proof.theorem_i kind before_qed after_qed' (map snd stmt) |
283 |> Proof.theorem_i before_qed after_qed' (map snd stmt) |
288 |> Proof.refine_insert facts |
284 |> Proof.refine_insert facts |
289 end; |
285 end; |
290 |
286 |
291 in |
287 in |
292 |
288 |