Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 905 lines (796 sloc) 33.832 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 (* cf mli *)
20 (* depends *)
21 module List = BaseList
22
23 (* shorthands *)
24 module Q = QmlAst
25 module QTV = QmlTypeVars
26
27 (* aliases *)
28 module TypeIdent = QmlAst.TypeIdent
29 module TypeIdentMap = QmlAst.TypeIdentMap
30
31 module FreeVars = QmlTypeVars.FreeVars
32 module TypeVar = QmlTypeVars.TypeVar
33 module RowVar = QmlTypeVars.RowVar
34 module ColVar = QmlTypeVars.ColVar
35
36 module TypeVarSet = QmlTypeVars.TypeVarSet
37 module RowVarSet = QmlTypeVars.RowVarSet
38 module ColVarSet = QmlTypeVars.ColVarSet
39
40 module RowVarMap = QmlTypeVars.RowVarMap
41 module ColVarMap = QmlTypeVars.ColVarMap
42 module TypeVarMap = QmlTypeVars.TypeVarMap
43
44 let (@*) = InfixOperator.(@*)
45 (* -- *)
46
47 type error = TyperError of Q.code_elt * (exn * exn list) (** guard for a non empty list *)
48 exception Exception of error
49
50 let warning fmt = OManager.warning ~wclass:QmlTyperWarnings.typer fmt
51
52 let type_err_raise t exn =
53 let loc =
54 QmlTyperException.loc_make (`Ty_loc t) QmlTyperException.loc_set_empty
55 in
56 raise (QmlTyperException.Exception (loc, exn))
57
58 let invalidTypeDefinition (tvars, tname, ty) =
59 let typedef = Q.TypeName (List.map (fun t -> Q.TypeVar t) tvars, tname) in
60 QmlTyperException.InvalidTypeDefinition (typedef, ty)
61
62 type bypass_typer = BslKey.t -> Q.ty option
63 type typescheme = (Q.ty, unit) QmlGenericScheme.tsc (* no constraints in public env *)
64
65 module ImplFieldMap = SetMap.Make(String)(TypeIdent)
66 module ImplFieldMapQuick = SetMap.Make(StringSet)(TypeIdent)
67
b12589b fpessaux [feature] Typer: Height of type abbreviation to balance unwinding during...
fpessaux authored
68 type abbrev_height = int
69
fccc685 Initial open-source release
MLstate authored
70 type gamma = {
71 ident : typescheme IdentMap.t ;
b12589b fpessaux [feature] Typer: Height of type abbreviation to balance unwinding during...
fpessaux authored
72 type_ident :
73 (typescheme * abbrev_height * QmlAst.type_def_visibility) TypeIdentMap.t ;
fccc685 Initial open-source release
MLstate authored
74 field_map : ImplFieldMap.t ;
75 field_map_quick : ImplFieldMapQuick.t ;
76 }
77
78
79 type options =
80 {
81 explicit_instantiation : bool;
82 value_restriction : [`disabled|`normal|`strict];
83 }
84
85 let default_options =
86 {
87 explicit_instantiation = true; (* in case Explicit Instantiation used *)
88 value_restriction = `disabled; (* in case value restriction used *)
89 }
90
91 module type QML_LOW_LEVEL_TYPER =
92 sig
93 val type_of_expr :
94 ?options : options ->
95 ?annotmap : Q.annotmap ->
96 bypass_typer : bypass_typer ->
97 gamma: gamma ->
98 Q.expr ->
99 gamma * Q.annotmap * Q.ty
100
101 (* Voir mli *)
102 end
103 (** empty *)
104 let gamma_empty = {
105 ident = IdentMap.empty ;
106 type_ident = TypeIdentMap.empty ;
107 field_map = ImplFieldMap.empty ;
108 field_map_quick = ImplFieldMapQuick.empty ;
109 }
110
111 let rec ty_ty ~with_forall ~free = function
112 | Q.TypeAbstract
113 | Q.TypeConst _ -> free
114 | Q.TypeVar typevar -> FreeVars.add_ty typevar free
115 | Q.TypeArrow (le1, e2) ->
116 let free = ty_ty_list ~with_forall ~free le1 in
117 ty_ty ~with_forall ~free e2
118 | Q.TypeRecord _ty_row -> ty_row ~with_forall ~free _ty_row
119 | Q.TypeName (params, _) -> ty_ty_list ~with_forall ~free params
120 | Q.TypeSum sum -> ty_sums ~with_forall ~free sum
121 | Q.TypeSumSugar sum -> ty_sums_sugar ~with_forall ~free sum
122 | Q.TypeForall (vars, rvars, cvars, t) ->
123 if with_forall
124 then ty_ty ~with_forall ~free t
125 else
126 let ts = TypeVarSet.from_list vars in
127 let rs = RowVarSet.from_list rvars in
128 let cs = ColVarSet.from_list cvars in
129 let vars = FreeVars.import_from_sets ts rs cs in
130 FreeVars.diff (ty_ty ~with_forall ~free t) vars
131
132 and ty_ty_list ~with_forall ~free tyl =
133 List.fold_left (fun free -> ty_ty ~with_forall ~free) free tyl
134
135 and ty_row ~with_forall ~free (Q.TyRow (fields, rv)) =
136 let free = List.fold_left (fun free (_, tau) -> ty_ty ~with_forall ~free tau) free fields in
137 let free = Option.default_map free (fun v -> FreeVars.add_row v free) rv
138 in free
139
140 and ty_sums ~with_forall ~free sum =
141 let Q.TyCol (_, cv) = sum in
142 let free = Option.default_map free (fun v -> FreeVars.add_col v free) cv in
143 let lt = Q.column_to_records sum in
144 List.fold_left (fun free _ty -> ty_ty ~with_forall ~free _ty) free lt
145
146 and ty_sums_sugar ~with_forall ~free sum =
147 List.fold_left (fun free _ty -> ty_ty ~with_forall ~free _ty) free sum
148
149 let freevars_of_ty ?(with_forall=false) ?(free=FreeVars.empty) t =
150 ty_ty ~with_forall ~free t
151 let freevars_of_row ?(with_forall=false) ?(free=FreeVars.empty) t =
152 ty_row ~with_forall ~free t
153 let freevars_of_col ?(with_forall=false) ?(free=FreeVars.empty) t =
154 ty_sums ~with_forall ~free t
155
156 let freevars_of_typescheme =
157 let f body () = freevars_of_ty body in
158 QmlGenericScheme.freevars_with_cache f
159
160 let freevars_of_gamma g =
161 let free = FreeVars.empty in
162 let free = IdentMap.fold (fun _ sh acc -> let free = freevars_of_typescheme sh in FreeVars.union acc free) g.ident free in
163 free
164
165 (** a function to specialize types from 3 functions of maping for typevars *)
166 (** for rows and cols, it DOES NOT perform the merge (merge in map_row and map_col if you want) *)
167 let map_vars_of_ty map_ty map_row map_col =
168 let ty_row ((Q.TyRow (_, rv)) as row) =
169 Option.default_map row (map_row row) rv
170 and ty_sums ((Q.TyCol (_, cv)) as col) =
171 Option.default_map col (map_col col) cv
172 in
173 QmlAstWalk.Type.map_up
174 (function
175 | (Q.TypeVar v) as ty -> map_ty ty v
176 | Q.TypeRecord row -> Q.TypeRecord (ty_row row)
177 | Q.TypeSum sum -> Q.TypeSum (ty_sums sum)
178 | ty -> ty)
179
180 module Scheme =
181 struct
182 type t = typescheme
fd1d3d6 [enhance] qmlTypes: add renaming possibility with refresh of typescheme
Valentin Gatien-Baron authored
183 type renaming = TypeVar.t TypeVarMap.t * RowVar.t RowVarMap.t * ColVar.t ColVarMap.t
fccc685 Initial open-source release
MLstate authored
184
fd1d3d6 [enhance] qmlTypes: add renaming possibility with refresh of typescheme
Valentin Gatien-Baron authored
185 let empty_renaming = (TypeVarMap.empty,RowVarMap.empty,ColVarMap.empty)
fccc685 Initial open-source release
MLstate authored
186 let next v = QmlGenericScheme.import FreeVars.empty (Q.TypeVar v) ()
187
188 (* TODO: we will also need a version which keeps track between runs
189 which variable is changed to which, e.g. to rename user-written
190 vars consistently in a freshly parsed code. It may be good
191 to write the general function and then instantiate it for
192 typesheme refresh below
193 *)
fd1d3d6 [enhance] qmlTypes: add renaming possibility with refresh of typescheme
Valentin Gatien-Baron authored
194 let refresh_quantifier_and_renaming s =
fccc685 Initial open-source release
MLstate authored
195 let ordered_quantif = QmlGenericScheme.export_ordered_quantif s in
196 (** BEWARE : refreshing set and ordered quantification with coherence *)
197 let typevarmap, new_typevar =
198 (* we fold over ordered_quantif, to reflect the order of vars
199 by the order in which we generate them (and so the order in the set);
200 to keep it correct, refresh has to be performed in the order given
201 and generate variables which are stricly greater than any
202 variables generated before (e.g. using a global counter) *)
203 List.fold_left (fun (map, set) elt ->
204 let index = TypeVar.refresh elt in
205 let map = TypeVarMap.add elt index map in
206 let set = TypeVarSet.add index set in
207 (map, set))
208 (TypeVarMap.empty, TypeVarSet.empty)
209 ordered_quantif.QTV.typevar
210 in
211 let rowvarmap, new_rowvar =
212 List.fold_left (fun (map, set) elt ->
213 let index = RowVar.refresh elt in
214 let map = RowVarMap.add elt index map in
215 let set = RowVarSet.add index set in
216 (map, set))
217 (RowVarMap.empty, RowVarSet.empty)
218 ordered_quantif.QTV.rowvar
219 in
220 let colvarmap, new_colvar =
221 List.fold_left (fun (map, set) elt ->
222 let index = ColVar.refresh elt in
223 let map = ColVarMap.add elt index map in
224 let set = ColVarSet.add index set in
225 (map, set))
226 (ColVarMap.empty, ColVarSet.empty)
227 ordered_quantif.QTV.colvar
228 in
229 let new_quantif =
230 { QTV.
231 typevar = new_typevar;
232 rowvar = new_rowvar;
233 colvar = new_colvar
234 } in
fd1d3d6 [enhance] qmlTypes: add renaming possibility with refresh of typescheme
Valentin Gatien-Baron authored
235 new_quantif, (typevarmap, rowvarmap, colvarmap)
236
237 let apply_renaming (((typevarmap, rowvarmap, colvarmap) as renaming) : renaming) ty =
238 if renaming = empty_renaming then ty else (
239 (** /!\ Beware here, use the refresh substitution to refresh all variable
240 according to the new quantification *)
241 let map_ty ty v =
242 match TypeVarMap.find_opt v typevarmap with
243 | Some t -> Q.TypeVar t
244 | None -> ty
245 in
246 let map_row ((Q.TyRow (r, _)) as row) v =
247 match RowVarMap.find_opt v rowvarmap with
248 | Some t -> Q.TyRow (r, Some t)
249 | None -> row
250 in
251 let map_col ((Q.TyCol (l, _)) as col) v =
252 match ColVarMap.find_opt v colvarmap with
253 | Some t -> Q.TyCol (l, Some t)
254 | None -> col
255 in
256 map_vars_of_ty map_ty map_row map_col ty
257 )
258
259 let refresh_and_renaming s =
260 let new_quantif, renaming = refresh_quantifier_and_renaming s in
fccc685 Initial open-source release
MLstate authored
261 let (_, body, ()) = QmlGenericScheme.export_unsafe s in
fd1d3d6 [enhance] qmlTypes: add renaming possibility with refresh of typescheme
Valentin Gatien-Baron authored
262 let new_body = apply_renaming renaming body in
263 let new_s = QmlGenericScheme.import new_quantif new_body () in
264 new_s, renaming
265
266 let refresh s =
267 fst (refresh_and_renaming s)
fccc685 Initial open-source release
MLstate authored
268
269 let instantiate t =
270 let s = refresh t in
271 let (_, body, ()) = QmlGenericScheme.export_unsafe s in
272 body
273
274 let export t =
275 let t = refresh t in
276 let ordered_quantif = QmlGenericScheme.export_ordered_quantif t in
277 (ordered_quantif.QTV.typevar,
278 ordered_quantif.QTV.rowvar,
279 ordered_quantif.QTV.colvar),
280 let (_, body, ()) = QmlGenericScheme.export_unsafe t in
281 body
282
283 let generalize gamma ty =
284 let free_ty = freevars_of_ty ty in
285 let free_gamma = freevars_of_gamma gamma in
286 let quantif = FreeVars.diff free_ty free_gamma in
287 QmlGenericScheme.import quantif ty ()
288
289 let quantify ty =
290 let quantif = freevars_of_ty ty in
291 QmlGenericScheme.import quantif ty ()
292
293
294
295 (* ************************************************************************ *)
296 (** We check that for recursive type definitions the recursive reference
297 uses the same type parameters, i.e.:
298 type 'a t = ... 'b t ..., if a <> b raises InvalidTypeUsage
299 We check that the type definition is not trivially cyclic, i.e we forbid
300 type t('a) = t('a).
301 We check that sum types do not have cases containing the same labels,
302 i.e. we forbid
303 type t = { A } / { B } / { A }
304 type t = { A; B } / { A; B }
305 type t = { A : int } / { A : char }
306 but we do not forbid
307 type t = { A; B } / { A; C }
308 type t = { A; B } / { A } *)
309 (* ************************************************************************ *)
310 (* TODO: This will have to be extended to mutually recursive types, once those are
311 handled properly *)
312 let check_definition tname tvars ty =
313 let rec check_row (Q.TyRow (fields, _)) =
314 List.iter (check ~top:false @* snd) fields
315
316 and check_col (Q.TyCol (l, _)) =
317 let seen_sum_cases = ref [] in
318 List.iter
319 (fun a_case_fields ->
320 (* For the current case of the sum, check the fields making this case
321 and by the way, recover all the labels presents in the record
322 forming this case. *)
323 let the_case_labels =
324 List.map
325 (fun (label, field_ty) ->
326 (* Recursively check the type of the label. *)
327 check ~top: false field_ty ;
328 (* Return the label found for this field of the row. *)
329 label)
330 a_case_fields in
331 (* Now, sort the labels of this case of the sum to compare them with
332 those already found for the other cases of the sum type. *)
333 let the_case_labels_sorted = List.sort compare the_case_labels in
334 if not (List.mem the_case_labels_sorted !seen_sum_cases) then
335 seen_sum_cases := the_case_labels_sorted :: !seen_sum_cases
336 else
337 let exc = invalidTypeDefinition (tvars, tname, ty) in
338 type_err_raise ty exc)
339 l
340
341
342 and check ?(top=false) t =
343 match t with
344 | Q.TypeConst _ | Q.TypeVar _ -> ()
345 | Q.TypeArrow (lt, u) ->
346 List.iter check lt;
347 check u
348 | Q.TypeSumSugar s -> List.iter check s
349 | Q.TypeSum col -> check_col col
350 | Q.TypeRecord r -> check_row r
351 | Q.TypeName (vars, name) ->
352 List.iter check vars ;
7b03dd4 fpessaux [cleanup] QML types: Finally, TypeIdent are now regular Ident.
fpessaux authored
353 if TypeIdent.equal name tname then
fccc685 Initial open-source release
MLstate authored
354 let ok =
355 if ty == t then (
356 (* We want to reject definitions trivially cyclic like
357 type t = t. This is the case when the initial type expression
358 is the same than the current one. *)
359 false
360 )
361 else (
362 try
363 let c = List.combine tvars vars in
364 let pos_ok (v, t) =
365 match t with
366 | Q.TypeVar v' -> TypeVar.equal v v'
367 | _ -> false in
368 List.for_all pos_ok c
369 with Invalid_argument "List.combine" -> false) in
370 if not ok then
371 let exc = invalidTypeDefinition (tvars, tname, ty) in
372 type_err_raise t exc
373 | Q.TypeAbstract ->
374 if (not top) then
375 let exc =
376 QmlTyperException.InvalidType (ty, `abstract_in_ty_annotation) in
377 type_err_raise t exc (* "abstract" nested inside a type def *)
378 | Q.TypeForall (_, _, _, t) -> check t
379 in
380 let rec repeated_var = function
381 | [] -> false
382 | x::xs -> List.exists (fun y -> TypeVar.equal x y) xs || repeated_var xs
383 in
384 if repeated_var tvars then
385 let exc = invalidTypeDefinition (tvars, tname, ty) in
386 type_err_raise ty exc
387 else
388 check ~top:true ty
389
390 let definition_no_check ?(typevar=[]) ?(ty_row=[]) tname typ =
391 let error () =
392 let exn = invalidTypeDefinition (typevar, tname, typ) in
393 type_err_raise typ exn
394 in
395 let build_typevar = List.fold_left
396 (fun free v ->
397 if TypeVarSet.mem v free then error ()
398 else TypeVarSet.add v free
399 ) TypeVarSet.empty
400 in
401 let build_rowvar = List.fold_left
402 (fun free v ->
403 if RowVarSet.mem v free then error ()
404 else RowVarSet.add v free
405 ) RowVarSet.empty
406 in
407 let ty_params = build_typevar typevar in
408 let row_params = build_rowvar ty_row in
409
410 let free = freevars_of_ty typ in
411 let new_free =
412 { QTV.
413 typevar = ty_params;
414 rowvar = row_params;
415 colvar = ColVarSet.empty
416 }
417 in
418
419 if
420 TypeVarSet.subset free.QTV.typevar ty_params
421 (* for now other kinds of variables are forbidden in type defs: *)
422 && RowVarSet.is_empty free.QTV.rowvar
423 then
424 (* TODO: why do we refresh here? isn't it enough to refresh at each access *)
425 refresh (QmlGenericScheme.import new_free typ ())
426
427 else error ()
428
429 let definition ?(typevar=[]) ?(ty_row=[]) tname typ =
430 check_definition tname typevar typ;
431 definition_no_check ~typevar ~ty_row tname typ
432
433 (* we could also specialize column variables if needed *)
434 let specialize ~typeident ?(ty=[]) ?(ty_row=[]) s =
435 let error () =
436 let exn = QmlTyperException.InvalidTypeUsage (typeident, (QmlGenericScheme.export_ordered_quantif s).QTV.typevar, ty) in
437 let (_, body, ()) = QmlGenericScheme.export_unsafe s in
438 type_err_raise body exn
439 in
440 (* The different maps are built from a fold_left2 between parameters provided and the
441 ordered representation of the quantification
442 Any problem by doing the fold_left2 means that the arity of type constructors are not respected
443 We raise error when instantiating type with too many or too few parameters,
444 but not with no parameters, since it is a nice abbreviation (e.g., [] : list, means [] : 'a list) *)
445 let typevarmap, rowvarmap =
446 try
447 let build cons add empty refresh a b =
448 let a, b =
449 match a, b with
450 | _::_, [] ->
451 (** this is the case we want to allow *)
452 a, List.map (fun var -> cons (refresh var)) a
453 | _, _ -> a, b in
454
455 List.fold_left2 (fun map index ty -> add index ty map) empty a b in
456
457 let typevar_refresh = TypeVar.refresh in
458 let rowvar_refresh = RowVar.refresh in
459 build (fun s -> Q.TypeVar s) TypeVarMap.add TypeVarMap.empty typevar_refresh (QmlGenericScheme.export_ordered_quantif s).QTV.typevar ty,
460 build (fun s -> Q.TyRow ([], Some s)) RowVarMap.add RowVarMap.empty rowvar_refresh (QmlGenericScheme.export_ordered_quantif s).QTV.rowvar ty_row
461 with
462 | Invalid_argument _ -> error ()
463 in
464 let map_ty ty v = Option.default ty (TypeVarMap.find_opt v typevarmap) in
465 let map_row row v =
466 match RowVarMap.find_opt v rowvarmap with
467 | Some t ->
468 let cmp_fields (f1, _) (f2, _) = String.compare f1 f2 in
469 let Q.TyRow (fields1, _) = row in
470 let Q.TyRow (fields2, rv) = t in
471 let fields = List.uniq_unsorted ~cmp:cmp_fields
472 (fields1 @ fields2) in (* so we prefer duplicates from fields1 rather than from fields2 *)
473 Q.TyRow (fields, rv)
474 | None -> row in
475 let (_, body, ()) = QmlGenericScheme.export_unsafe s in
476 map_vars_of_ty map_ty map_row (fun col _ -> col) body
477
7b03dd4 fpessaux [cleanup] QML types: Finally, TypeIdent are now regular Ident.
fpessaux authored
478 let id ty = QmlGenericScheme.import FreeVars.empty ty ()
fccc685 Initial open-source release
MLstate authored
479
480 let explicit_forall tsc =
481 let (tv,rv,cv),ty = export tsc in
482 match tv,rv,cv with
483 | [],[],[] -> ty
484 | _ -> Q.TypeForall(tv,rv,cv,ty)
485
486 end
487
488 module Env =
489 struct
490 type t = gamma
491 let empty = gamma_empty
492 module Ident =
493 struct
494 let find_opt id g = IdentMap.find_opt id g.ident
495 let find id g = match find_opt id g with
496 | Some t -> t
497 | None ->
498 raise (QmlTyperException.Exception
499 (QmlTyperException.loc_empty,
7b03dd4 fpessaux [cleanup] QML types: Finally, TypeIdent are now regular Ident.
fpessaux authored
500 QmlTyperException.IdentifierNotFound
501 (id, IdentMap.keys g.ident)))
fccc685 Initial open-source release
MLstate authored
502 let add id s g = { g with ident = IdentMap.add id s g.ident }
503 let remove id g = { g with ident = IdentMap.remove id g.ident }
504 let mem id g = IdentMap.mem id g.ident
505 let iter f g = IdentMap.iter f g.ident
506 let fold f g = IdentMap.fold f g.ident
507 let map f g = {g with ident = IdentMap.map f g.ident}
508 let fold_map f gamma acc =
509 let acc, ident = IdentMap.fold_map f gamma.ident acc in
510 acc, {gamma with ident = ident}
511 let from_map map gamma =
512 {gamma with ident = map}
513 let to_map gamma = gamma.ident
514 let pp f gamma =
515 iter (fun ident tsc ->
516 Format.fprintf f "@[<2>%s -> %a@]@\n" (Ident.to_string ident) QmlPrint.pp#tsc tsc
517 ) gamma
518 end
519
520 module TypeIdent =
521 struct
522 module T = TypeIdent
523
524 (** [TODO] Documentation. *)
b12589b fpessaux [feature] Typer: Height of type abbreviation to balance unwinding during...
fpessaux authored
525 let apply_visibility scheme abbrev_height = function
526 | QmlAst.TDV_public -> Some (scheme, abbrev_height)
fccc685 Initial open-source release
MLstate authored
527 | QmlAst.TDV_private package ->
528 (* Since types private to a package are not visible at all from
529 other packages, this type must be considered as non-existant
530 if we are not in its definition package. *)
531 if package <> (ObjectFiles.get_current_package_name ()) then None
b12589b fpessaux [feature] Typer: Height of type abbreviation to balance unwinding during...
fpessaux authored
532 else Some (scheme, abbrev_height)
fccc685 Initial open-source release
MLstate authored
533 | QmlAst.TDV_abstract package ->
534 (* If we are not in the type's definition package, then it
535 must be considered as abstract. *)
536 if package <> (ObjectFiles.get_current_package_name ()) then (
537 (* Turn the body of the scheme into a [TypeAbstract]. *)
538 let (quantif, _, constraints) =
539 QmlGenericScheme.export_unsafe scheme in
540 Some
b12589b fpessaux [feature] Typer: Height of type abbreviation to balance unwinding during...
fpessaux authored
541 ((QmlGenericScheme.import quantif
542 QmlAst.TypeAbstract constraints),
543 0)
fccc685 Initial open-source release
MLstate authored
544 )
b12589b fpessaux [feature] Typer: Height of type abbreviation to balance unwinding during...
fpessaux authored
545 else Some (scheme, abbrev_height)
fccc685 Initial open-source release
MLstate authored
546
547 (** [TODO] Documentation of [~visibility_applies] for passes that anyway
548 need to see types' structure once the typechecker ensured these types,
549 even not visible are used in a consistent way. *)
550 let find_opt ~visibility_applies id g =
7b03dd4 fpessaux [cleanup] QML types: Finally, TypeIdent are now regular Ident.
fpessaux authored
551 let opt_found = TypeIdentMap.find_opt id g.type_ident in
fccc685 Initial open-source release
MLstate authored
552 match opt_found with
553 | None -> None
b12589b fpessaux [feature] Typer: Height of type abbreviation to balance unwinding during...
fpessaux authored
554 | Some (sch, abbrev_height, visibility) ->
555 if visibility_applies then
556 apply_visibility sch abbrev_height visibility
557 else Some (sch, abbrev_height)
fccc685 Initial open-source release
MLstate authored
558
559 let findi_opt ~visibility_applies id g =
7b03dd4 fpessaux [cleanup] QML types: Finally, TypeIdent are now regular Ident.
fpessaux authored
560 let opt_found = TypeIdentMap.findi_opt id g.type_ident in
fccc685 Initial open-source release
MLstate authored
561 match opt_found with
562 | None -> None
b12589b fpessaux [feature] Typer: Height of type abbreviation to balance unwinding during...
fpessaux authored
563 | Some (i, (sch, abbrev_height, visibility)) -> (
564 if not visibility_applies then Some (i, (sch, abbrev_height))
fccc685 Initial open-source release
MLstate authored
565 else
b12589b fpessaux [feature] Typer: Height of type abbreviation to balance unwinding during...
fpessaux authored
566 match apply_visibility sch abbrev_height visibility with
fccc685 Initial open-source release
MLstate authored
567 | None -> None
568 | Some sch' -> Some (i, sch')
569 )
570
571 let find ~visibility_applies id g =
572 Option.get_exn
573 (QmlTyperException.Exception
574 (QmlTyperException.loc_empty,
575 QmlTyperException.TypeIdentNotFound id))
576 (find_opt ~visibility_applies id g)
577 let findi ~visibility_applies id g =
578 Option.get_exn
579 (QmlTyperException.Exception
580 (QmlTyperException.loc_empty,
581 QmlTyperException.TypeIdentNotFound id))
582 (findi_opt ~visibility_applies id g)
583
584
585 (* ********************************************************************** *)
586 (** {b Descr}: See .mli file.
587 {b Visibility}: Exported outside this module. *)
588 (* ********************************************************************** *)
589 let raw_find id g =
590 (* Since we return both the bound scheme and its visibility information,
591 fetch in the environment is done ignoring visibility. *)
7b03dd4 fpessaux [cleanup] QML types: Finally, TypeIdent are now regular Ident.
fpessaux authored
592 let opt_found = TypeIdentMap.find_opt id g.type_ident in
fccc685 Initial open-source release
MLstate authored
593 Option.get_exn
594 (QmlTyperException.Exception
595 (QmlTyperException.loc_empty,
596 QmlTyperException.TypeIdentNotFound id))
597 opt_found
598
599
600 let records_field_names t =
601 let handle_ty_row acc (Q.TyRow (fields, _)) =
602 let handle_field_t acc (name, _) = name :: acc in
603 List.fold_left handle_field_t acc fields
604 in
605 let rec handle_ty acc = function
606 | Q.TypeSum (Q.TyCol (l, _)) ->
607 List.flatten (List.map (List.map fst) l) @ acc
608 | Q.TypeSumSugar sum ->
609 List.fold_left handle_ty acc sum
610 | Q.TypeRecord r -> handle_ty_row acc r
611 | _ -> acc (* record cannot have any other unnamed type *)
612 in handle_ty [] t
613
614 let records_field_names_quick t =
615 let handle_ty_row (Q.TyRow (fields, _)) = List.map fst fields in
616 let rec handle_ty acc = function
617 | Q.TypeSum (Q.TyCol (l, _)) ->
618 List.map (List.map fst) l @ acc
619 | Q.TypeSumSugar sum ->
620 List.fold_left handle_ty acc sum
621 | Q.TypeRecord r -> handle_ty_row r :: acc
622 | _ -> acc (* record cannot have any other unnamed type *)
623 in handle_ty [] t
624
b12589b fpessaux [feature] Typer: Height of type abbreviation to balance unwinding during...
fpessaux authored
625 let add id (s, abbrev_height, visibility) g =
fccc685 Initial open-source release
MLstate authored
626 let field_map =
4d93efa fpessaux [cleanup] QML types: No more "externality" test based on TypeIdent tag.
fpessaux authored
627 (* Update field map : only in the case of type sum and type record.
628 Abstract type are obviously skipped. *)
629 let fields =
630 let (_, ty) = Scheme.export s in
631 records_field_names ty in
632 List.fold_left
633 (fun map f -> ImplFieldMap.add f id map) g.field_map fields in
fccc685 Initial open-source release
MLstate authored
634 let field_map_quick =
4d93efa fpessaux [cleanup] QML types: No more "externality" test based on TypeIdent tag.
fpessaux authored
635 (* Update field map : only in the case of type sum and type record. *)
636 let fields =
7b03dd4 fpessaux [cleanup] QML types: Finally, TypeIdent are now regular Ident.
fpessaux authored
637 let (_, ty) = Scheme.export s in
4d93efa fpessaux [cleanup] QML types: No more "externality" test based on TypeIdent tag.
fpessaux authored
638 records_field_names_quick ty in
639 let fields = List.map StringSet.from_list fields in
640 List.fold_left
641 (fun map f -> ImplFieldMapQuick.add f id map)
642 g.field_map_quick fields in
b12589b fpessaux [feature] Typer: Height of type abbreviation to balance unwinding during...
fpessaux authored
643 let type_ident =
644 TypeIdentMap.add id (s, abbrev_height, visibility) g.type_ident in
47dc97c fpessaux [cleanup] QML typer: Removed duplication TypeIdentMap/TypeIdentPreciseMa...
fpessaux authored
645 { g with
4d93efa fpessaux [cleanup] QML types: No more "externality" test based on TypeIdent tag.
fpessaux authored
646 type_ident = type_ident ; field_map = field_map ;
647 field_map_quick = field_map_quick }
fccc685 Initial open-source release
MLstate authored
648
7b03dd4 fpessaux [cleanup] QML types: Finally, TypeIdent are now regular Ident.
fpessaux authored
649 let mem id g = TypeIdentMap.mem id g.type_ident
fccc685 Initial open-source release
MLstate authored
650
47dc97c fpessaux [cleanup] QML typer: Removed duplication TypeIdentMap/TypeIdentPreciseMa...
fpessaux authored
651 let iter f g = TypeIdentMap.iter f g.type_ident
fccc685 Initial open-source release
MLstate authored
652
47dc97c fpessaux [cleanup] QML typer: Removed duplication TypeIdentMap/TypeIdentPreciseMa...
fpessaux authored
653 let fold f g = TypeIdentMap.fold f g.type_ident
fccc685 Initial open-source release
MLstate authored
654
655 let to_list gamma = TypeIdentMap.to_list gamma.type_ident
656
657 let fold_map f gamma acc =
658 let acc, type_ident = TypeIdentMap.fold_map f gamma.type_ident acc in
47dc97c fpessaux [cleanup] QML typer: Removed duplication TypeIdentMap/TypeIdentPreciseMa...
fpessaux authored
659 (acc, {gamma with type_ident = type_ident })
660
fccc685 Initial open-source release
MLstate authored
661 let map f gamma =
662 let type_ident = TypeIdentMap.map f gamma.type_ident in
47dc97c fpessaux [cleanup] QML typer: Removed duplication TypeIdentMap/TypeIdentPreciseMa...
fpessaux authored
663 { gamma with type_ident = type_ident }
fccc685 Initial open-source release
MLstate authored
664
665 let pp f gamma =
666 iter
b12589b fpessaux [feature] Typer: Height of type abbreviation to balance unwinding during...
fpessaux authored
667 (fun typeident (tsc, _, _) ->
fccc685 Initial open-source release
MLstate authored
668 Format.fprintf f "@[<2>%s -> %a@]@\n"
669 (TypeIdent.to_string typeident) QmlPrint.pp#tsc tsc)
670 gamma
671 end
672
673 module FieldMap =
674 struct
675 let find s g =
676 let s = ImplFieldMap.find s g.field_map in
677 ImplFieldMap.S.elements s
678 end
679
b5f0109 fpessaux [cleanup] Type utils: Removed no more used functions.
fpessaux authored
680
fccc685 Initial open-source release
MLstate authored
681
682 let pp f gamma =
683 Format.fprintf f "@[<v>@[<v2>ident:@ %a@]@ @[<v2>types:@ %a@]@]" Ident.pp gamma TypeIdent.pp gamma
684
685 (* Appends the definition in g2 to those of g1 *)
686 let append g1 g2 =
687 let ident = IdentMap.merge (fun _ x -> x) g1.ident g2.ident
688 and type_ident = TypeIdentMap.merge (fun _ x -> x) g1.type_ident g2.type_ident
689 and field_map = ImplFieldMap.M.merge ImplFieldMap.S.union g1.field_map g2.field_map
690 and field_map_quick = ImplFieldMapQuick.M.merge ImplFieldMapQuick.S.union g1.field_map_quick g2.field_map_quick in
47dc97c fpessaux [cleanup] QML typer: Removed duplication TypeIdentMap/TypeIdentPreciseMa...
fpessaux authored
691 { ident = ident ; type_ident = type_ident ; field_map = field_map ;
692 field_map_quick = field_map_quick }
fccc685 Initial open-source release
MLstate authored
693
694 end
695
696 (** More Common Types, needed in order that differents HighTyper could share the type env *)
697 type typed_code_elt = (Q.ty, Scheme.t) Q.maped_code_elt
698 type 'schema public_env =
699 {
700 exported_values_idents : IdentSet.t ;
701 gamma : gamma ;
702 schema : 'schema ;
703 annotmap : Q.annotmap ;
704 bypass_typer : bypass_typer ;
705 had_error : bool ;
706 exception_handler : 'schema public_env -> exn -> unit ;
707 display : bool ; (** false by default *)
708 options : options ;
709 }
710
711 (** Helper functions to normalize types wrt a gamma (process typenames, remove
712 sugared sums, etc.) *)
713 let unsugar_type gamma ty =
714 let error kind =
715 type_err_raise ty (QmlTyperException.InvalidType (ty, kind)) in
716
717 (** {b Descr}: Local function to unwind named type expression, i.e. to
718 replace them by the efective structure that are bound to, with their
719 effective arguments used to instantiate parameters of the definition the
720 name is bound to. *)
721 let unwind_type gamma = function
722 | Q.TypeName (params, ti) ->
b12589b fpessaux [feature] Typer: Height of type abbreviation to balance unwinding during...
fpessaux authored
723 let (ti, (tsc, _)) =
fccc685 Initial open-source release
MLstate authored
724 Env.TypeIdent.findi ~visibility_applies: true ti gamma in
4d93efa fpessaux [cleanup] QML types: No more "externality" test based on TypeIdent tag.
fpessaux authored
725 if (Scheme.instantiate tsc) = Q.TypeAbstract then (
fccc685 Initial open-source release
MLstate authored
726 (* The type name is bound to a definition that is said "abstract" or
727 "extern", so return a type that is a named type with the same
728 name than the initial one. This way, since the type has no
729 representation, i.e. the name is not bound to a definition
730 providing an explicit structure for this name, it will be
731 considered as being structured as itself, hence it will be
732 compatible only with itself. And that, this is really the meaning
733 of an abstract type. *)
734 Q.TypeName (params, ti)
735 )
736 else (
737 (* Ok, the name of this type is bound to a type definition. So we
738 instantiate this definition's scheme by the effective arguments
739 aplied to the type name. Hence, we get a new type that is an
740 instance of the name's definition in which parameters are replaced
741 by the effective types applied to the type name. *)
742 Scheme.specialize ~typeident: ti ~ty: params tsc
743 )
744 | t ->
745 (* The type is not a named type, hence it has its own structure and
746 doesn't unwind. So return it unchanged. *)
747 t in
748
749 let deal_with_duplicates l =
750 let module SpecialMapForDuplicates = BaseMap.Make ( StringSet ) in
751 let safe_add f s =
752 if StringSet.mem f s then (
753 (* There is a duplicate field inside a same record. *)
754 error `duplicate_field
755 )
756 else StringSet.add f s in
757 let undup acc fields =
758 let (s, m) =
759 List.fold_left
760 (fun (s, m) (f, (t : QmlAst.ty)) ->
761 (safe_add f s, StringMap.add f t m))
762 (StringSet.empty, StringMap.empty)
763 fields in
764 match SpecialMapForDuplicates.find_opt s acc with
765 | None -> ((SpecialMapForDuplicates.add s m acc), (Some fields))
766 | Some m' when StringMap.compare (Pervasives.compare) m m' = 0 ->
767 (* We are in the case where several cases of the sum have exactly
768 the same fields with the same types. Hence, we have duplicate
769 sum cases. Just drop this redundant case. *)
770 (acc, None)
771 | _ ->
772 (* There is a duplicate field in different cases of the sum with
773 different types. *)
774 error `duplicate_field_with_diff_ty_in_sum_cases in
775 snd (List.fold_left_filter_map undup SpecialMapForDuplicates.empty l) in
776
777 let make_typesum = function
778 | [r] -> Q.TypeRecord (Q.TyRow (r, None))
779 | l -> Q.TypeSum (Q.TyCol (l, None)) in
780
781 let get_fields = function
782 | Q.TypeRecord (Q.TyRow (fields, None)) -> [fields]
783 | Q.TypeSum (Q.TyCol (fields, None)) -> fields
784 | Q.TypeRecord (Q.TyRow (_, Some _)) -> error `record_not_closed
785 | _ -> error `not_a_record in
786
787 let aux = function
788 | Q.TypeSumSugar l ->
789 (make_typesum @* deal_with_duplicates)
790 (List.concat_map (get_fields @* unwind_type gamma) l)
791 | Q.TypeRecord (Q.TyRow (fields, _)) as t ->
792 ignore (deal_with_duplicates [fields]) ;
793 t
794 | Q.TypeSum (Q.TyCol (cases, _)) as t ->
795 (* For each case of the sum, check that the record representing this
796 case doesn't have duplicate fields and that is a field appears in
797 different sum cases, then it doesn't have different types. *)
798 ignore (deal_with_duplicates cases) ;
799 t
800 | t -> t in
801 QmlAstWalk.Type.map_up aux ty
802
803
804
7b03dd4 fpessaux [cleanup] QML types: Finally, TypeIdent are now regular Ident.
fpessaux authored
805 (* FPE says: after so many refactoring, it seems tat now this function only
806 checks that names of types are used with the right arity... *)
fccc685 Initial open-source release
MLstate authored
807 let process_typenames ?(typedef=false) gamma ty =
808 let aux ty =
809 match ty with
810 | Q.TypeName (tl, ti) ->
b12589b fpessaux [feature] Typer: Height of type abbreviation to balance unwinding during...
fpessaux authored
811 let (ti, (ts, _)) =
812 Env.TypeIdent.findi ~visibility_applies: true ti gamma in
7b03dd4 fpessaux [cleanup] QML types: Finally, TypeIdent are now regular Ident.
fpessaux authored
813 if (typedef || tl <> []) &&
b12589b fpessaux [feature] Typer: Height of type abbreviation to balance unwinding during...
fpessaux authored
814 (List.length tl <> QmlGenericScheme.arity ts) then (
7b03dd4 fpessaux [cleanup] QML types: Finally, TypeIdent are now regular Ident.
fpessaux authored
815 let exn =
816 QmlTyperException.InvalidTypeUsage
817 (ti, (QmlGenericScheme.export_ordered_quantif ts).QTV.typevar,
818 tl) in
819 let (_, body, ()) = QmlGenericScheme.export_unsafe ts in
820 type_err_raise body exn
b12589b fpessaux [feature] Typer: Height of type abbreviation to balance unwinding during...
fpessaux authored
821 )
7b03dd4 fpessaux [cleanup] QML types: Finally, TypeIdent are now regular Ident.
fpessaux authored
822 else Q.TypeName (tl, ti)
823 | _ -> ty in
824 QmlAstWalk.Type.map_up aux ty
825
826
fccc685 Initial open-source release
MLstate authored
827
b12589b fpessaux [feature] Typer: Height of type abbreviation to balance unwinding during...
fpessaux authored
828 (** {b Visibility}: Not exported outside this module. *)
829 (* FPE says: test cases like type 'at = 'a type 'a u = 'a t to see. *)
830 let get_abbreviation_height gamma ty =
831 match ty with
832 | Q.TypeName (_, ti) ->
833 let (_, (_, abb_height)) =
834 Env.TypeIdent.findi ~visibility_applies: true ti gamma in
835 abb_height
836 | Q.TypeVar _ -> -1
837 | _ -> 0
838
839
840
fccc685 Initial open-source release
MLstate authored
841 let type_of_type ?(typedef = false) ?(tirec = []) gamma ty =
842 let gamma =
843 List.fold_left
844 (fun gamma (ti,vars) ->
845 let fake_rec_def =
846 Scheme.definition_no_check ~typevar: vars ti Q.TypeAbstract in
847 Env.TypeIdent.add
848 ti
849 (fake_rec_def,
b12589b fpessaux [feature] Typer: Height of type abbreviation to balance unwinding during...
fpessaux authored
850 (* Abbreviations height is 0 since the definition is considered as
851 binding an abstract type. *)
852 0,
fccc685 Initial open-source release
MLstate authored
853 QmlAst.TDV_private (ObjectFiles.get_current_package_name ()))
854 gamma)
855 gamma tirec in
856 let ty = process_typenames ~typedef gamma ty in
857 let ty = unsugar_type gamma ty in
b12589b fpessaux [feature] Typer: Height of type abbreviation to balance unwinding during...
fpessaux authored
858 let abb_height = get_abbreviation_height gamma ty in
859 (ty, abb_height)
fccc685 Initial open-source release
MLstate authored
860
861 let process_scheme gamma tsc =
b12589b fpessaux [feature] Typer: Height of type abbreviation to balance unwinding during...
fpessaux authored
862 QmlGenericScheme.map_body_unsafe2 (type_of_type gamma) tsc
fccc685 Initial open-source release
MLstate authored
863 (* safe as long as type_of_type doesn't touch type variables, etc. *)
864
865 let process_gamma ~gamma target_gamma =
866 let new_gamma = Env.empty in
867 let new_gamma =
868 Env.Ident.fold
869 (fun id tsc new_gamma ->
b12589b fpessaux [feature] Typer: Height of type abbreviation to balance unwinding during...
fpessaux authored
870 let (tsc', _) = process_scheme gamma tsc in
fccc685 Initial open-source release
MLstate authored
871 Env.Ident.add id tsc' new_gamma)
872 target_gamma new_gamma in
873 let new_gamma =
874 Env.TypeIdent.fold
b12589b fpessaux [feature] Typer: Height of type abbreviation to balance unwinding during...
fpessaux authored
875 (fun id (tsc, height, visibility) new_gamma ->
876 let (tsc', height') = process_scheme gamma tsc in
877 (* FPE says: I think this should be the case... *)
878 assert (height = height') ;
879 Env.TypeIdent.add id (tsc', height, visibility) new_gamma)
fccc685 Initial open-source release
MLstate authored
880 target_gamma new_gamma in
881 new_gamma
882
883 let process_typenames_annotmap ~gamma annotmap =
884 QmlAnnotMap.map (process_typenames ~typedef:false gamma) annotmap
885
886 let process_annotmap ~gamma annotmap =
b12589b fpessaux [feature] Typer: Height of type abbreviation to balance unwinding during...
fpessaux authored
887 QmlAnnotMap.map (fun ty -> fst (type_of_type gamma ty)) annotmap
fccc685 Initial open-source release
MLstate authored
888
7b03dd4 fpessaux [cleanup] QML types: Finally, TypeIdent are now regular Ident.
fpessaux authored
889
890
fccc685 Initial open-source release
MLstate authored
891 let check_no_duplicate_type_defs =
892 let cmp x y =
7b03dd4 fpessaux [cleanup] QML types: Finally, TypeIdent are now regular Ident.
fpessaux authored
893 let c = TypeIdent.compare x y in
894 if c = 0 then
895 raise
896 (QmlTyperException.Exception
897 (QmlTyperException.loc_empty,
898 QmlTyperException.DuplicateTypeDefinitions
899 (TypeIdent.to_string x))) ;
900 c in
fccc685 Initial open-source release
MLstate authored
901 ignore @* (List.sort cmp) @*
902 (List.concat_map
903 (function Q.NewType (_, l) ->
904 List.map (fun ty_def -> ty_def.QmlAst.ty_def_name) l | _ -> []))
Something went wrong with that request. Please try again.