33 |
33 |
34 |
34 |
35 (* attribute source *) |
35 (* attribute source *) |
36 |
36 |
37 val _ = Theory.setup |
37 val _ = Theory.setup |
38 (ML_Context.add_antiq @{binding attributes} |
38 (ML_Context.antiquotation @{binding attributes} (Scan.lift Parse_Spec.attribs) |
39 (Scan.depend (fn context => Parse_Spec.attribs >> (fn raw_srcs => |
39 (fn _ => fn raw_srcs => fn ctxt => |
40 let |
40 let |
41 val ctxt = Context.the_proof context; |
|
42 |
|
43 val i = serial (); |
41 val i = serial (); |
44 val srcs = map (Attrib.check_src ctxt) raw_srcs; |
42 val srcs = map (Attrib.check_src ctxt) raw_srcs; |
45 val _ = map (Attrib.attribute ctxt) srcs; |
43 val _ = map (Attrib.attribute ctxt) srcs; |
46 val (a, ctxt') = ctxt |
44 val (a, ctxt') = ctxt |
47 |> ML_Antiquote.variant "attributes" ||> put_attributes (i, srcs); |
45 |> ML_Antiquote.variant "attributes" ||> put_attributes (i, srcs); |
48 val ml = |
46 val ml = |
49 ("val " ^ a ^ " = ML_Thms.the_attributes ML_context " ^ |
47 ("val " ^ a ^ " = ML_Thms.the_attributes ML_context " ^ |
50 string_of_int i ^ ";\n", "Isabelle." ^ a); |
48 string_of_int i ^ ";\n", "Isabelle." ^ a); |
51 in (Context.Proof ctxt', K ml) end)))); |
49 in (K ml, ctxt') end)); |
52 |
50 |
53 |
51 |
54 (* fact references *) |
52 (* fact references *) |
55 |
53 |
56 fun thm_binding kind is_single context thms = |
54 fun thm_binding kind is_single thms ctxt = |
57 let |
55 let |
58 val ctxt = Context.the_proof context; |
|
59 |
|
60 val initial = null (get_thmss ctxt); |
56 val initial = null (get_thmss ctxt); |
61 val (name, ctxt') = ML_Antiquote.variant kind ctxt; |
57 val (name, ctxt') = ML_Antiquote.variant kind ctxt; |
62 val ctxt'' = cons_thms ((name, is_single), thms) ctxt'; |
58 val ctxt'' = cons_thms ((name, is_single), thms) ctxt'; |
63 |
59 |
64 val ml_body = "Isabelle." ^ name; |
60 val ml_body = "Isabelle." ^ name; |
67 let |
63 let |
68 val binds = get_thmss final_ctxt |> map (fn ((a, b), _) => (b ? enclose "[" "]") a); |
64 val binds = get_thmss final_ctxt |> map (fn ((a, b), _) => (b ? enclose "[" "]") a); |
69 val ml_env = "val [" ^ commas binds ^ "] = ML_Thms.the_thmss ML_context;\n"; |
65 val ml_env = "val [" ^ commas binds ^ "] = ML_Thms.the_thmss ML_context;\n"; |
70 in (ml_env, ml_body) end |
66 in (ml_env, ml_body) end |
71 else ("", ml_body); |
67 else ("", ml_body); |
72 in (Context.Proof ctxt'', decl) end; |
68 in (decl, ctxt'') end; |
73 |
69 |
74 val _ = Theory.setup |
70 val _ = Theory.setup |
75 (ML_Context.add_antiq @{binding thm} |
71 (ML_Context.antiquotation @{binding thm} (Attrib.thm >> single) (K (thm_binding "thm" true)) #> |
76 (Scan.depend (fn context => |
72 ML_Context.antiquotation @{binding thms} Attrib.thms (K (thm_binding "thms" false))); |
77 Scan.pass context Attrib.thm >> (thm_binding "thm" true context o single))) #> |
|
78 ML_Context.add_antiq @{binding thms} |
|
79 (Scan.depend (fn context => |
|
80 Scan.pass context Attrib.thms >> thm_binding "thms" false context))); |
|
81 |
73 |
82 |
74 |
83 (* ad-hoc goals *) |
75 (* ad-hoc goals *) |
84 |
76 |
85 val and_ = Args.$$$ "and"; |
77 val and_ = Args.$$$ "and"; |
86 val by = Args.$$$ "by"; |
78 val by = Args.$$$ "by"; |
87 val goal = Scan.unless (by || and_) Args.name_inner_syntax; |
79 val goal = Scan.unless (by || and_) Args.name_inner_syntax; |
88 |
80 |
89 val _ = Theory.setup |
81 val _ = Theory.setup |
90 (ML_Context.add_antiq @{binding lemma} |
82 (ML_Context.antiquotation @{binding lemma} |
91 (Scan.depend (fn context => |
83 (Scan.lift (Args.mode "open" -- Parse.enum1 "and" (Scan.repeat1 goal) -- |
92 Args.mode "open" -- Parse.enum1 "and" (Scan.repeat1 goal) -- |
84 (by |-- Method.parse -- Scan.option Method.parse))) |
93 (by |-- Method.parse -- Scan.option Method.parse) |
85 (fn _ => fn ((is_open, raw_propss), (m1, m2)) => fn ctxt => |
94 >> (fn ((is_open, raw_propss), (m1, m2)) => |
86 let |
95 let |
87 val _ = Context_Position.reports ctxt (maps Method.reports_of (m1 :: the_list m2)); |
96 val ctxt = Context.proof_of context; |
|
97 |
88 |
98 val _ = Context_Position.reports ctxt (maps Method.reports_of (m1 :: the_list m2)); |
89 val propss = burrow (map (rpair []) o Syntax.read_props ctxt) raw_propss; |
|
90 val prep_result = Goal.norm_result ctxt #> not is_open ? Thm.close_derivation; |
|
91 fun after_qed res goal_ctxt = |
|
92 Proof_Context.put_thms false (Auto_Bind.thisN, |
|
93 SOME (map prep_result (Proof_Context.export goal_ctxt ctxt (flat res)))) goal_ctxt; |
99 |
94 |
100 val propss = burrow (map (rpair []) o Syntax.read_props ctxt) raw_propss; |
95 val ctxt' = ctxt |
101 val prep_result = Goal.norm_result ctxt #> not is_open ? Thm.close_derivation; |
96 |> Proof.theorem NONE after_qed propss |
102 fun after_qed res goal_ctxt = |
97 |> Proof.global_terminal_proof (m1, m2); |
103 Proof_Context.put_thms false (Auto_Bind.thisN, |
98 val thms = |
104 SOME (map prep_result (Proof_Context.export goal_ctxt ctxt (flat res)))) goal_ctxt; |
99 Proof_Context.get_fact ctxt' |
105 |
100 (Facts.named (Proof_Context.full_name ctxt' (Binding.name Auto_Bind.thisN))); |
106 val ctxt' = ctxt |
101 in thm_binding "lemma" (length (flat propss) = 1) thms ctxt end)); |
107 |> Proof.theorem NONE after_qed propss |
|
108 |> Proof.global_terminal_proof (m1, m2); |
|
109 val thms = |
|
110 Proof_Context.get_fact ctxt' |
|
111 (Facts.named (Proof_Context.full_name ctxt' (Binding.name Auto_Bind.thisN))); |
|
112 in thm_binding "lemma" (length (flat propss) = 1) context thms end)))); |
|
113 |
102 |
114 end; |
103 end; |
115 |
104 |