1 (* Title: Pure/General/binding.ML |
1 (* Title: Pure/General/binding.ML |
2 Author: Florian Haftmann, TU Muenchen |
2 Author: Florian Haftmann, TU Muenchen |
|
3 Author: Makarius |
3 |
4 |
4 Structured name bindings. |
5 Structured name bindings. |
5 *) |
6 *) |
6 |
7 |
7 signature BASIC_BINDING = |
8 type bstring = string; (*primitive names to be bound*) |
8 sig |
|
9 type binding |
|
10 val long_names: bool ref |
|
11 val short_names: bool ref |
|
12 val unique_names: bool ref |
|
13 end; |
|
14 |
9 |
15 signature BINDING = |
10 signature BINDING = |
16 sig |
11 sig |
17 include BASIC_BINDING |
12 type binding |
18 val name_pos: string * Position.T -> binding |
13 val dest: binding -> (string * bool) list * (string * bool) list * bstring |
19 val name: string -> binding |
14 val verbose: bool ref |
|
15 val str_of: binding -> string |
|
16 val make: bstring * Position.T -> binding |
|
17 val name: bstring -> binding |
|
18 val pos_of: binding -> Position.T |
|
19 val name_of: binding -> string |
|
20 val map_name: (bstring -> bstring) -> binding -> binding |
20 val empty: binding |
21 val empty: binding |
21 val map_base: (string -> string) -> binding -> binding |
22 val is_empty: binding -> bool |
22 val qualify: string -> binding -> binding |
23 val qualify: bool -> string -> binding -> binding |
|
24 val map_prefix: ((string * bool) list -> (string * bool) list) -> binding -> binding |
23 val add_prefix: bool -> string -> binding -> binding |
25 val add_prefix: bool -> string -> binding -> binding |
24 val map_prefix: ((string * bool) list -> binding -> binding) -> binding -> binding |
|
25 val is_empty: binding -> bool |
|
26 val base_name: binding -> string |
|
27 val pos_of: binding -> Position.T |
|
28 val dest: binding -> (string * bool) list * string |
|
29 val separator: string |
|
30 val is_qualified: string -> bool |
|
31 val display: binding -> string |
|
32 end; |
26 end; |
33 |
27 |
34 structure Binding : BINDING = |
28 structure Binding: BINDING = |
35 struct |
29 struct |
36 |
30 |
37 (** global flags **) |
31 (** representation **) |
38 |
32 |
39 val long_names = ref false; |
33 (* datatype *) |
40 val short_names = ref false; |
34 |
41 val unique_names = ref true; |
35 type component = string * bool; (*name with mandatory flag*) |
|
36 |
|
37 datatype binding = Binding of |
|
38 {prefix: component list, (*system prefix*) |
|
39 qualifier: component list, (*user qualifier*) |
|
40 name: bstring, (*base name*) |
|
41 pos: Position.T}; (*source position*) |
|
42 |
|
43 fun make_binding (prefix, qualifier, name, pos) = |
|
44 Binding {prefix = prefix, qualifier = qualifier, name = name, pos = pos}; |
|
45 |
|
46 fun map_binding f (Binding {prefix, qualifier, name, pos}) = |
|
47 make_binding (f (prefix, qualifier, name, pos)); |
|
48 |
|
49 fun dest (Binding {prefix, qualifier, name, ...}) = (prefix, qualifier, name); |
42 |
50 |
43 |
51 |
44 (** qualification **) |
52 (* diagnostic output *) |
45 |
53 |
46 val separator = "."; |
54 val verbose = ref false; |
47 val is_qualified = exists_string (fn s => s = separator); |
|
48 |
55 |
49 fun reject_qualified kind s = |
56 val str_of_components = implode o map (fn (s, true) => s ^ "!" | (s, false) => s ^ "?"); |
50 if is_qualified s then |
57 |
51 error ("Attempt to declare qualified " ^ kind ^ " " ^ quote s) |
58 fun str_of (Binding {prefix, qualifier, name, pos}) = |
52 else s; |
59 let |
|
60 val text = |
|
61 if ! verbose then |
|
62 (if null prefix then "" else enclose "(" ")" (str_of_components prefix)) ^ |
|
63 str_of_components qualifier ^ name |
|
64 else name; |
|
65 val props = Position.properties_of pos; |
|
66 in Markup.markup (Markup.properties props (Markup.binding name)) text end; |
53 |
67 |
54 |
68 |
55 (** binding representation **) |
|
56 |
69 |
57 datatype binding = Binding of ((string * bool) list * string) * Position.T; |
70 (** basic operations **) |
58 (* (prefix components (with mandatory flag), base name, position) *) |
|
59 |
71 |
60 fun name_pos (name, pos) = Binding (([], name), pos); |
72 (* name and position *) |
61 fun name name = name_pos (name, Position.none); |
73 |
|
74 fun make (name, pos) = make_binding ([], [], name, pos); |
|
75 fun name name = make (name, Position.none); |
|
76 |
|
77 fun pos_of (Binding {pos, ...}) = pos; |
|
78 fun name_of (Binding {name, ...}) = name; |
|
79 |
|
80 fun map_name f = map_binding (fn (prefix, qualifier, name, pos) => (prefix, qualifier, f name, pos)); |
|
81 |
62 val empty = name ""; |
82 val empty = name ""; |
|
83 fun is_empty b = name_of b = ""; |
63 |
84 |
64 fun map_binding f (Binding (prefix_name, pos)) = Binding (f prefix_name, pos); |
|
65 |
85 |
66 val map_base = map_binding o apsnd; |
86 (* user qualifier *) |
67 |
87 |
68 fun qualify_base path name = |
88 fun qualify _ "" = I |
69 if path = "" orelse name = "" then name |
89 | qualify mandatory qual = map_binding (fn (prefix, qualifier, name, pos) => |
70 else path ^ separator ^ name; |
90 (prefix, (qual, mandatory) :: qualifier, name, pos)); |
71 |
91 |
72 val qualify = map_base o qualify_base; |
|
73 (*FIXME should all operations on bare names move here from name_space.ML ?*) |
|
74 |
92 |
75 fun add_prefix sticky "" b = b |
93 (* system prefix *) |
76 | add_prefix sticky prfx b = (map_binding o apfst) |
|
77 (cons ((*reject_qualified "prefix"*) prfx, sticky)) b; |
|
78 |
94 |
79 fun map_prefix f (Binding ((prefix, name), pos)) = |
95 fun map_prefix f = map_binding (fn (prefix, qualifier, name, pos) => |
80 f prefix (name_pos (name, pos)); |
96 (f prefix, qualifier, name, pos)); |
81 |
97 |
82 fun is_empty (Binding ((_, name), _)) = name = ""; |
98 fun add_prefix _ "" = I |
83 fun base_name (Binding ((_, name), _)) = name; |
99 | add_prefix mandatory prfx = map_prefix (cons (prfx, mandatory)); |
84 fun pos_of (Binding (_, pos)) = pos; |
|
85 fun dest (Binding (prefix_name, _)) = prefix_name; |
|
86 |
|
87 fun display (Binding ((prefix, name), _)) = |
|
88 let |
|
89 fun mk_prefix (prfx, true) = prfx |
|
90 | mk_prefix (prfx, false) = enclose "(" ")" prfx |
|
91 in if not (! long_names) orelse null prefix orelse name = "" then name |
|
92 else space_implode "." (map mk_prefix prefix) ^ ":" ^ name |
|
93 end; |
|
94 |
100 |
95 end; |
101 end; |
96 |
102 |
97 structure Basic_Binding : BASIC_BINDING = Binding; |
103 type binding = Binding.binding; |
98 open Basic_Binding; |
104 |