Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 259 lines (197 sloc) 7.657 kb
fccc685 Initial open-source release
MLstate authored
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18
19 let (!!) = Annot.annot
20
21 type trace = Annot.t AnnotMap.t
22
23 exception AnnotNotFound of string * Annot.t
24 exception ConflictingAnnotations of Annot.t
25
26 (* For the semantics, have a look at the .mli. *)
27
28
29 type 'a typed_annot =
30 {
31 a_ty : 'a option ;
32 (* TODO: rename a_tsc to a_tsc_gen and perhaps change it's type
33 to [TypeVar.t list] and rename even more *)
34 a_tsc : ('a, unit) QmlGenericScheme.tsc option ;
35 a_tsc_inst : ('a, unit) QmlGenericScheme.tsc option ;
36 }
37
38 type 'a gen_annotmap = ('a typed_annot) AnnotMap.t
39
40 (* registering exception printers *)
41 let () = Printexc.register_printer
42 (function
43 | AnnotNotFound (s,annot) -> Some (Printf.sprintf "QmlAnnotMap.AnnotNotFound (%S,%s)" s (Annot.to_string annot))
44 | ConflictingAnnotations annot -> Some (Printf.sprintf "QmlAnnotMap.ConflictingAnnotations %s" (Annot.to_string annot))
45 | _ -> None
46 )
47
48 let default_annot = {
49 a_ty = None ;
50 a_tsc = None ;
51 a_tsc_inst = None ;
52 }
53
54 let empty = AnnotMap.empty
55
56 let is_empty am = AnnotMap.is_empty am
57 let size am = AnnotMap.size am
58
59 let rec lift f f_tsc annot = {
60 a_ty = Option.map f annot.a_ty ;
61 a_tsc = Option.map f_tsc annot.a_tsc ;
62 a_tsc_inst = Option.map f_tsc annot.a_tsc_inst ;
63 }
64 and map f f_tsc annotmap =
65 AnnotMap.map (lift f f_tsc) annotmap
66
67 let map_ty_tsc ~ty:f ~tsc:f_tsc annotmap =
68 map f f_tsc annotmap
69 let map f annotmap =
70 map_ty_tsc ~ty:f ~tsc:(QmlGenericScheme.map_body_unsafe f) annotmap
71
72 let annot_merge conflict_t conflict_s i annot1 annot2 =
73 let { a_ty = t1 ; a_tsc = tsc1 ; a_tsc_inst = tsc_inst1 } = annot1
74 and { a_ty = t2 ; a_tsc = tsc2 ; a_tsc_inst = tsc_inst2 } = annot2 in
75 {
76 a_ty = Option.merge (conflict_t i) t1 t2 ;
77 a_tsc = Option.merge (conflict_s i) tsc1 tsc2 ;
78 a_tsc_inst = Option.merge (conflict_s i) tsc_inst1 tsc_inst2 ;
79 }
80
81 let merge_i f annotmap1 annotmap2 =
82 AnnotMap.merge_i f annotmap1 annotmap2
83
84 let merge ?(no_conflict_if_equal=false) annotmap1 annotmap2 =
85 let f i x y =
86 if no_conflict_if_equal && (x = y) then y
87 else raise (ConflictingAnnotations i)
88 in
89 merge_i (annot_merge f f) annotmap1 annotmap2
90
91 let overwrite annotmap1 annotmap2 =
92 let f _ _ y = y in
93 merge_i (annot_merge f f) annotmap1 annotmap2
94
95 let unsafe_overwrite annotmap1 annotmap2 =
96 let f _ _ y = y in
97 merge_i f annotmap1 annotmap2
98
99 let find_opt i annotmap = AnnotMap.find_opt i annotmap
100 let find_opt_label label = find_opt (!! label)
101 let find i annotmap = Option.get_exn (AnnotNotFound ("annot", i)) (find_opt i annotmap)
102 let find_label label = find (!! label)
103 let add i annot annotmap = AnnotMap.add i annot annotmap
104 let add_label label = add (!! label)
105 let remove i annotmap = AnnotMap.remove i annotmap
106
107 let find_opt_factory _name accessor i annotmap =
108 Option.join (Option.map accessor (find_opt i annotmap))
109 let find_factory name accessor i annotmap =
110 Option.get_exn (AnnotNotFound (name, i)) (accessor (find i annotmap))
111 let add_factory _name builder i t annotmap =
112 match find_opt i annotmap with
113 | None -> add i (builder default_annot t) annotmap
114 | Some annot -> add i (builder annot t) annotmap
115
116 let find_ty_opt i annotmap =
117 find_opt_factory "ty"
118 (fun x -> x.a_ty)
119 i annotmap
120
121 let find_ty_opt_label label = find_ty_opt (!! label)
122
123 let find_ty i annotmap =
124 find_factory "ty"
125 (fun x -> x.a_ty)
126 i annotmap
127
128 let find_ty_label label = find_ty (!! label)
129
130 let add_ty i t annotmap =
131 add_factory "ty"
132 (fun annot t -> { annot with a_ty = Some t })
133 i t annotmap
134
135 let add_ty_label label = add_ty (!! label)
136
137 let find_tsc_opt i annotmap =
138 find_opt_factory "tsc"
139 (fun x -> x.a_tsc)
140 i annotmap
141
142 let find_tsc_opt_label label = find_tsc_opt (!! label)
143
144 let find_tsc i annotmap =
145 find_factory "tsc"
146 (fun x -> x.a_tsc)
147 i annotmap
148
149 let find_tsc_label label = find_tsc (!! label)
150
151 let add_tsc i t annotmap =
152 add_factory "tsc"
153 (fun annot t -> { annot with a_tsc = Some t } )
154 i t annotmap
155 let add_tsc_label label = add_tsc (!! label)
156 let add_tsc_opt i t annotmap =
157 Option.default annotmap (Option.map (fun t -> add_tsc i t annotmap) t)
158 let add_tsc_opt_label label = add_tsc_opt (!! label)
159
160 let find_tsc_inst_opt i annotmap =
161 find_opt_factory "tsc_inst"
162 (fun x -> x.a_tsc_inst)
163 i annotmap
164
165 let find_tsc_inst_opt_label label = find_tsc_inst_opt (!! label)
166
167 let find_tsc_inst i annotmap =
168 find_factory "tsc_inst"
169 (fun x -> x.a_tsc_inst)
170 i annotmap
171
172 let find_tsc_inst_label label = find_tsc_inst (!! label)
173
174 let add_tsc_inst i t annotmap =
175 add_factory "tsc_inst"
176 (fun annot t -> { annot with a_tsc_inst = Some t })
177 i t annotmap
178
179 let add_tsc_inst_label label = add_tsc_inst (!! label)
180
181 let add_tsc_inst_opt i t annotmap =
182 Option.default annotmap (Option.map (fun t -> add_tsc_inst i t annotmap) t)
183
184 let add_tsc_inst_opt_label label = add_tsc_inst_opt (!! label)
185
186 let remove_tsc i annotmap =
187 match find_opt i annotmap with
188 | None -> annotmap
189 | Some annot -> add i { annot with a_tsc = None } annotmap
190
191 let remove_tsc_label label = remove_tsc (!! label)
192
193 let remove_tsc_inst i annotmap =
194 match find_opt i annotmap with
195 | None -> annotmap
196 | Some annot -> add i { annot with a_tsc_inst = None } annotmap
197
198 let remove_tsc_inst_label label = remove_tsc_inst (!! label)
199
200 let iteri ~f_for_key ~f_for_ty ~f_for_tsc ~f_for_tsc_inst
201 annotmap =
202 AnnotMap.iter
203 (fun key bound_value ->
204 f_for_key key ;
205 f_for_ty bound_value.a_ty ;
206 f_for_tsc bound_value.a_tsc ;
207 f_for_tsc_inst bound_value.a_tsc_inst)
208 annotmap
209
210
211
212 module Ref = struct
213
214 module type REF = sig type ty val _global : (ty gen_annotmap) ref end
215
216 module type ANNOTMAPREF =
217 sig
218 type ty
219
220 val clear : unit -> unit
221 val import : ty gen_annotmap -> unit
222 val merge : ty gen_annotmap -> unit
223 val overwrite : ty gen_annotmap -> unit
224 val export : unit -> ty gen_annotmap
225 val get_opt : Annot.t -> (ty typed_annot) option
226 val get : Annot.t -> ty typed_annot
227 val set : Annot.t -> ty typed_annot -> unit
228
229 (* specific functions: please add more if useful *)
230 val set_ty : Annot.t -> ty -> unit
231 val get_ty : Annot.t -> ty
232 val get_ty_opt : Annot.t -> ty option
233 val get_tsc_opt : Annot.t -> (ty, unit) QmlGenericScheme.tsc option
234
235 (* we don't provide Ref interface for everything -- please add if you need *)
236 end
237
238 module Make (Ref: REF) : (ANNOTMAPREF with type ty = Ref.ty) =
239 struct
240 type ty = Ref.ty
241
242 let clear () = Ref._global := empty
243 let import annotmap = Ref._global := annotmap
244 let merge annotmap = Ref._global := merge !Ref._global annotmap
245 let overwrite annotmap = Ref._global := overwrite !Ref._global annotmap
246 let export () = !Ref._global
247 let get_opt i = find_opt i !Ref._global
248 let get i = find i !Ref._global
249 let set i annot = Ref._global := add i annot !Ref._global
250
251 let set_ty i t = Ref._global := add_ty i t !Ref._global
252 let get_ty i = find_ty i !Ref._global
253 let get_ty_opt i = find_ty_opt i !Ref._global
254 let get_tsc_opt i = find_tsc_opt i !Ref._global
255
256 end
257
258 end (* module Ref *)
Something went wrong with that request. Please try again.