97 |
97 |
98 (** global names (identifiers) **) |
98 (** global names (identifiers) **) |
99 |
99 |
100 (* identifier categories *) |
100 (* identifier categories *) |
101 |
101 |
102 val idf_class = "class"; |
102 val suffix_class = "class"; |
103 val idf_classrel = "clsrel" |
103 val suffix_classrel = "clsrel" |
104 val idf_tyco = "tyco"; |
104 val suffix_tyco = "tyco"; |
105 val idf_instance = "inst"; |
105 val suffix_instance = "inst"; |
106 val idf_const = "const"; |
106 val suffix_const = "const"; |
107 |
107 |
108 fun string_of_classrel (class, superclass) = class ^ " < " ^ superclass; |
108 fun string_of_classrel (class, superclass) = class ^ " < " ^ superclass; |
109 fun string_of_instance (class, tyco) = tyco ^ " :: " ^ class; |
109 fun string_of_instance (class, tyco) = tyco ^ " :: " ^ class; |
110 |
110 |
111 fun add_idf nsp name = |
111 fun add_suffix nsp name = |
112 NameSpace.append name nsp; |
112 NameSpace.append name nsp; |
113 |
113 |
114 fun dest_idf nsp name = |
114 fun dest_suffix nsp name = |
115 if NameSpace.base name = nsp |
115 if NameSpace.base name = nsp |
116 then SOME (NameSpace.qualifier name) |
116 then SOME (NameSpace.qualifier name) |
117 else NONE; |
117 else NONE; |
118 |
118 |
119 local |
119 local |
120 |
120 |
121 val name_mapping = [ |
121 val name_mapping = [ |
122 (idf_class, "class"), |
122 (suffix_class, "class"), |
123 (idf_classrel, "subclass relation"), |
123 (suffix_classrel, "subclass relation"), |
124 (idf_tyco, "type constructor"), |
124 (suffix_tyco, "type constructor"), |
125 (idf_instance, "instance"), |
125 (suffix_instance, "instance"), |
126 (idf_const, "constant") |
126 (suffix_const, "constant") |
127 ] |
127 ] |
128 |
128 |
129 in |
129 in |
130 |
130 |
131 val category_of = the o AList.lookup (op =) name_mapping o NameSpace.base; |
131 val category_of = the o AList.lookup (op =) name_mapping o NameSpace.base; |
147 | NONE => error (errmsg x) end; |
147 | NONE => error (errmsg x) end; |
148 |
148 |
149 fun thyname_of_class thy = |
149 fun thyname_of_class thy = |
150 thyname_of thy (fn thy => member (op =) (Sign.all_classes thy)) |
150 thyname_of thy (fn thy => member (op =) (Sign.all_classes thy)) |
151 (fn class => "thyname_of_class: no such class: " ^ quote class); |
151 (fn class => "thyname_of_class: no such class: " ^ quote class); |
152 |
|
153 fun thyname_of_classrel thy = |
|
154 thyname_of thy (fn thy => fn (class1, class2) => Sign.subsort thy ([class1], [class2])) |
|
155 (fn (class1, class2) => "thyname_of_classrel: no such subclass relation: " |
|
156 ^ (quote o string_of_classrel) (class1, class2)); |
|
157 |
152 |
158 fun thyname_of_tyco thy = |
153 fun thyname_of_tyco thy = |
159 thyname_of thy Sign.declared_tyname |
154 thyname_of thy Sign.declared_tyname |
160 (fn tyco => "thyname_of_tyco: no such type constructor: " ^ quote tyco); |
155 (fn tyco => "thyname_of_tyco: no such type constructor: " ^ quote tyco); |
161 |
156 |
203 val base = (purify_base o get_basename) name; |
198 val base = (purify_base o get_basename) name; |
204 in NameSpace.implode (prefix @ [base]) end; |
199 in NameSpace.implode (prefix @ [base]) end; |
205 |
200 |
206 fun class_policy thy = default_policy thy NameSpace.base thyname_of_class; |
201 fun class_policy thy = default_policy thy NameSpace.base thyname_of_class; |
207 fun classrel_policy thy = default_policy thy (fn (class1, class2) => |
202 fun classrel_policy thy = default_policy thy (fn (class1, class2) => |
208 NameSpace.base class2 ^ "_" ^ NameSpace.base class1) thyname_of_classrel; |
203 NameSpace.base class2 ^ "_" ^ NameSpace.base class1) (fn thy => thyname_of_class thy o fst); |
209 (*order fits nicely with composed projections*) |
204 (*order fits nicely with composed projections*) |
210 fun tyco_policy thy = default_policy thy NameSpace.base thyname_of_tyco; |
205 fun tyco_policy thy = default_policy thy NameSpace.base thyname_of_tyco; |
211 fun instance_policy thy = default_policy thy (fn (class, tyco) => |
206 fun instance_policy thy = default_policy thy (fn (class, tyco) => |
212 NameSpace.base class ^ "_" ^ NameSpace.base tyco) thyname_of_instance; |
207 NameSpace.base class ^ "_" ^ NameSpace.base tyco) thyname_of_instance; |
213 |
208 |
366 |
361 |
367 (* external interfaces *) |
362 (* external interfaces *) |
368 |
363 |
369 fun class thy = |
364 fun class thy = |
370 get thy #class Symtab.lookup map_class Symtab.update class_policy |
365 get thy #class Symtab.lookup map_class Symtab.update class_policy |
371 #> add_idf idf_class; |
366 #> add_suffix suffix_class; |
372 fun classrel thy = |
367 fun classrel thy = |
373 get thy #classrel StringPairTab.lookup map_classrel StringPairTab.update classrel_policy |
368 get thy #classrel StringPairTab.lookup map_classrel StringPairTab.update classrel_policy |
374 #> add_idf idf_classrel; |
369 #> add_suffix suffix_classrel; |
375 fun tyco thy = |
370 fun tyco thy = |
376 get thy #tyco Symtab.lookup map_tyco Symtab.update tyco_policy |
371 get thy #tyco Symtab.lookup map_tyco Symtab.update tyco_policy |
377 #> add_idf idf_tyco; |
372 #> add_suffix suffix_tyco; |
378 fun instance thy = |
373 fun instance thy = |
379 get thy #instance StringPairTab.lookup map_instance StringPairTab.update instance_policy |
374 get thy #instance StringPairTab.lookup map_instance StringPairTab.update instance_policy |
380 #> add_idf idf_instance; |
375 #> add_suffix suffix_instance; |
381 fun const thy = |
376 fun const thy = |
382 get_const thy |
377 get_const thy |
383 #> add_idf idf_const; |
378 #> add_suffix suffix_const; |
384 |
379 |
385 fun class_rev thy = |
380 fun class_rev thy = |
386 dest_idf idf_class |
381 dest_suffix suffix_class |
387 #> Option.map (rev thy #class); |
382 #> Option.map (rev thy #class); |
388 fun classrel_rev thy = |
383 fun classrel_rev thy = |
389 dest_idf idf_classrel |
384 dest_suffix suffix_classrel |
390 #> Option.map (rev thy #classrel); |
385 #> Option.map (rev thy #classrel); |
391 fun tyco_rev thy = |
386 fun tyco_rev thy = |
392 dest_idf idf_tyco |
387 dest_suffix suffix_tyco |
393 #> Option.map (rev thy #tyco); |
388 #> Option.map (rev thy #tyco); |
394 fun instance_rev thy = |
389 fun instance_rev thy = |
395 dest_idf idf_instance |
390 dest_suffix suffix_instance |
396 #> Option.map (rev thy #instance); |
391 #> Option.map (rev thy #instance); |
397 fun const_rev thy = |
392 fun const_rev thy = |
398 dest_idf idf_const |
393 dest_suffix suffix_const |
399 #> Option.map (rev_const thy); |
394 #> Option.map (rev_const thy); |
400 |
395 |
401 local |
396 local |
402 |
397 |
403 val f_mapping = [ |
398 val f_mapping = [ |
404 (idf_class, class_rev), |
399 (suffix_class, class_rev), |
405 (idf_classrel, Option.map string_of_classrel oo classrel_rev), |
400 (suffix_classrel, Option.map string_of_classrel oo classrel_rev), |
406 (idf_tyco, tyco_rev), |
401 (suffix_tyco, tyco_rev), |
407 (idf_instance, Option.map string_of_instance oo instance_rev), |
402 (suffix_instance, Option.map string_of_instance oo instance_rev), |
408 (idf_const, fn thy => Option.map (CodeUnit.string_of_const thy) o const_rev thy) |
403 (suffix_const, fn thy => Option.map (CodeUnit.string_of_const thy) o const_rev thy) |
409 ]; |
404 ]; |
410 |
405 |
411 in |
406 in |
412 |
407 |
413 fun labelled_name thy idf = |
408 fun labelled_name thy suffix_name = |
414 let |
409 let |
415 val category = category_of idf; |
410 val category = category_of suffix_name; |
416 val name = NameSpace.qualifier idf; |
411 val name = NameSpace.qualifier suffix_name; |
417 val f = (the o AList.lookup (op =) f_mapping o NameSpace.base) idf |
412 val suffix = NameSpace.base suffix_name |
418 in case f thy idf |
413 in case (the o AList.lookup (op =) f_mapping) suffix thy suffix_name |
419 of SOME thing => category ^ " " ^ quote thing |
414 of SOME thing => category ^ " " ^ quote thing |
420 | NONE => error ("Unknown name: " ^ quote name) |
415 | NONE => error ("Unknown name: " ^ quote name) |
421 end; |
416 end; |
422 |
417 |
423 end; |
418 end; |