Skip to content

HTTPS clone URL

Subversion checkout URL

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