19 structure Named_Target: NAMED_TARGET = |
19 structure Named_Target: NAMED_TARGET = |
20 struct |
20 struct |
21 |
21 |
22 (* context data *) |
22 (* context data *) |
23 |
23 |
24 datatype target = |
|
25 Target of {target: string, is_locale: bool, is_class: bool}; |
|
26 |
|
27 fun make_target target is_locale is_class = |
|
28 Target {target = target, is_locale = is_locale, is_class = is_class}; |
|
29 |
|
30 fun named_target _ "" = make_target "" false false |
|
31 | named_target thy target = |
|
32 if Locale.defined thy target |
|
33 then make_target target true (Class.is_class thy target) |
|
34 else error ("No such locale: " ^ quote target); |
|
35 |
|
36 structure Data = Proof_Data |
24 structure Data = Proof_Data |
37 ( |
25 ( |
38 type T = target option; |
26 type T = (string * bool) option; |
39 fun init _ = NONE; |
27 fun init _ = NONE; |
40 ); |
28 ); |
41 |
29 |
42 val get_bottom_data = Option.map (fn Target ta => ta) o Data.get; |
30 val get_bottom_data = Data.get; |
43 |
31 |
44 fun get_data lthy = |
32 fun get_data lthy = |
45 if Local_Theory.level lthy = 1 |
33 if Local_Theory.level lthy = 1 |
46 then get_bottom_data lthy |
34 then get_bottom_data lthy |
47 else NONE; |
35 else NONE; |
48 |
36 |
49 fun is_theory lthy = |
37 fun is_theory lthy = |
50 case get_data lthy of |
38 case get_data lthy of |
51 SOME {target = "", ...} => true |
39 SOME ("", _) => true |
52 | _ => false; |
40 | _ => false; |
53 |
41 |
54 fun locale_of lthy = |
42 fun locale_name_of NONE = NONE |
55 case get_data lthy of |
43 | locale_name_of (SOME ("", _)) = NONE |
56 SOME {target = locale, is_locale = true, ...} => SOME locale |
44 | locale_name_of (SOME (locale, _)) = SOME locale; |
57 | _ => NONE; |
|
58 |
45 |
59 fun bottom_locale_of lthy = |
46 val locale_of = locale_name_of o get_data; |
60 case get_bottom_data lthy of |
47 |
61 SOME {target = locale, is_locale = true, ...} => SOME locale |
48 val bottom_locale_of = locale_name_of o get_bottom_data; |
62 | _ => NONE; |
|
63 |
49 |
64 fun class_of lthy = |
50 fun class_of lthy = |
65 case get_data lthy of |
51 case get_data lthy of |
66 SOME {target = class, is_class = true, ...} => SOME class |
52 SOME (class, true) => SOME class |
67 | _ => NONE; |
53 | _ => NONE; |
68 |
54 |
69 |
55 |
70 (* define *) |
56 (* define *) |
71 |
57 |
77 fun class_foundation class (((b, U), mx), (b_def, rhs)) params = |
63 fun class_foundation class (((b, U), mx), (b_def, rhs)) params = |
78 Generic_Target.background_foundation (((b, U), NoSyn), (b_def, rhs)) params |
64 Generic_Target.background_foundation (((b, U), NoSyn), (b_def, rhs)) params |
79 #-> (fn (lhs, def) => Class.const class ((b, mx), lhs) params |
65 #-> (fn (lhs, def) => Class.const class ((b, mx), lhs) params |
80 #> pair (lhs, def)); |
66 #> pair (lhs, def)); |
81 |
67 |
82 fun foundation (Target {target, is_locale, is_class, ...}) = |
68 fun foundation ("", _) = Generic_Target.theory_foundation |
83 if is_class then class_foundation target |
69 | foundation (locale, false) = locale_foundation locale |
84 else if is_locale then locale_foundation target |
70 | foundation (class, true) = class_foundation class; |
85 else Generic_Target.theory_foundation; |
|
86 |
71 |
87 |
72 |
88 (* notes *) |
73 (* notes *) |
89 |
74 |
90 fun notes (Target {target, is_locale, ...}) = |
75 fun notes ("", _) = Generic_Target.theory_notes |
91 if is_locale then Generic_Target.locale_notes target |
76 | notes (locale, _) = Generic_Target.locale_notes locale; |
92 else Generic_Target.theory_notes; |
|
93 |
77 |
94 |
78 |
95 (* abbrev *) |
79 (* abbrev *) |
96 |
80 |
97 fun locale_abbrev locale prmode (b, mx) global_rhs params = |
81 fun locale_abbrev locale prmode (b, mx) global_rhs params = |
100 |
84 |
101 fun class_abbrev class prmode (b, mx) global_rhs params = |
85 fun class_abbrev class prmode (b, mx) global_rhs params = |
102 Generic_Target.background_abbrev (b, global_rhs) (snd params) |
86 Generic_Target.background_abbrev (b, global_rhs) (snd params) |
103 #-> (fn (lhs, rhs) => Class.abbrev class prmode ((b, mx), lhs) rhs params); |
87 #-> (fn (lhs, rhs) => Class.abbrev class prmode ((b, mx), lhs) rhs params); |
104 |
88 |
105 fun abbrev (Target {target, is_locale, is_class, ...}) = |
89 fun abbrev ("", _) = Generic_Target.theory_abbrev |
106 if is_class then class_abbrev target |
90 | abbrev (locale, false) = locale_abbrev locale |
107 else if is_locale then locale_abbrev target |
91 | abbrev (class, true) = class_abbrev class; |
108 else Generic_Target.theory_abbrev; |
|
109 |
92 |
110 |
93 |
111 (* declaration *) |
94 (* declaration *) |
112 |
95 |
113 fun declaration (Target {target, is_locale, ...}) flags decl = |
96 fun declaration ("", _) flags decl = Generic_Target.theory_declaration decl |
114 if is_locale then Generic_Target.locale_declaration target flags decl |
97 | declaration (locale, _) flags decl = Generic_Target.locale_declaration locale flags decl; |
115 else Generic_Target.theory_declaration decl; |
|
116 |
98 |
117 |
99 |
118 (* subscription *) |
100 (* subscription *) |
119 |
101 |
120 fun subscription (Target {target, is_locale, ...}) = |
102 fun subscription ("", _) = Generic_Target.theory_registration |
121 if is_locale then Generic_Target.locale_dependency target |
103 | subscription (locale, _) = Generic_Target.locale_dependency locale; |
122 else Generic_Target.theory_registration; |
|
123 |
104 |
124 |
105 |
125 (* pretty *) |
106 (* pretty *) |
126 |
107 |
127 fun pretty (Target {target, is_locale, is_class, ...}) ctxt = |
108 fun pretty (target, is_class) ctxt = |
128 let |
109 let |
129 val target_name = |
110 val target_name = |
130 [Pretty.keyword1 (if is_class then "class" else "locale"), Pretty.brk 1, |
111 [Pretty.keyword1 (if is_class then "class" else "locale"), Pretty.brk 1, |
131 Locale.pretty_name ctxt target]; |
112 Locale.pretty_name ctxt target]; |
132 val fixes = |
113 val fixes = |
137 (Assumption.all_assms_of ctxt); |
118 (Assumption.all_assms_of ctxt); |
138 val elems = |
119 val elems = |
139 (if null fixes then [] else [Element.Fixes fixes]) @ |
120 (if null fixes then [] else [Element.Fixes fixes]) @ |
140 (if null assumes then [] else [Element.Assumes assumes]); |
121 (if null assumes then [] else [Element.Assumes assumes]); |
141 val body_elems = |
122 val body_elems = |
142 if not is_locale then [] |
123 if target = "" then [] |
143 else if null elems then [Pretty.block target_name] |
124 else if null elems then [Pretty.block target_name] |
144 else [Pretty.block (Pretty.fbreaks (Pretty.block (target_name @ [Pretty.str " ="]) :: |
125 else [Pretty.block (Pretty.fbreaks (Pretty.block (target_name @ [Pretty.str " ="]) :: |
145 map (Pretty.chunks o Element.pretty_ctxt ctxt) elems))]; |
126 map (Pretty.chunks o Element.pretty_ctxt ctxt) elems))]; |
146 in |
127 in |
147 Pretty.block [Pretty.keyword1 "theory", Pretty.brk 1, |
128 Pretty.block [Pretty.keyword1 "theory", Pretty.brk 1, |
149 end; |
130 end; |
150 |
131 |
151 |
132 |
152 (* init *) |
133 (* init *) |
153 |
134 |
154 fun init_context (Target {target, is_locale, is_class, ...}) = |
135 fun make_name_data _ "" = ("", false) |
155 if not is_locale then Proof_Context.init_global |
136 | make_name_data thy target = |
156 else if not is_class then Locale.init target |
137 if Locale.defined thy target |
157 else Class.init target; |
138 then (target, Class.is_class thy target) |
|
139 else error ("No such locale: " ^ quote target); |
|
140 |
|
141 fun init_context ("", _) = Proof_Context.init_global |
|
142 | init_context (locale, false) = Locale.init locale |
|
143 | init_context (class, true) = Class.init class; |
158 |
144 |
159 fun init target thy = |
145 fun init target thy = |
160 let |
146 let |
161 val ta = named_target thy target; |
147 val name_data = make_name_data thy target; |
162 val naming = Sign.naming_of thy |
148 val naming = Sign.naming_of thy |
163 |> Name_Space.mandatory_path (Long_Name.base_name target); |
149 |> Name_Space.mandatory_path (Long_Name.base_name target); |
164 in |
150 in |
165 thy |
151 thy |
166 |> Sign.change_begin |
152 |> Sign.change_begin |
167 |> init_context ta |
153 |> init_context name_data |
168 |> Data.put (SOME ta) |
154 |> Data.put (SOME name_data) |
169 |> Local_Theory.init naming |
155 |> Local_Theory.init naming |
170 {define = Generic_Target.define (foundation ta), |
156 {define = Generic_Target.define (foundation name_data), |
171 notes = Generic_Target.notes (notes ta), |
157 notes = Generic_Target.notes (notes name_data), |
172 abbrev = Generic_Target.abbrev (abbrev ta), |
158 abbrev = Generic_Target.abbrev (abbrev name_data), |
173 declaration = declaration ta, |
159 declaration = declaration name_data, |
174 subscription = subscription ta, |
160 subscription = subscription name_data, |
175 pretty = pretty ta, |
161 pretty = pretty name_data, |
176 exit = Local_Theory.target_of #> Sign.change_end_local} |
162 exit = Local_Theory.target_of #> Sign.change_end_local} |
177 end; |
163 end; |
178 |
164 |
179 val theory_init = init ""; |
165 val theory_init = init ""; |
180 |
166 |