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