9 signature DATA = |
9 signature DATA = |
10 sig |
10 sig |
11 type T |
11 type T |
12 val empty: T |
12 val empty: T |
13 val merge: T * T -> T |
13 val merge: T * T -> T |
14 val print: T -> unit |
14 val prep_ext: T -> T |
15 val init: T -> string -> exn -> (exn * exn -> exn) -> (string -> exn -> Pretty.T) -> T |
15 val kinds: T -> string list |
|
16 val init: T -> string -> exn -> (exn -> exn) -> (exn * exn -> exn) |
|
17 -> (string -> exn -> unit) -> T |
16 val get: T -> string -> exn |
18 val get: T -> string -> exn |
17 val put: T -> string -> exn -> T |
19 val put: T -> string -> exn -> T |
|
20 val print: T -> string -> unit |
18 end; |
21 end; |
19 |
22 |
20 |
23 |
21 structure Data: DATA = |
24 structure Data: DATA = |
22 struct |
25 struct |
23 |
26 |
|
27 |
24 (* datatype T *) |
28 (* datatype T *) |
25 |
29 |
26 datatype T = Data of (*value, merge method, pp method*) |
30 datatype T = Data of |
27 (exn * ((exn * exn -> exn) * (string -> exn -> Pretty.T))) Symtab.table; |
31 (exn * (*value*) |
|
32 ((exn -> exn) * (*prepare extend method*) |
|
33 (exn * exn -> exn) * (*merge and prepare extend method*) |
|
34 (string -> exn -> unit))) (*print method*) |
|
35 Symtab.table; |
|
36 |
|
37 val empty = Data Symtab.null; |
|
38 |
|
39 fun kinds (Data tab) = map fst (Symtab.dest tab); |
28 |
40 |
29 |
41 |
30 (* errors *) |
42 (* errors *) |
31 |
43 |
32 fun err_msg_merge kind = |
44 fun err_mergext kind = |
33 error_msg ("Error while trying to merge " ^ quote kind ^ " data"); |
45 error ("Error while extend / merge of " ^ quote kind ^ " data"); |
34 |
46 |
35 fun err_dup_init kind = |
47 fun err_dup_init kind = |
36 error ("Duplicate initialization of " ^ quote kind ^ " data"); |
48 error ("Duplicate initialization of " ^ quote kind ^ " data"); |
37 |
49 |
38 fun err_uninit kind = |
50 fun err_uninit kind = |
39 error ("Tried to access uninitialized " ^ quote kind ^ " data"); |
51 error ("Tried to access uninitialized " ^ quote kind ^ " data"); |
40 |
52 |
41 |
53 |
42 (* operations *) |
54 (* prepare data *) |
43 |
|
44 val empty = Data Symtab.null; |
|
45 |
|
46 |
55 |
47 fun merge (Data tab1, Data tab2) = |
56 fun merge (Data tab1, Data tab2) = |
48 let |
57 let |
49 val data1 = Symtab.dest tab1; |
58 val data1 = Symtab.dest tab1; |
50 val data2 = Symtab.dest tab2; |
59 val data2 = Symtab.dest tab2; |
54 fun entry data kind = |
63 fun entry data kind = |
55 (case assoc (data, kind) of |
64 (case assoc (data, kind) of |
56 None => [] |
65 None => [] |
57 | Some x => [(kind, x)]); |
66 | Some x => [(kind, x)]); |
58 |
67 |
59 fun merge_entries [x] = x |
68 fun merge_entries [(kind, (e, mths as (ext, _, _)))] = |
60 | merge_entries [(kind, (e1, mths as (mrg, _))), (_, (e2, _))] = |
69 (kind, (ext e handle exn => err_mergext kind, mths)) |
61 (kind, (mrg (e1, e2) handle exn => (err_msg_merge kind; raise exn), mths)) |
70 | merge_entries [(kind, (e1, mths as (_, mrg, _))), (_, (e2, _))] = |
|
71 (kind, (mrg (e1, e2) handle exn => (err_mergext kind; raise exn), mths)) |
62 | merge_entries _ = sys_error "merge_entries"; |
72 | merge_entries _ = sys_error "merge_entries"; |
63 |
73 |
64 val data = map (fn k => merge_entries (entry data1 k @ entry data2 k)) kinds; |
74 val data = map (fn k => merge_entries (entry data1 k @ entry data2 k)) kinds; |
65 in Data (Symtab.make data) end; |
75 in Data (Symtab.make data) end; |
66 |
76 |
67 |
77 |
68 fun print (Data tab) = |
78 fun prep_ext data = merge (data, empty); (* FIXME !? *) |
69 let fun prnt (kind, (e, (_, prt))) = Pretty.writeln (prt kind e) in |
|
70 seq prnt (Symtab.dest tab) |
|
71 end; |
|
72 |
79 |
73 |
80 fun init (Data tab) kind e ext mrg prt = |
74 fun init (Data tab) kind e mrg prt = |
81 Data (Symtab.update_new ((kind, (e, (ext, mrg, prt))), tab)) |
75 Data (Symtab.update_new ((kind, (e, (mrg, prt))), tab)) |
|
76 handle Symtab.DUPLICATE _ => err_dup_init kind; |
82 handle Symtab.DUPLICATE _ => err_dup_init kind; |
77 |
83 |
78 |
84 |
79 fun get (Data tab) kind = |
85 (* access data *) |
|
86 |
|
87 fun lookup tab kind = |
80 (case Symtab.lookup (tab, kind) of |
88 (case Symtab.lookup (tab, kind) of |
81 Some (e, _) => e |
89 Some x => x |
82 | None => err_uninit kind); |
90 | None => err_uninit kind); |
83 |
91 |
|
92 fun get (Data tab) kind = fst (lookup tab kind); |
84 |
93 |
85 fun put (Data tab) kind e = |
94 fun put (Data tab) kind e = |
86 (case Symtab.lookup (tab, kind) of |
95 Data (Symtab.update ((kind, (e, snd (lookup tab kind))), tab)); |
87 Some (_, meths) => Data (Symtab.update ((kind, (e, meths)), tab)) |
96 |
88 | None => err_uninit kind); |
97 fun print (Data tab) kind = |
|
98 let val (e, (_, _, prt)) = lookup tab kind in prt kind e end; |
89 |
99 |
90 |
100 |
91 end; |
101 end; |