Skip to content
Newer
Older
100755 335 lines (295 sloc) 13.8 KB
fccc685 Initial open-source release
MLstate authored Jun 21, 2011
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 Author: 2011, François Pessaux <francois.pessaux@mlstate.com>
20 *)
21
22 (**
23 Strongly mapped on hmx_Compare.ml of the old HMX typechecker.
24 This module implements comparison on QML types with the semantics that
25 old HMX typechecker had when it first transformed QML types into HMX types
26 then compared the HMX types.
27 The idea is to remove the bridge between QML and HMX primitives since HMX
28 is not used anymore. However, QML still used some parts of HMX functions
29 for various things. That's the reason why this module exists.
30 *)
31
32 (* depends *)
33 module List = BaseList
34
35 (* shorthands *)
36 module Q = QmlAst
37
38
39
40 module TyPairSet : (BaseSetSig.S with type elt = QmlAst.ty * QmlAst.ty) =
41 BaseSet.Make (
42 struct
43 type t = QmlAst.ty * QmlAst.ty
44 let compare = Pervasives.compare
45 end
46 )
47
48
49
50 let typeident_is_abstract ti = QmlAst.TypeIdent.is_abstract ti
51
52
53
54 (**
55 sort the list of type variables [bvs] bounds in a TypeForall
56 according to the apparition order in the quantified type [t]
57 *)
58 (* TODO : extend to row and column variables *)
59 let sort_bound_vars env bvs t =
60 let rec aux memo (sbvs, bvs) t =
61 match t with
62 | Q.TypeSumSugar _ ->
63 (* They should have all disapeared. *)
64 assert false
65 | Q.TypeConst _ -> (sbvs, bvs)
66 | Q.TypeVar v ->
67 if List.mem v bvs then ((v :: sbvs), (List.remove_first v bvs))
68 else (sbvs, bvs)
69 | Q.TypeArrow (lt, u) ->
70 aux memo (List.fold_left (aux memo) (sbvs, bvs) lt) u
71 | Q.TypeRecord (Q.TyRow (fields, _)) -> aux_fields memo (sbvs, bvs) fields
72 | Q.TypeSum (Q.TyCol (l_fields, _)) ->
73 List.fold_left (aux_fields memo) (sbvs, bvs) l_fields
74 | Q.TypeName (lt, tn) ->
75 let tsc =
76 QmlTypes.Env.TypeIdent.find ~visibility_applies: true tn env in
77 let acc =
78 if List.mem t memo then (sbvs, bvs)
79 else
80 let t' = QmlTypes.Scheme.specialize ~typeident: tn ~ty: lt tsc in
81 aux (t :: memo) (sbvs, bvs) t' in
82 (* explore phantom types, because they don't appear in the body *)
83 let (vars, _, _) = QmlGenericScheme.export_unsafe tsc in
84 let (typevars, _, _) = QmlTypeVars.FreeVars.export_as_lists vars in
85 let count_t_c_freevars t _c = QmlTypes.freevars_of_ty t in
86 let phantomvars =
87 QmlGenericScheme.phantomvars_with_cache count_t_c_freevars tsc in
88 let fold_fun acc v t =
89 if QmlTypeVars.FreeVars.mem_typevar v phantomvars then aux memo acc t
90 else acc in
91 List.fold_left2 fold_fun acc typevars lt
92 | Q.TypeAbstract -> (sbvs, bvs)
93 | Q.TypeForall (_, _, _, t) -> aux memo (sbvs, bvs) t
94
95 and aux_fields memo (sbvs, bvs) fields =
96 let lt = List.map snd fields in
97 List.fold_left (aux memo) (sbvs, bvs) lt in
98
99 (* Note that it is legal to have variable not "seen", i.e. variable remaining
100 in [bvs] and not sent to [sbvs] after sorting because when a type name is
101 defined as an abstract type, since this latter doesn't have parameter,
102 parameters of the type name do not appear in the instantiation hence are
103 not "seen". As a result, they in effect are not removed from the list [bvs]
104 and not added in the list [sbvs]. *)
105 let (sbvs, _) = aux [] ([], bvs) t in
106 List.rev sbvs
107
108
109
110 let sort_row_fields fields =
111 List.sort (fun (n1, _) (n2, _) -> String.compare n1 n2) fields
112
113
114
115 let sort_col_cases (Q.TyCol (cases, ending)) =
116 (* First, for each case, sort the fields of the row forming the case. *)
117 let cases' = List.map sort_row_fields cases in
118 (* Now, sort each case according to the fields it has. *)
119 let cases'' =
120 List.sort
121 (fun case1 case2 ->
122 List.make_compare
123 (fun (n1, _) (n2, _) -> String.compare n1 n2) case1 case2)
124 cases' in
125 QmlAst.TyCol (cases'', ending)
126
127
128
129 let rec test_tys_eq env ?(bound_vars=[]) memo t1 t2 =
130 let call_aux ?(bound_vars=bound_vars) = test_tys_eq env ~bound_vars memo in
131 let is_bound v = List.mem v bound_vars in
132 if t1 == t2 then true (* speedup *) else
133 match t1, t2 with
134 | ((Q.TypeConst c), (Q.TypeConst d)) -> c = d
135 | ((Q.TypeVar v1), (Q.TypeVar v2)) when is_bound v1 && not (is_bound v2) ->
136 false
137 | ((Q.TypeVar v1), (Q.TypeVar v2)) when not (is_bound v1) && is_bound v2 ->
138 false
139 | ((Q.TypeVar v1), (Q.TypeVar v2)) -> v1 = v2
140 | ((Q.TypeArrow (lt, t)), (Q.TypeArrow (lu, u))) ->
141 ((List.length lt) = (List.length lu)) &&
142 (List.for_all2 (call_aux ~bound_vars) lt lu) &&
143 (call_aux ~bound_vars t u)
144 | ((Q.TypeSum ts), (Q.TypeSum us)) -> cmp_col env memo ts us
145 | ((Q.TypeRecord rx), (Q.TypeRecord ry)) -> cmp_row env memo rx ry
146 | (Q.TypeRecord (Q.TyRow (tfs, trv))), (Q.TypeSum (Q.TyCol (ufs, ucv))) -> (
147 match trv with
148 | Some _ -> false
149 | None ->
150 match ucv with
151 | Some _ -> false
152 | None ->
153 (* No row/column variables -> compare fields *)
154 (match ufs with
155 | [ one ] ->
156 (* To be "equal", the sum must have only 1 case. *)
157 sort_and_cmp_fields env memo tfs one
158 | _ -> false)
159 )
160 | ((Q.TypeSum _), (Q.TypeRecord _)) -> call_aux ~bound_vars t2 t1
161 | ((Q.TypeName (ts, tn)), (Q.TypeName (us, un))) ->
162 if TyPairSet.mem (t1, t2) memo then true (* already seen, assumed equal *)
163 else (
164 let memo = TyPairSet.add (t1, t2) (TyPairSet.add (t2, t1) memo) in
165 let (tn, te) =
166 QmlTypes.Env.TypeIdent.findi ~visibility_applies: true tn env in
167 let (un, ue) =
168 QmlTypes.Env.TypeIdent.findi ~visibility_applies: true un env in
169 if (typeident_is_abstract tn && typeident_is_abstract un) then (
170 (QmlAst.TypeIdent.equal tn un) &&
171 ((List.length ts) = (List.length us)) &&
172 (List.for_all2 (call_aux ~bound_vars) ts us)
173 )
174 else (
175 let comparable_by_name =
176 (QmlAst.TypeIdent.equal tn un) &&
177 ((List.length ts) = (List.length us)) &&
178 (List.for_all2 (call_aux ~bound_vars) ts us) in
179 if comparable_by_name then true
180 else (
181 let t =
182 if typeident_is_abstract tn then QmlAst.TypeName (ts, tn)
183 else QmlTypes.Scheme.specialize ~typeident: tn ~ty: ts te in
184 let u =
185 if typeident_is_abstract un then QmlAst.TypeName (us, un)
186 else QmlTypes.Scheme.specialize ~typeident: un ~ty: us ue in
187 (* FPE: Dirty fix for ticket OPA-485. In fact, when comparing
188 1 type named different, testing if they are both abstract
189 (hence not equal) usign the above:
190 [(typeident_is_abstract tn && typeident_is_abstract un)]
191 is wrong. This test only check the tag of the ident. With
192 new @private and @abstract types, this tag seems not to be
193 informed wether a type is @abstract or @private. Hence, it
194 doesn't see that the types are @abstract and continues testing
195 on their structure. Since their structure are both
196 [QmlAstTypeAbstract], we go in the case where types are == and
197 and then the 2 different abstract types finally are considered
198 equal, which is totally wrong.
199 So, when we arrive here, we know that both named types have
200 not already be seen, have different names, the test on wether
201 they are both abstract based on their idents failed, so we
202 ensure that the bodies of the schemes bound to these 2 different
203 named types are not both [QmlAst.TypeAbstract]. If they are not,
204 we can safely recurse, otherwise, if they are both, we know
205 that they are 2 different named types abstract hence they are
206 not equal.
207 A better fix should be to make the tags in the ident consistent
208 with the new notion of @abstract / @private types. I don't know
209 if this is possible since such types are not abstract in their
210 definition package and are either not visible or abstract outside
211 their definition package. So I don't know yet if the mechanism
212 of tags in idents can support this change od status.
213 Other solution, may be remove the tags in idents mechanism if
214 this has no real meaning or is not consistent.
215 This issue is to be investigated to finally arrive to a better
216 fix of the ticket OPA-485. *)
217 if (t = QmlAst.TypeAbstract) && (u = QmlAst.TypeAbstract) then false
218 else test_tys_eq env ~bound_vars memo t u
219 )
220 )
221 )
222 | ((Q.TypeForall _), _) | (_, (Q.TypeForall _)) ->
223 (* let env_vars = env.Hmx_env.freevars_of_idents in *)
224 let t = (* generalize_in_type env_vars *) t1 in
225 let u = (* generalize_in_type env_vars *) t2 in
226 let res = (
227 match (t, u) with
228 | Q.TypeForall (t_bvs, t_row_vars, t_col_vars, t),
229 Q.TypeForall (u_bvs, _, _, u) ->
230 (* TODO : comparision is not correct !!! *)
231 (* quantification over row and column variables is not handled *)
232 let t_bvs = sort_bound_vars env t_bvs t in
233 let u_bvs = sort_bound_vars env u_bvs u in
234 if (List.length t_bvs) <> (List.length u_bvs) then false
235 else (
236 (* At this point, we are sure that the lists of quantified vars
237 are the same length. So we can safely transform the type t
238 into a pseudo scheme, call QmlTypes.instantiate on it with
239 a fake type ident since lists of quantified vars being the
240 same length, we won't get an error, so the fake ident won't
241 respring. *)
242 let fake_ident =
243 QmlAst.TypeIdent.of_string "__icmpty_broken_if_seen " in
244 let fake_quantif =
245 QmlTypeVars.FreeVars.add_list
246 (t_bvs, t_row_vars, t_col_vars) QmlTypeVars.FreeVars.empty in
247 let fake_sch = QmlGenericScheme.import fake_quantif t () in
248 let fake_ml_vars = List.map (fun v -> QmlAst.TypeVar v) t_bvs in
249 let fake_row_vars =
250 List.map (fun v -> QmlAst.TyRow ([], (Some v))) t_row_vars in
251 (* Instantiate the pseudo scheme built from the body of t.
252 Instantiation is done by replacing its variables by those of
253 u. *)
254 let t =
255 QmlTypes.Scheme.specialize
256 ~typeident: fake_ident ~ty: fake_ml_vars
257 ~ty_row: fake_row_vars fake_sch in
258 call_aux ~bound_vars: (t_bvs @ bound_vars) t u
259 )
260 | ((Q.TypeForall _), _) | (_, (Q.TypeForall _)) -> false
261 | _ -> assert false (* at least one of them should be a TypeForall *)
262 ) in
263 res
264 | ((Q.TypeName (ts, tn)), u) ->
265 (* beware of type 'a nil = {nil:unit}, then int nil = float nil *)
266 if TyPairSet.mem (t1, t2) memo then false
267 else (
268 let memo = TyPairSet.add (t1, t2) memo in
269 let (tn, te) =
270 QmlTypes.Env.TypeIdent.findi ~visibility_applies: true tn env in
271 if typeident_is_abstract tn then false
272 else (
273 let t = QmlTypes.Scheme.specialize ~typeident: tn ~ty: ts te in
274 test_tys_eq env memo t u
275 )
276 )
277 | (_, (Q.TypeName (_, _))) -> call_aux ~bound_vars t2 t1
278 | (Q.TypeAbstract, _) | (_, Q.TypeAbstract) -> false
279 | (_, _) ->
280 (* Different constructors or not matching extern abstract type:
281 fall back on Pervasives' comparison *)
282 t1 = t2
283
284
285
286 and sort_and_cmp_fields env memo tfs ufs =
287 let cmp_field (tfn, tft) (ufn, uft) =
288 (tfn = ufn) && (test_tys_eq env memo tft uft) in
289 (* First, compare lists lengths. *)
290 if (List.length tfs) <> (List.length ufs) then false
291 else (
292 (* Sort the fields by name. *)
293 let tfs' = sort_row_fields tfs in
294 let ufs' = sort_row_fields ufs in
295 List.for_all2 cmp_field tfs' ufs'
296 )
297
298
299
300
301 (* Fields will be sorted by name by calling [sort_and_cmp_fields]. No need
302 to sort them in this function. *)
303 and cmp_row env memo (Q.TyRow (tfs, tv)) (Q.TyRow (ufs, uv)) =
304 let row_var_eq =
305 (match (tv, uv) with
306 | (None, None) -> true
307 | (None, (Some _)) | ((Some _), None) -> false
308 | ((Some v1), (Some v2)) -> (QmlAst.RowVar.equal v1 v2)) in
309 row_var_eq && (sort_and_cmp_fields env memo tfs ufs)
310
311
312
313 (* Since to sort cases, we need to sort fields of each row forming a case,
314 to avoid sorting several times, we don't use [cmp_row] and
315 [sort_and_cmp_fields] and directly sort the whole column in one shot here. *)
316 and cmp_col env memo (Q.TyCol (_tfs, tv) as tcol) (Q.TyCol (_ufs, uv) as ucol) =
317 let col_var_eq =
318 (match (tv, uv) with
319 | (None, None) -> true
320 | (None, (Some _)) | ((Some _), None) -> false
321 | ((Some v1), (Some v2)) -> QmlAst.ColVar.equal v1 v2) in
322 if not col_var_eq then false
323 else (
324 (* Sort the cases. *)
325 let tcol = sort_col_cases tcol in
326 let ucol = sort_col_cases ucol in
327 let ts = Q.column_to_records tcol in
328 let us = Q.column_to_records ucol in
329 ((List.length ts) = (List.length us)) &&
330 (List.for_all2 (test_tys_eq env memo) ts us)
331 )
332
333
334 let equal_ty env t u = test_tys_eq env TyPairSet.empty t u
Something went wrong with that request. Please try again.