Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 494 lines (448 sloc) 20.966 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 (**
20 Top level typing loop.
21 *)
22
23
24
25 (* depends *)
26 module Format = Base.Format
27 module List = BaseList
28
29 (* shorthands *)
30 module Q = QmlAst
31 module QT = QmlTypes
32
33 (* aliases *)
34 module TypeIdent = QmlAst.TypeIdent
35 module Db = QmlAst.Db
36
37 (* refactoring in progress *)
38
39 (*
40 The signature of the Typer constructor has been review a little :
41
42 There is no reason to switch of DbSchema constructor in the middle of a typing loop.
43 Anyway, we have until now just on dbGen, and we use to call everytime type_of_expr with
44 the same function in arg.
45
46 Otherwise, the bypass_typer must be provided with a
47 dynamic passing for this function, but without passing it
48 everytime in everycall : so now, the function is in the env
49
50 To get a function bypass_typer, use Libbsl, build your bypassmap, and use a partial call of the
51 function ByPassMap.bypass_typer mymap ~if_not_found
52 *)
53
54 (** New functionnaly system for annoation
55 Beware : this functionnaly annot map is automatically updated in the annot part of the env
56 if you don't need everyannot, use the syntax [{ env with annot = IntMap.empty }] for
57 the env passed as argument. *)
58
59 (** avoid cyclic dependencies between QmlTypes and DbGen *)
60 type public_env = QmlDbGen.Schema.t QT.public_env
61
62 (** The type sig is specified because it is used in qmlBlender *)
63 module type HIGH_LEVEL_TYPER =
64 sig
65 (** Error Managment *)
66 (** The module is a functor, so it can raises some unbound yet exception but, we keep trace of it
67 in the second part of the exception constructor
68 The code_elt provided is here to give an information to locate the place where the exception was raised *)
69 (** To upgrade the pretty printing functionnality of exception unbound yet here,
70 give a specialized Printexc parameter module *)
71
72 (** Main types : Moved in QmlTypes *)
73 type gamma = QT.gamma
74 type schema = QmlDbGen.Schema.t
75 type bypass_typer = QT.bypass_typer
76 type env = public_env
77
78 (** All default values are specified on the right (empty or dummy version for bypass_typer) *)
79 val initial :
5e2359f @fpessaux [cleanup] qml level typer: Cleanup in obscure options never set.
fpessaux authored
80 bypass_typer: bypass_typer ->
fccc685 Initial open-source release
MLstate authored
81 ?exception_handler:(env -> exn -> unit) -> (** fun _ e -> raise e *)
82 ?display:bool -> (** false *)
83 explicit_instantiation : bool ->
84 (** not an optional argument, because it has to be the same
85 as the OPA compilation option of the same name, it's called
86 in many places in OPA, and the default value in OPA changes
87 (so we risk getting out of sync with OPA and having obscure errors
88 or inefficiencies, if we have a (different) default value here, too) *)
5e2359f @fpessaux [cleanup] qml level typer: Cleanup in obscure options never set.
fpessaux authored
89 value_restriction : [`disabled|`normal|`strict] ->
fccc685 Initial open-source release
MLstate authored
90 (** The set of toplevel identifiers that are visible outside the package.
91 It will be used to raise an error if a value has a type containing a
92 @private type and this value is not marked also by a @private. This
93 is to avoid private types escaping from their scope. *)
94 exported_values_idents: IdentSet.t ->
95 unit -> env
96
97 val map_expr : env -> Q.expr -> Q.ty
98 val map_elt : env -> Q.code_elt -> QT.typed_code_elt
99 val map : env -> Q.code -> QT.typed_code_elt list
100
101 val fold_expr : env -> Q.expr -> env
102 val fold_elt : env -> Q.code_elt -> env
103 val fold : env -> Q.code -> env
104
105 val fold_map_expr : env -> Q.expr -> env * Q.ty
106 val fold_map_elt : env -> Q.code_elt -> env * QT.typed_code_elt
107 val fold_map : env -> Q.code -> env * QT.typed_code_elt list
108
109 (** *)
110 val type_newtype_for_separation : more_gamma:QT.gamma -> env -> Q.code_elt -> Q.typedef list -> gamma * env
111 end
112
113 module Make ( LLTyper : QT.QML_LOW_LEVEL_TYPER ) : HIGH_LEVEL_TYPER =
114 struct
115 (** Error Managment : see if we want to catch error of ByPassTyper and Schema or not *)
116 (** The module is a functor, so it can raises some unbound yet exception but, we keep trace of it
117 in the second part of the exception constructor *)
118 (** To upgrade the pretty printing functionnality of exception unbound yet here,
119 give a specialized Printexc parameter module *)
120
121 (* the wrapper with annot checks *)
122 let type_of_expr ~options ~annotmap ~bypass_typer ~gamma expr =
123 (* check input annotmap *)
124 assert
125 (
126 let check_opts =
127 {QmlAnnotCheckup.default with
128 QmlAnnotCheckup.freshness_only = true;
129 QmlAnnotCheckup.dump_not_found = true}
130 in
131 QmlAnnotCheckup.expr ~options:check_opts annotmap expr
132 );
133 (* call the typer *)
134 let (gamma, annotmap, t) =
135 LLTyper.type_of_expr ~options ~annotmap ~bypass_typer ~gamma expr
136 in
137 (* check the result annotmap *)
138 assert
139 (
140 let config_basic_annotations =
141 (* don't be strict if the poweruser typer testing flag is set
142 (e.g., for dynamic typers that override the [annot_config]) *)
143 not (Base.debug_getenv_toggle "TYPER_OVERRIDE")
144 in
145 let check_opts =
146 {QmlAnnotCheckup.default with
147 (* don't spam if we don't fail, unless in debug mode below: *)
148 QmlAnnotCheckup.dump_not_found = config_basic_annotations}
149 in
150 #<< let check_opts = if Q.QmlConsole.is_typer_debug_on () >>#;
151 #<< then { check_opts with QmlAnnotCheckup.dump_not_found = true; QmlAnnotCheckup.dump_found = true; } >>#;
152 #<< else check_opts in >>#;
153 QmlAnnotCheckup.expr ~options:check_opts annotmap expr
154 (* do not fail if the option permits missing annot contents *)
155 || not config_basic_annotations
156 );
157 (* give unchanged result if everything OK *)
158 (gamma, annotmap, t)
159
160 type typed_code_elt = (Q.ty, QT.Scheme.t) Q.maped_code_elt
161 type gamma = QT.gamma
162 type schema = QmlDbGen.Schema.t
163 type bypass_typer = QT.bypass_typer
164 type env = public_env
165
166 let initial
c2096c3 @fpessaux [cleanup] qml level typer: removed arguments always used with the sam…
fpessaux authored
167 ~bypass_typer ?(exception_handler=(fun _ e -> raise e))
168 ?(display=false) ~explicit_instantiation ~value_restriction
169 ~exported_values_idents () =
fccc685 Initial open-source release
MLstate authored
170 {
c2096c3 @fpessaux [cleanup] qml level typer: removed arguments always used with the sam…
fpessaux authored
171 QmlTypes.exported_values_idents = exported_values_idents ;
172 QmlTypes.gamma = QmlTypes.Env.empty ; (* Initial gamma. *)
173 QmlTypes.schema = QmlDbGen.Schema.initial ; (* Initial DB scheme. *)
174 QmlTypes.annotmap = QmlAnnotMap.empty ; (* Initial annotmap. *)
175 QmlTypes.bypass_typer = bypass_typer ;
176 QmlTypes.exception_handler = exception_handler ;
177 QmlTypes.had_error = false ;
178 QmlTypes.display = display ;
179 QmlTypes.options = {
180 QmlTypes.explicit_instantiation = explicit_instantiation ;
181 QmlTypes.value_restriction = value_restriction ;
182 }
fccc685 Initial open-source release
MLstate authored
183 }
184
185 let exception_handler env (code_elt, (e, x)) =
186 match e with
187 | QmlTyperException.Exception _ ->
5e2359f @fpessaux [cleanup] qml level typer: Cleanup in obscure options never set.
fpessaux authored
188 env.QT.exception_handler
189 env (QT.Exception (QT.TyperError (code_elt, (e, x))))
fccc685 Initial open-source release
MLstate authored
190 | _ ->
191 (* reraise any non-typer exceptions (assert failures, etc.) *)
192 raise e
193
194
195 let type_newtype_gen ~more_gamma: more_gamma env code_elt ty_defs =
196 let compare_record (a, _) (b, _) = String.compare a b in
197 let sort_record = List.sort compare_record in
198 let sort_sum li =
199 let li2 = List.map sort_record li in
200 List.sort (List.make_compare compare_record) li2 in
201 try
202 let gamma = env.QT.gamma in
203 let l =
204 List.concat_map
205 (fun { Q.ty_def_name = ti; Q.ty_def_params = vars;
206 Q.ty_def_body = te ; Q.ty_def_visibility = visibility } ->
207 let add_ti ti visibility = [(ti, (vars, te), visibility)] in
7b03dd4 @fpessaux [cleanup] QML types: Finally, TypeIdent are now regular Ident.
fpessaux authored
208 (* [TODO] Attention, here the body of the definition is allowed to
209 use only type constructors that are visible from the currently
210 compiled package. *)
211 add_ti ti visibility)
fccc685 Initial open-source release
MLstate authored
212 ty_defs in
213 let tirec = List.map (fun (ti, (vars, _), _) -> (ti, vars)) l in
214 let (more_gamma, gamma), l =
215 List.fold_left_map
216 (fun (more_gamma, gamma) (ti, (vars, te), visibility) ->
217 (* /!\ may raise TypeidentNotFound *)
b12589b @fpessaux [feature] Typer: Height of type abbreviation to balance unwinding dur…
fpessaux authored
218 let (te, abb_height) =
219 QT.type_of_type ~typedef: true ~tirec gamma te in
fccc685 Initial open-source release
MLstate authored
220 let te = QmlAstWalk.Type.map
221 (fun t ->
222 match t with
223 | Q.TypeRecord (Q.TyRow (li, c) ) ->
224 let li2 = sort_record li in
225 Q.TypeRecord (Q.TyRow(li2, c))
226 | Q.TypeSum (Q.TyCol (li, v)) ->
227 let li2 = sort_sum li in
228 Q.TypeSum (Q.TyCol (li2, v))
229 | Q.TypeSumSugar _ ->
230 assert false (* Case solved by type_of_type. *)
231 | _ -> t)
232 te in
233 let def_scheme = QT.Scheme.definition ~typevar: vars ti te in
b12589b @fpessaux [feature] Typer: Height of type abbreviation to balance unwinding dur…
fpessaux authored
234 (* Check if the definition is a trivial abbreviation, i.e. is of
235 the shape: type t('a, 'b...) = 'b. If so, then the abbreviation
236 height of this named type is set to the negated position
237 (numbered from 1) of the parameter used in the body of the
238 trivial abbreviation definition (in our example, -2).
239 Otherwise, it is set to 1 + the abbreviation height of the
240 body. *)
241 let abb_height' =
242 (match (vars, te) with
243 | ((_ :: _), (Q.TypeVar var_body)) -> (
244 let opt_found =
245 List.findi
246 (fun v -> (QmlTypeVars.TypeVar.compare v var_body) = 0)
247 vars in
248 match opt_found with
249 | None -> assert false
250 | Some index ->
251 (* Avoid 0 since it's a regular height. So, start
252 counting position from 1 instead of 0. *)
253 - (index + 1)
254 )
255 | (_, _) ->
256 (* Attention, here check if the height is negative. *)
257 if abb_height < 0 then (
258 (* The type expression of the body must be a type name
259 otherwise there is something broken. We must hence
260 recover it and get the height of the argument applied
261 at the - (abb_height + 1) position. Thsi will then
262 be the height of the defined type constructor. *)
263 match te with
264 | Q.TypeName (args, _) ->
265 let interest_index = - (abb_height + 1) in
266 (* Get the effective type expression at this
267 position. *)
268 let interest_arg = List.nth args interest_index in
269 let (interest_arg, interest_arg_height) =
270 QmlTypes.type_of_type gamma interest_arg in
271 (* Again special case if we get -1 which means that's
272 a type variable. *)
273 if interest_arg_height = -1 then (
274 match interest_arg with
275 | Q.TypeVar interest_var -> (
276 let opt_found =
277 List.findi
278 (fun v ->
279 (QmlTypeVars.TypeVar.compare
280 v interest_var) = 0)
281 vars in
282 match opt_found with
283 | None -> assert false
284 | Some index ->
285 (* Avoid 0 since it's a regular height. So,
286 start counting position from 1 instead of
287 0. *)
288 - (index + 1)
289 )
290 | _ -> assert false
291 )
292 else 1 + interest_arg_height
293 | _ -> assert false
294 )
295 else 1 + abb_height (* Regular case. *)
296 ) in
fccc685 Initial open-source release
MLstate authored
297 (* Here we must the @private and @abstract directives by
298 exploiting the visibility information of the type definition. *)
299 let gamma =
b12589b @fpessaux [feature] Typer: Height of type abbreviation to balance unwinding dur…
fpessaux authored
300 QT.Env.TypeIdent.add
301 ti (def_scheme, abb_height', visibility) gamma in
fccc685 Initial open-source release
MLstate authored
302 let more_gamma =
b12589b @fpessaux [feature] Typer: Height of type abbreviation to balance unwinding dur…
fpessaux authored
303 QT.Env.TypeIdent.add
304 ti (def_scheme, abb_height', visibility) more_gamma in
fccc685 Initial open-source release
MLstate authored
305 if env.QT.display then (
b12589b @fpessaux [feature] Typer: Height of type abbreviation to balance unwinding dur…
fpessaux authored
306 (* Reset the type vars to avoid variables names to be
307 continuously incremented and not restarted at "'v0" for this
308 new type definition. *)
fccc685 Initial open-source release
MLstate authored
309 QmlPrint.pp#reset_typevars ;
310 let ((vars, _, _), ty) = QT.Scheme.export def_scheme in
311 let def_for_print = {
312 QmlAst.ty_def_options = QmlAst.ty_def_options ;
313 QmlAst.ty_def_visibility = visibility ;
314 QmlAst.ty_def_name = ti ;
315 QmlAst.ty_def_params = vars ;
316 QmlAst.ty_def_body = ty } in
317 OManager.printf "%a@." QmlPrint.pp#typedef def_for_print
318 );
319 (more_gamma, gamma), (ti, def_scheme)) (more_gamma, gamma) l in
320 (more_gamma, { env with QT.gamma = gamma }, (Q.M_NewType l))
321 with e ->
322 exception_handler env (code_elt, (e, [])) ;
323 (more_gamma, { env with QT.had_error = true },
324 Q.M_Failure (code_elt, (e, [])))
325
326
327
328 let type_newtype_for_separation ~more_gamma env code_elt l =
329 let (more_gamma, env, _) = type_newtype_gen ~more_gamma env code_elt l in
330 (more_gamma, env)
331
332 let type_newtype env code_elt l =
333 let more_gamma = QT.Env.empty in
334 let (_, env, stuff) = type_newtype_gen ~more_gamma env code_elt l in
335 (env, stuff)
336
337 let fold_map_elt env code_elt =
338 let exception_handler_with_env = exception_handler in
339 let exception_handler = exception_handler env in
340 let rec get_let_component_old id t =
341 match t with
342 | Q.TypeRecord (Q.TyRow (lt, _)) ->
343 List.assoc id lt
344 | Q.TypeSum (Q.TyCol ([lt], _)) ->
345 List.assoc id lt
346 | t when t = Q.typeNull ->
347 Q.typeNull (* for typer "off" (Qmltyper.NoTyper) *)
348 | _ -> assert false
349 in
350 let get_let_component s t annotmap ident letrec =
351 match t with
352 | Q.TypeRecord (Q.TyRow (_lt, _))
353 | Q.TypeSum (Q.TyCol ([_lt], _)) -> (
354 match letrec with
355 | Q.LetIn (_, vals, _)
356 | Q.LetRecIn (_, vals, _) ->
357 let e = List.assoc ident vals in
358 QmlAnnotMap.find_ty (Q.QAnnot.expr e) annotmap
359 | _ -> assert false
360 )
361 | _ ->
362 get_let_component_old s t
363 in
364 let type_bndlist ?(env=env) valrec letrec fields =
365 let gamma = env.QT.gamma in
366 let bypass_typer = env.QT.bypass_typer in
aeb2974 @fpessaux [fix] OPA-555: Missing source location in error message for escaping …
fpessaux authored
367 (* Keep this annotmap under the hand because this is the one that has locations
368 information. The one that will be returned after typechecking doesn't have
369 some anymore. So, in case of error, keeping this annotmap allows us to report
370 the error accurately in the source code instead of crudely citing the guilty
371 part of source code. *)
372 let initial_annotmap_with_locs = env.QT.annotmap in
fccc685 Initial open-source release
MLstate authored
373 let options = env.QT.options in
374 let exported_values_idents = env.QT.exported_values_idents in
aeb2974 @fpessaux [fix] OPA-555: Missing source location in error message for escaping …
fpessaux authored
375 let typer =
376 type_of_expr
377 ~options ~annotmap: initial_annotmap_with_locs ~bypass_typer ~gamma in
fccc685 Initial open-source release
MLstate authored
378 let (gamma, annotmap, t) = typer letrec in
379 let fold_map gamma (ident, exp) (s, _, _) =
380 let ty = get_let_component s t annotmap ident letrec in
381 (* Ensure that if the bound ident is exported outside the package, then
382 its type doesn't make any reference to a type private to the
383 package. *)
384 if IdentSet.mem ident exported_values_idents then (
385 try QmlTypesUtils.Inspect.check_no_private_type_escaping gamma ty with
386 | QmlTypesUtils.Inspect.Escaping_private_type prv_ty ->
aeb2974 @fpessaux [fix] OPA-555: Missing source location in error message for escaping …
fpessaux authored
387 let err_ctxt =
388 QmlError.Context.annoted_expr initial_annotmap_with_locs exp in
389 QmlError.error err_ctxt
390 ("@[Definition@ of@ @{<red>%a@}@ is@ not@ private@ but@ its@ type@ "^^
391 "contains@ a@ type@ private@ to@ the@ package.@ Type@ %a@ must@ " ^^
392 "not@ escape@ its@ scope.@]@\n" ^^
393 "@[<2>@{<bright>Hint@}:@\nAdd@ a@ @@private@ directive@ on@ this@ " ^^
394 "definition.@]@\n")
395 QmlPrint.pp#ident ident QmlPrint.pp#ty prv_ty
fccc685 Initial open-source release
MLstate authored
396 ) ;
397 (* If interface printing is requested, then print the type of the bound
398 value. *)
399 if env.QT.display then (
400 (* Reset the type vars to avoid variables names to be continuously
401 incremented and not restarted at "'v0" for this new value
402 definition. *)
403 QmlPrint.pp#reset_typevars ;
404 OManager.printf "@[<2>val %a :@\n%a@]@."
405 QmlPrint.pp#ident ident QmlPrint.pp#ty ty) ;
406 (** If we have free type vars in the top level of the qml language,
407 e.g. due to value restriction, then use [generalize]
408 instead of [quantify] *)
409 let sch =
410 let is_expansive = QmlAstUtils.is_expansive_with_options options.QT.value_restriction in
411 if not (QT.FreeVars.is_type_empty (QT.freevars_of_ty ty)) && is_expansive exp
412 then (
413 let context = QmlError.Context.annoted_expr annotmap exp in
414 QmlError.serror context
415 "Value restriction error@\n@[<2>This expression is not generalizable but it has type@ %a .@]"
416 QmlPrint.pp_value_restriction#ty_new_scope ty
417 );
418 QT.Scheme.quantify ty
419 in
420 let gamma = QT.Env.Ident.add ident sch gamma in
421 gamma, (ident, ty)
422 in
423 let gamma, maped =
424 List.fold_left_map2 fold_map gamma valrec fields
425 in
426 { env with QT.gamma = gamma ; QT.annotmap = annotmap }, maped
427 in
428 match code_elt with
429 | Q.Database (_label, ident, p, opts) ->
430 env, Q.M_Database (ident, p, opts)
431 | Q.NewDbValue (_label, Db.Db_TypeDecl (p, ty)) ->
432 env, Q.M_NewDbValue (p, ty)
433 | Q.NewDbValue (_label, Db.Db_Alias (p, p')) ->
434 env, Q.M_DbAlias (p, p')
435 | Q.NewDbValue (_label, Db.Db_Default (p, _dflt)) ->
436 env, Q.M_DbDefault p
437 | Q.NewDbValue (_, Db.Db_Constraint (p,c)) ->
438 env, Q.M_DbConstraint (p,c)
439 | Q.NewDbValue (_, Db.Db_Virtual (p, e)) ->
440 env, Q.M_DbVirtual(p, e)
441 | Q.NewType (_, l) ->
442 type_newtype env code_elt l
443
444 | Q.NewVal (_, val_list) | Q.NewValRec (_, val_list) ->
445 begin
446 try
447 let (fields, letin, _, _) = QmlAstCons.UnValRec.make_let code_elt in
448 begin
449 try
450 let env, maped = type_bndlist ~env val_list letin fields in
451 env, Q.M_NewVal maped
452 with
453 | e ->
454 exception_handler_with_env env (code_elt, (e, []));
455 { env with QT.had_error = true }, Q.M_Failure (code_elt, (e, []))
456 (* this try ... with has a better env for error reporting (more positions) *)
457 end
458 with
459 | e ->
460 exception_handler (code_elt, (e, []));
461 { env with QT.had_error = true }, Q.M_Failure (code_elt, (e, []))
462 end
463
464 let fold_map_expr env expr =
465 let code_elt, rebuilder = QmlAstCons.UnValRec.make_code_elt_maped expr in
466 let env, maped = fold_map_elt env code_elt in
467 let ty = rebuilder maped in
468 env, ty
469
470 let map_expr env expr =
471 let _, ty = fold_map_expr env expr in
472 ty
473
474 let map_elt env code_elt =
475 let _, maped = fold_map_elt env code_elt in
476 maped
477
478 let map env code =
479 let _, maped = Base.List.fold_left_map fold_map_elt env code in
480 maped
481
482 let fold_expr env expr =
483 let env, _ = fold_map_expr env expr in
484 env
485
486 let fold_elt env code_elt =
487 let env, _ = fold_map_elt env code_elt in
488 env
489
490 let fold = List.fold_left fold_elt
491
492 let fold_map = Base.List.fold_left_map fold_map_elt
493 end
Something went wrong with that request. Please try again.