author | wenzelm |
Sat, 15 Sep 2018 23:35:46 +0200 | |
changeset 68997 | 4278947ba336 |
parent 68900 | 1145b25c53de |
child 69003 | a015f1d3ba0c |
permissions | -rw-r--r-- |
68154 | 1 |
(* Title: Pure/Thy/export_theory.ML |
2 |
Author: Makarius |
|
3 |
||
4 |
Export foundational theory content. |
|
5 |
*) |
|
6 |
||
7 |
signature EXPORT_THEORY = |
|
8 |
sig |
|
68201 | 9 |
val setup_presentation: (Thy_Info.presentation_context -> theory -> unit) -> unit |
10 |
val export_body: theory -> string -> XML.body -> unit |
|
68154 | 11 |
end; |
12 |
||
13 |
structure Export_Theory: EXPORT_THEORY = |
|
14 |
struct |
|
15 |
||
68725 | 16 |
(* names for bound variables *) |
17 |
||
18 |
local |
|
19 |
fun declare_names (Abs (_, _, b)) = declare_names b |
|
20 |
| declare_names (t $ u) = declare_names t #> declare_names u |
|
21 |
| declare_names (Const (c, _)) = Name.declare (Long_Name.base_name c) |
|
22 |
| declare_names (Free (x, _)) = Name.declare x |
|
23 |
| declare_names _ = I; |
|
24 |
||
25 |
fun variant_abs bs (Abs (x, T, t)) = |
|
26 |
let |
|
27 |
val names = fold Name.declare bs (declare_names t Name.context); |
|
28 |
val x' = #1 (Name.variant x names); |
|
29 |
val t' = variant_abs (x' :: bs) t; |
|
30 |
in Abs (x', T, t') end |
|
31 |
| variant_abs bs (t $ u) = variant_abs bs t $ variant_abs bs u |
|
32 |
| variant_abs _ t = t; |
|
33 |
in |
|
34 |
val named_bounds = variant_abs []; |
|
35 |
end; |
|
36 |
||
37 |
||
68201 | 38 |
(* general setup *) |
68154 | 39 |
|
68201 | 40 |
fun setup_presentation f = |
41 |
Theory.setup (Thy_Info.add_presentation (fn context => fn thy => |
|
42 |
if Options.bool (#options context) "export_theory" then f context thy else ())); |
|
68154 | 43 |
|
68201 | 44 |
fun export_body thy name body = |
68230 | 45 |
Export.export thy ("theory/" ^ name) (Buffer.chunks (YXML.buffer_body body Buffer.empty)); |
68165 | 46 |
|
68154 | 47 |
|
68201 | 48 |
(* presentation *) |
49 |
||
50 |
val _ = setup_presentation (fn {adjust_pos, ...} => fn thy => |
|
51 |
let |
|
68900
1145b25c53de
more robust: parents are strict in Export_Theory.read_theory and thus approximate "commit" of exports;
wenzelm
parents:
68864
diff
changeset
|
52 |
val parents = Theory.parents_of thy; |
68264 | 53 |
val rep_tsig = Type.rep_tsig (Sign.tsig_of thy); |
54 |
||
68997 | 55 |
val ctxt = Proof_Context.init_global thy; |
56 |
||
68264 | 57 |
|
68201 | 58 |
(* entities *) |
68154 | 59 |
|
68201 | 60 |
fun entity_markup space name = |
61 |
let |
|
68997 | 62 |
val xname = Name_Space.extern_shortest ctxt space name; |
68201 | 63 |
val {serial, pos, ...} = Name_Space.the_entry space name; |
64 |
val props = |
|
68830
44ec6fdaacf8
retain original id, which is command_id/exec_id for PIDE;
wenzelm
parents:
68727
diff
changeset
|
65 |
Position.offset_properties_of (adjust_pos pos) @ |
44ec6fdaacf8
retain original id, which is command_id/exec_id for PIDE;
wenzelm
parents:
68727
diff
changeset
|
66 |
Position.id_properties_of pos @ |
44ec6fdaacf8
retain original id, which is command_id/exec_id for PIDE;
wenzelm
parents:
68727
diff
changeset
|
67 |
Markup.serial_properties serial; |
68997 | 68 |
in (Markup.entityN, (Markup.nameN, name) :: (Markup.xnameN, xname) :: props) end; |
68154 | 69 |
|
68201 | 70 |
fun export_entities export_name export get_space decls = |
71 |
let val elems = |
|
72 |
let |
|
68206 | 73 |
val parent_spaces = map get_space parents; |
68201 | 74 |
val space = get_space thy; |
75 |
in |
|
76 |
(decls, []) |-> fold (fn (name, decl) => |
|
77 |
if exists (fn space => Name_Space.declared space name) parent_spaces then I |
|
78 |
else |
|
79 |
(case export name decl of |
|
80 |
NONE => I |
|
68724 | 81 |
| SOME body => |
82 |
cons (#serial (Name_Space.the_entry space name), |
|
83 |
XML.Elem (entity_markup space name, body)))) |
|
84 |
|> sort (int_ord o apply2 #1) |> map #2 |
|
68201 | 85 |
end; |
86 |
in if null elems then () else export_body thy export_name elems end; |
|
68165 | 87 |
|
88 |
||
68201 | 89 |
(* types *) |
68165 | 90 |
|
68201 | 91 |
val encode_type = |
92 |
let open XML.Encode Term_XML.Encode |
|
93 |
in pair (list string) (option typ) end; |
|
68165 | 94 |
|
68201 | 95 |
fun export_type (Type.LogicalType n) = |
96 |
SOME (encode_type (Name.invent Name.context Name.aT n, NONE)) |
|
97 |
| export_type (Type.Abbreviation (args, U, false)) = |
|
98 |
SOME (encode_type (args, SOME U)) |
|
99 |
| export_type _ = NONE; |
|
68165 | 100 |
|
68201 | 101 |
val _ = |
102 |
export_entities "types" (K export_type) Sign.type_space |
|
68264 | 103 |
(Name_Space.dest_table (#types rep_tsig)); |
68201 | 104 |
|
68173 | 105 |
|
68201 | 106 |
(* consts *) |
107 |
||
108 |
val encode_const = |
|
109 |
let open XML.Encode Term_XML.Encode |
|
68725 | 110 |
in triple (list string) typ (option (term o named_bounds)) end; |
68165 | 111 |
|
68201 | 112 |
fun export_const c (T, abbrev) = |
113 |
let |
|
114 |
val T' = T |> Logic.unvarifyT_global |> Type.strip_sorts; |
|
115 |
val abbrev' = abbrev |> Option.map (Logic.unvarify_global #> map_types Type.strip_sorts); |
|
116 |
val args = map (#1 o dest_TFree) (Consts.typargs (Sign.consts_of thy) (c, T')); |
|
117 |
in SOME (encode_const (args, T', abbrev')) end; |
|
68165 | 118 |
|
68201 | 119 |
val _ = |
120 |
export_entities "consts" export_const Sign.const_space |
|
121 |
(#constants (Consts.dest (Sign.consts_of thy))); |
|
122 |
||
68208 | 123 |
|
68232 | 124 |
(* axioms and facts *) |
68208 | 125 |
|
68727 | 126 |
fun standard_prop_of raw_thm = |
127 |
let |
|
128 |
val thm = raw_thm |
|
129 |
|> Thm.transfer thy |
|
130 |
|> Thm.check_hyps (Context.Theory thy) |
|
131 |
|> Thm.strip_shyps; |
|
132 |
val prop = thm |
|
133 |
|> Thm.full_prop_of |
|
134 |
|> Term_Subst.zero_var_indexes; |
|
135 |
in (Thm.extra_shyps thm, prop) end; |
|
68539 | 136 |
|
68727 | 137 |
fun encode_prop (Ss, prop) = |
68208 | 138 |
let |
68726 | 139 |
val prop' = Logic.unvarify_global (named_bounds prop); |
140 |
val typargs = rev (Term.add_tfrees prop' []); |
|
68727 | 141 |
val sorts = Name.invent (Name.make_context (map #1 typargs)) Name.aT (length Ss) ~~ Ss; |
68726 | 142 |
val args = rev (Term.add_frees prop' []); |
143 |
in |
|
68727 | 144 |
(sorts @ typargs, args, prop') |> |
145 |
let open XML.Encode Term_XML.Encode |
|
146 |
in triple (list (pair string sort)) (list (pair string typ)) term end |
|
68726 | 147 |
end; |
68208 | 148 |
|
68726 | 149 |
val encode_fact = XML.Encode.list encode_prop o map standard_prop_of; |
68208 | 150 |
|
68232 | 151 |
val _ = |
68727 | 152 |
export_entities "axioms" (fn _ => fn t => SOME (encode_prop ([], t))) Theory.axiom_space |
68235
a3bd410db5b2
standardize implicit variables: non-zero indexes do occur occasionally, e.g. via RS;
wenzelm
parents:
68232
diff
changeset
|
153 |
(Theory.axioms_of thy); |
a3bd410db5b2
standardize implicit variables: non-zero indexes do occur occasionally, e.g. via RS;
wenzelm
parents:
68232
diff
changeset
|
154 |
val _ = |
68726 | 155 |
export_entities "facts" (K (SOME o encode_fact)) (Facts.space_of o Global_Theory.facts_of) |
68232 | 156 |
(Facts.dest_static true [] (Global_Theory.facts_of thy)); |
157 |
||
68264 | 158 |
|
159 |
(* type classes *) |
|
160 |
||
161 |
val encode_class = |
|
162 |
let open XML.Encode Term_XML.Encode |
|
68725 | 163 |
in pair (list (pair string typ)) (list (term o named_bounds)) end; |
68264 | 164 |
|
165 |
fun export_class name = |
|
166 |
(case try (Axclass.get_info thy) name of |
|
167 |
NONE => ([], []) |
|
168 |
| SOME {params, axioms, ...} => |
|
169 |
(params, map (Logic.unvarify_global o Thm.full_prop_of) axioms)) |
|
170 |
|> encode_class |> SOME; |
|
171 |
||
172 |
val _ = |
|
173 |
export_entities "classes" (fn name => fn () => export_class name) |
|
174 |
Sign.class_space (map (rpair ()) (Graph.keys (Sorts.classes_of (#2 (#classes rep_tsig))))); |
|
175 |
||
68295 | 176 |
|
177 |
(* sort algebra *) |
|
178 |
||
179 |
val {classrel, arities} = |
|
180 |
Sorts.dest_algebra (map (#2 o #classes o Type.rep_tsig o Sign.tsig_of) parents) |
|
181 |
(#2 (#classes rep_tsig)); |
|
182 |
||
183 |
val encode_classrel = |
|
184 |
let open XML.Encode |
|
185 |
in list (pair string (list string)) end; |
|
186 |
||
187 |
val encode_arities = |
|
188 |
let open XML.Encode Term_XML.Encode |
|
189 |
in list (triple string (list sort) string) end; |
|
190 |
||
191 |
val _ = if null classrel then () else export_body thy "classrel" (encode_classrel classrel); |
|
192 |
val _ = if null arities then () else export_body thy "arities" (encode_arities arities); |
|
193 |
||
68862 | 194 |
|
195 |
(* locales *) |
|
196 |
||
68864 | 197 |
fun encode_locale ({type_params, params, asm, defs}: Locale.content) = |
198 |
let |
|
199 |
val args = map #1 params; |
|
200 |
val typargs = type_params @ rev (fold Term.add_tfrees (map Free args @ the_list asm) []); |
|
201 |
val encode = |
|
202 |
let open XML.Encode Term_XML.Encode in |
|
203 |
pair (list (pair string sort)) |
|
204 |
(pair (list (pair string typ)) |
|
205 |
(pair (option term) (list term))) |
|
206 |
end; |
|
207 |
in encode (typargs, (args, (asm, defs))) end; |
|
68862 | 208 |
|
209 |
val _ = |
|
210 |
export_entities "locales" (fn _ => SOME o encode_locale) Locale.locale_space |
|
211 |
(Locale.dest_locales thy); |
|
212 |
||
68900
1145b25c53de
more robust: parents are strict in Export_Theory.read_theory and thus approximate "commit" of exports;
wenzelm
parents:
68864
diff
changeset
|
213 |
|
1145b25c53de
more robust: parents are strict in Export_Theory.read_theory and thus approximate "commit" of exports;
wenzelm
parents:
68864
diff
changeset
|
214 |
(* parents *) |
1145b25c53de
more robust: parents are strict in Export_Theory.read_theory and thus approximate "commit" of exports;
wenzelm
parents:
68864
diff
changeset
|
215 |
|
1145b25c53de
more robust: parents are strict in Export_Theory.read_theory and thus approximate "commit" of exports;
wenzelm
parents:
68864
diff
changeset
|
216 |
val _ = |
1145b25c53de
more robust: parents are strict in Export_Theory.read_theory and thus approximate "commit" of exports;
wenzelm
parents:
68864
diff
changeset
|
217 |
export_body thy "parents" |
1145b25c53de
more robust: parents are strict in Export_Theory.read_theory and thus approximate "commit" of exports;
wenzelm
parents:
68864
diff
changeset
|
218 |
(XML.Encode.string (cat_lines (map Context.theory_long_name parents))); |
1145b25c53de
more robust: parents are strict in Export_Theory.read_theory and thus approximate "commit" of exports;
wenzelm
parents:
68864
diff
changeset
|
219 |
|
68295 | 220 |
in () end); |
68165 | 221 |
|
222 |
end; |