56 |
56 |
57 (* consts *) |
57 (* consts *) |
58 |
58 |
59 fun consts loc depends decls lthy = |
59 fun consts loc depends decls lthy = |
60 let |
60 let |
61 val xs = filter depends (#1 (ProofContext.inferred_fixes lthy)); |
61 val is_loc = loc <> ""; |
62 val ys = filter (Variable.newly_fixed lthy (LocalTheory.target_of lthy) o #1) xs; |
62 val xs = filter depends (#1 (ProofContext.inferred_fixes (LocalTheory.target_of lthy))); |
63 |
63 |
64 fun const ((c, T), mx) thy = |
64 fun const ((c, T), mx) thy = |
65 let |
65 let |
66 val U = map #2 xs ---> T; |
66 val U = map #2 xs ---> T; |
67 val mx' = if null ys then mx else NoSyn; |
|
68 val mx'' = Syntax.unlocalize_mixfix (loc <> "") mx'; |
|
69 |
|
70 val t = Term.list_comb (Const (Sign.full_name thy c, U), map Free xs); |
67 val t = Term.list_comb (Const (Sign.full_name thy c, U), map Free xs); |
71 val defn = ((c, if loc <> "" then mx else NoSyn (* FIXME !? *)), (("", []), t)); |
68 val thy' = Sign.add_consts_authentic [(c, U, Syntax.unlocalize_mixfix is_loc mx)] thy; |
72 val abbr = ((c, mx'), fold_rev (lambda o Free) ys t); |
69 in (((c, mx), t), thy') end; |
73 val thy' = Sign.add_consts_authentic [(c, U, mx'')] thy; |
70 |
74 in ((defn, abbr), thy') end; |
71 val (abbrs, lthy') = lthy |> LocalTheory.theory_result (fold_map const decls); |
75 |
72 val defs = abbrs |> map (fn (x, t) => (x, (("", []), t))); |
76 val ((defns, abbrs), lthy') = lthy |
|
77 |> LocalTheory.theory_result (fold_map const decls) |>> split_list; |
|
78 in |
73 in |
79 lthy' |
74 lthy' |
80 |> K (loc <> "") ? (snd o LocalTheory.abbrevs Syntax.default_mode abbrs) |
75 |> K is_loc ? LocalTheory.abbrevs Syntax.default_mode abbrs |
81 |> ProofContext.set_stmt true |
76 |> LocalDefs.add_defs defs |>> map (apsnd snd) |
82 |> LocalDefs.add_defs defns |>> map (apsnd snd) |
|
83 ||> ProofContext.restore_stmt lthy' |
|
84 end; |
77 end; |
85 |
78 |
86 |
79 |
87 (* axioms *) |
80 (* axioms *) |
88 |
81 |
125 |
118 |
126 fun expand_defs lthy = |
119 fun expand_defs lthy = |
127 Drule.term_rule (ProofContext.theory_of lthy) |
120 Drule.term_rule (ProofContext.theory_of lthy) |
128 (Assumption.export false lthy (LocalTheory.target_of lthy)); |
121 (Assumption.export false lthy (LocalTheory.target_of lthy)); |
129 |
122 |
|
123 infix also; |
|
124 fun eq1 also eq2 = Thm.transitive eq1 eq2; |
|
125 |
130 in |
126 in |
131 |
127 |
132 fun defs kind args lthy = |
128 fun defs kind args lthy = |
133 let |
129 let |
134 fun def ((x, mx), ((name, atts), rhs)) lthy1 = |
130 fun def ((c, mx), ((name, atts), rhs)) lthy1 = |
135 let |
131 let |
136 val name' = Thm.def_name_optional x name; |
132 val name' = Thm.def_name_optional c name; |
137 val T = Term.fastype_of rhs; |
133 val T = Term.fastype_of rhs; |
|
134 |
138 val rhs' = expand_defs lthy1 rhs; |
135 val rhs' = expand_defs lthy1 rhs; |
139 val depends = member (op =) (Term.add_frees rhs' []); |
136 val depends = member (op =) (Term.add_frees rhs' []); |
140 val defined = filter_out depends (Term.add_frees rhs []); |
137 val defined = filter_out depends (Term.add_frees rhs []); |
141 |
138 |
|
139 val ([(lhs, local_def)], lthy2) = lthy1 |
|
140 |> LocalTheory.consts depends [((c, T), mx)]; |
|
141 val lhs' = #2 (Logic.dest_equals (Thm.prop_of local_def)); |
|
142 |
142 val rhs_conv = rhs |
143 val rhs_conv = rhs |
143 |> Thm.cterm_of (ProofContext.theory_of lthy1) |
144 |> Thm.cterm_of (ProofContext.theory_of lthy1) |
144 |> Tactic.rewrite true (map_filter (LocalDefs.find_def lthy1 o #1) defined); |
145 |> Tactic.rewrite true (map_filter (LocalDefs.find_def lthy1 o #1) defined); |
145 |
146 |
146 val ([(lhs, local_def)], lthy2) = lthy1 |
|
147 |> LocalTheory.consts depends [((x, T), mx)]; |
|
148 val lhs' = #2 (Logic.dest_equals (Thm.prop_of local_def)); |
|
149 |
|
150 val (global_def, lthy3) = lthy2 |
147 val (global_def, lthy3) = lthy2 |
151 |> LocalTheory.theory_result (add_def (name', Logic.mk_equals (lhs', rhs'))); |
148 |> LocalTheory.theory_result (add_def (name', Logic.mk_equals (lhs', rhs'))); |
152 |
149 |
153 val eq = Thm.transitive (Thm.transitive local_def global_def) (Thm.symmetric rhs_conv); |
150 val eq = |
|
151 local_def (*c == loc.c xs*) |
|
152 also global_def (*... == rhs'*) |
|
153 also Thm.symmetric rhs_conv; (*... == rhs*) |
154 in ((lhs, ((name', atts), [([eq], [])])), lthy3) end; |
154 in ((lhs, ((name', atts), [([eq], [])])), lthy3) end; |
155 |
155 |
156 val ((lhss, facts), lthy') = lthy |> fold_map def args |>> split_list; |
156 val ((lhss, facts), lthy') = lthy |> fold_map def args |>> split_list; |
157 val (res, lthy'') = lthy' |> LocalTheory.notes kind facts; |
157 val (res, lthy'') = lthy' |> LocalTheory.notes kind facts; |
158 in (lhss ~~ map (apsnd the_single) res, lthy'') end; |
158 in (lhss ~~ map (apsnd the_single) res, lthy'') end; |
194 fun notes "" kind facts = theory_notes true kind facts #> context_notes kind facts |
194 fun notes "" kind facts = theory_notes true kind facts #> context_notes kind facts |
195 | notes loc kind facts = theory_notes false kind facts #> |
195 | notes loc kind facts = theory_notes false kind facts #> |
196 locale_notes loc kind facts #> context_notes kind facts; |
196 locale_notes loc kind facts #> context_notes kind facts; |
197 |
197 |
198 |
198 |
199 (* declarations *) |
199 (* target declarations *) |
200 |
200 |
201 (* FIXME proper morphisms *) |
201 fun decl _ "" f = |
202 fun decl _ "" f = LocalTheory.theory (Context.theory_map (f Morphism.identity)) |
202 LocalTheory.theory (Context.theory_map (f Morphism.identity)) #> |
203 | decl add loc f = LocalTheory.target (add loc (Context.proof_map o f)); |
203 LocalTheory.target (Context.proof_map (f Morphism.identity)) |
|
204 | decl add loc f = |
|
205 LocalTheory.target (add loc (Context.proof_map o f)); |
204 |
206 |
205 val type_syntax = decl Locale.add_type_syntax; |
207 val type_syntax = decl Locale.add_type_syntax; |
206 val term_syntax = decl Locale.add_term_syntax; |
208 val term_syntax = decl Locale.add_term_syntax; |
207 val declaration = decl Locale.add_declaration; |
209 val declaration = decl Locale.add_declaration; |
208 |
210 |
|
211 fun target_morphism loc lthy = |
|
212 ProofContext.export_standard_morphism lthy (LocalTheory.target_of lthy) $> |
|
213 Morphism.name_morphism (NameSpace.qualified loc); |
|
214 |
|
215 fun target_name "" lthy = Sign.full_name (ProofContext.theory_of lthy) |
|
216 | target_name _ lthy = ProofContext.full_name (LocalTheory.target_of lthy); |
|
217 |
209 |
218 |
210 (* init and exit *) |
219 (* init and exit *) |
211 |
220 |
212 fun begin loc = |
221 fun begin loc = |
213 Data.put (if loc = "" then NONE else SOME loc) #> |
222 Data.put (if loc = "" then NONE else SOME loc) #> |
214 LocalTheory.init (SOME (NameSpace.base loc)) |
223 LocalTheory.init (NameSpace.base loc) |
215 {pretty = pretty loc, |
224 {pretty = pretty loc, |
216 consts = consts loc, |
225 consts = consts loc, |
217 axioms = axioms, |
226 axioms = axioms, |
218 defs = defs, |
227 defs = defs, |
219 notes = notes loc, |
228 notes = notes loc, |
220 type_syntax = type_syntax loc, |
229 type_syntax = type_syntax loc, |
221 term_syntax = term_syntax loc, |
230 term_syntax = term_syntax loc, |
222 declaration = declaration loc, |
231 declaration = declaration loc, |
|
232 target_morphism = target_morphism loc, |
|
233 target_name = target_name loc, |
223 reinit = fn _ => begin loc o (if loc = "" then ProofContext.init else Locale.init loc), |
234 reinit = fn _ => begin loc o (if loc = "" then ProofContext.init else Locale.init loc), |
224 exit = LocalTheory.target_of} |
235 exit = LocalTheory.target_of}; |
225 |
236 |
226 fun init_i NONE thy = begin "" (ProofContext.init thy) |
237 fun init_i NONE thy = begin "" (ProofContext.init thy) |
227 | init_i (SOME loc) thy = begin loc (Locale.init loc thy); |
238 | init_i (SOME loc) thy = begin loc (Locale.init loc thy); |
228 |
239 |
229 fun init (SOME "-") thy = init_i NONE thy |
240 fun init (SOME "-") thy = init_i NONE thy |