author | wenzelm |
Thu, 24 May 2018 16:56:14 +0200 | |
changeset 68264 | bb9a3be6952a |
parent 68235 | a3bd410db5b2 |
child 68295 | 781a98696638 |
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 |
||
68201 | 16 |
(* general setup *) |
68154 | 17 |
|
68201 | 18 |
fun setup_presentation f = |
19 |
Theory.setup (Thy_Info.add_presentation (fn context => fn thy => |
|
20 |
if Options.bool (#options context) "export_theory" then f context thy else ())); |
|
68154 | 21 |
|
68201 | 22 |
fun export_body thy name body = |
68230 | 23 |
Export.export thy ("theory/" ^ name) (Buffer.chunks (YXML.buffer_body body Buffer.empty)); |
68165 | 24 |
|
68154 | 25 |
|
68201 | 26 |
(* presentation *) |
27 |
||
28 |
val _ = setup_presentation (fn {adjust_pos, ...} => fn thy => |
|
29 |
let |
|
68264 | 30 |
val rep_tsig = Type.rep_tsig (Sign.tsig_of thy); |
31 |
||
32 |
||
68206 | 33 |
(* parents *) |
34 |
||
35 |
val parents = Theory.parents_of thy; |
|
36 |
val _ = |
|
37 |
export_body thy "parents" |
|
68231 | 38 |
(XML.Encode.string (cat_lines (map Context.theory_long_name parents))); |
68206 | 39 |
|
40 |
||
68201 | 41 |
(* entities *) |
68154 | 42 |
|
68201 | 43 |
fun entity_markup space name = |
44 |
let |
|
45 |
val {serial, pos, ...} = Name_Space.the_entry space name; |
|
46 |
val props = |
|
47 |
Markup.serial_properties serial @ |
|
48 |
Position.offset_properties_of (adjust_pos pos); |
|
49 |
in (Markup.entityN, (Markup.nameN, name) :: props) end; |
|
68154 | 50 |
|
68201 | 51 |
fun export_entities export_name export get_space decls = |
52 |
let val elems = |
|
53 |
let |
|
68206 | 54 |
val parent_spaces = map get_space parents; |
68201 | 55 |
val space = get_space thy; |
56 |
in |
|
57 |
(decls, []) |-> fold (fn (name, decl) => |
|
58 |
if exists (fn space => Name_Space.declared space name) parent_spaces then I |
|
59 |
else |
|
60 |
(case export name decl of |
|
61 |
NONE => I |
|
62 |
| SOME body => cons (name, XML.Elem (entity_markup space name, body)))) |
|
63 |
|> sort_by #1 |> map #2 |
|
64 |
end; |
|
65 |
in if null elems then () else export_body thy export_name elems end; |
|
68165 | 66 |
|
67 |
||
68201 | 68 |
(* types *) |
68165 | 69 |
|
68201 | 70 |
val encode_type = |
71 |
let open XML.Encode Term_XML.Encode |
|
72 |
in pair (list string) (option typ) end; |
|
68165 | 73 |
|
68201 | 74 |
fun export_type (Type.LogicalType n) = |
75 |
SOME (encode_type (Name.invent Name.context Name.aT n, NONE)) |
|
76 |
| export_type (Type.Abbreviation (args, U, false)) = |
|
77 |
SOME (encode_type (args, SOME U)) |
|
78 |
| export_type _ = NONE; |
|
68165 | 79 |
|
68201 | 80 |
val _ = |
81 |
export_entities "types" (K export_type) Sign.type_space |
|
68264 | 82 |
(Name_Space.dest_table (#types rep_tsig)); |
68201 | 83 |
|
68173 | 84 |
|
68201 | 85 |
(* consts *) |
86 |
||
87 |
val encode_const = |
|
88 |
let open XML.Encode Term_XML.Encode |
|
89 |
in triple (list string) typ (option term) end; |
|
68165 | 90 |
|
68201 | 91 |
fun export_const c (T, abbrev) = |
92 |
let |
|
93 |
val T' = T |> Logic.unvarifyT_global |> Type.strip_sorts; |
|
94 |
val abbrev' = abbrev |> Option.map (Logic.unvarify_global #> map_types Type.strip_sorts); |
|
95 |
val args = map (#1 o dest_TFree) (Consts.typargs (Sign.consts_of thy) (c, T')); |
|
96 |
in SOME (encode_const (args, T', abbrev')) end; |
|
68165 | 97 |
|
68201 | 98 |
val _ = |
99 |
export_entities "consts" export_const Sign.const_space |
|
100 |
(#constants (Consts.dest (Sign.consts_of thy))); |
|
101 |
||
68208 | 102 |
|
68232 | 103 |
(* axioms and facts *) |
68208 | 104 |
|
68232 | 105 |
val encode_props = |
68208 | 106 |
let open XML.Encode Term_XML.Encode |
68232 | 107 |
in triple (list (pair string sort)) (list (pair string typ)) (list term) end; |
68208 | 108 |
|
68232 | 109 |
fun export_props props = |
68208 | 110 |
let |
68232 | 111 |
val props' = map Logic.unvarify_global props; |
112 |
val typargs = rev (fold Term.add_tfrees props' []); |
|
113 |
val args = rev (fold Term.add_frees props' []); |
|
114 |
in encode_props (typargs, args, props') end; |
|
68208 | 115 |
|
68235
a3bd410db5b2
standardize implicit variables: non-zero indexes do occur occasionally, e.g. via RS;
wenzelm
parents:
68232
diff
changeset
|
116 |
val export_axiom = export_props o single; |
a3bd410db5b2
standardize implicit variables: non-zero indexes do occur occasionally, e.g. via RS;
wenzelm
parents:
68232
diff
changeset
|
117 |
val export_fact = export_props o Term_Subst.zero_var_indexes_list o map Thm.full_prop_of; |
68208 | 118 |
|
68232 | 119 |
val _ = |
68235
a3bd410db5b2
standardize implicit variables: non-zero indexes do occur occasionally, e.g. via RS;
wenzelm
parents:
68232
diff
changeset
|
120 |
export_entities "axioms" (K (SOME o export_axiom)) Theory.axiom_space |
a3bd410db5b2
standardize implicit variables: non-zero indexes do occur occasionally, e.g. via RS;
wenzelm
parents:
68232
diff
changeset
|
121 |
(Theory.axioms_of thy); |
a3bd410db5b2
standardize implicit variables: non-zero indexes do occur occasionally, e.g. via RS;
wenzelm
parents:
68232
diff
changeset
|
122 |
val _ = |
a3bd410db5b2
standardize implicit variables: non-zero indexes do occur occasionally, e.g. via RS;
wenzelm
parents:
68232
diff
changeset
|
123 |
export_entities "facts" (K (SOME o export_fact)) (Facts.space_of o Global_Theory.facts_of) |
68232 | 124 |
(Facts.dest_static true [] (Global_Theory.facts_of thy)); |
125 |
||
68264 | 126 |
|
127 |
(* type classes *) |
|
128 |
||
129 |
val encode_class = |
|
130 |
let open XML.Encode Term_XML.Encode |
|
131 |
in pair (list (pair string typ)) (list term) end; |
|
132 |
||
133 |
fun export_class name = |
|
134 |
(case try (Axclass.get_info thy) name of |
|
135 |
NONE => ([], []) |
|
136 |
| SOME {params, axioms, ...} => |
|
137 |
(params, map (Logic.unvarify_global o Thm.full_prop_of) axioms)) |
|
138 |
|> encode_class |> SOME; |
|
139 |
||
140 |
val _ = |
|
141 |
export_entities "classes" (fn name => fn () => export_class name) |
|
142 |
Sign.class_space (map (rpair ()) (Graph.keys (Sorts.classes_of (#2 (#classes rep_tsig))))); |
|
143 |
||
68201 | 144 |
in () end); |
68165 | 145 |
|
146 |
end; |