Skip to content
Newer
Older
100644 428 lines (382 sloc) 17.1 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 *)
218 let te = QT.type_of_type ~typedef: true ~tirec gamma te in
219 let te = QmlAstWalk.Type.map
220 (fun t ->
221 match t with
222 | Q.TypeRecord (Q.TyRow (li, c) ) ->
223 let li2 = sort_record li in
224 Q.TypeRecord (Q.TyRow(li2, c))
225 | Q.TypeSum (Q.TyCol (li, v)) ->
226 let li2 = sort_sum li in
227 Q.TypeSum (Q.TyCol (li2, v))
228 | Q.TypeSumSugar _ ->
229 assert false (* Case solved by type_of_type. *)
230 | _ -> t)
231 te in
232 let def_scheme = QT.Scheme.definition ~typevar: vars ti te in
233 (* Here we must the @private and @abstract directives by
234 exploiting the visibility information of the type definition. *)
235 let gamma =
236 QT.Env.TypeIdent.add ti (def_scheme, visibility) gamma in
237 let more_gamma =
238 QT.Env.TypeIdent.add ti (def_scheme, visibility) more_gamma in
239 if env.QT.display then (
240 (* Reset the type vars to avoid variables names to be continuously
241 incremented and not restarted at "'v0" for this new type
242 definition. *)
243 QmlPrint.pp#reset_typevars ;
244 let ((vars, _, _), ty) = QT.Scheme.export def_scheme in
245 let def_for_print = {
246 QmlAst.ty_def_options = QmlAst.ty_def_options ;
247 QmlAst.ty_def_visibility = visibility ;
248 QmlAst.ty_def_name = ti ;
249 QmlAst.ty_def_params = vars ;
250 QmlAst.ty_def_body = ty } in
251 OManager.printf "%a@." QmlPrint.pp#typedef def_for_print
252 );
253 (more_gamma, gamma), (ti, def_scheme)) (more_gamma, gamma) l in
254 (more_gamma, { env with QT.gamma = gamma }, (Q.M_NewType l))
255 with e ->
256 exception_handler env (code_elt, (e, [])) ;
257 (more_gamma, { env with QT.had_error = true },
258 Q.M_Failure (code_elt, (e, [])))
259
260
261
262 let type_newtype_for_separation ~more_gamma env code_elt l =
263 let (more_gamma, env, _) = type_newtype_gen ~more_gamma env code_elt l in
264 (more_gamma, env)
265
266 let type_newtype env code_elt l =
267 let more_gamma = QT.Env.empty in
268 let (_, env, stuff) = type_newtype_gen ~more_gamma env code_elt l in
269 (env, stuff)
270
271 let fold_map_elt env code_elt =
272 let exception_handler_with_env = exception_handler in
273 let exception_handler = exception_handler env in
274 let rec get_let_component_old id t =
275 match t with
276 | Q.TypeRecord (Q.TyRow (lt, _)) ->
277 List.assoc id lt
278 | Q.TypeSum (Q.TyCol ([lt], _)) ->
279 List.assoc id lt
280 | t when t = Q.typeNull ->
281 Q.typeNull (* for typer "off" (Qmltyper.NoTyper) *)
282 | _ -> assert false
283 in
284 let get_let_component s t annotmap ident letrec =
285 match t with
286 | Q.TypeRecord (Q.TyRow (_lt, _))
287 | Q.TypeSum (Q.TyCol ([_lt], _)) -> (
288 match letrec with
289 | Q.LetIn (_, vals, _)
290 | Q.LetRecIn (_, vals, _) ->
291 let e = List.assoc ident vals in
292 QmlAnnotMap.find_ty (Q.QAnnot.expr e) annotmap
293 | _ -> assert false
294 )
295 | _ ->
296 get_let_component_old s t
297 in
298 let type_bndlist ?(env=env) valrec letrec fields =
299 let gamma = env.QT.gamma in
300 let bypass_typer = env.QT.bypass_typer in
aeb2974 @fpessaux [fix] OPA-555: Missing source location in error message for escaping …
fpessaux authored
301 (* Keep this annotmap under the hand because this is the one that has locations
302 information. The one that will be returned after typechecking doesn't have
303 some anymore. So, in case of error, keeping this annotmap allows us to report
304 the error accurately in the source code instead of crudely citing the guilty
305 part of source code. *)
306 let initial_annotmap_with_locs = env.QT.annotmap in
fccc685 Initial open-source release
MLstate authored
307 let options = env.QT.options in
308 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
309 let typer =
310 type_of_expr
311 ~options ~annotmap: initial_annotmap_with_locs ~bypass_typer ~gamma in
fccc685 Initial open-source release
MLstate authored
312 let (gamma, annotmap, t) = typer letrec in
313 let fold_map gamma (ident, exp) (s, _, _) =
314 let ty = get_let_component s t annotmap ident letrec in
315 (* Ensure that if the bound ident is exported outside the package, then
316 its type doesn't make any reference to a type private to the
317 package. *)
318 if IdentSet.mem ident exported_values_idents then (
319 try QmlTypesUtils.Inspect.check_no_private_type_escaping gamma ty with
320 | QmlTypesUtils.Inspect.Escaping_private_type prv_ty ->
aeb2974 @fpessaux [fix] OPA-555: Missing source location in error message for escaping …
fpessaux authored
321 let err_ctxt =
322 QmlError.Context.annoted_expr initial_annotmap_with_locs exp in
323 QmlError.error err_ctxt
324 ("@[Definition@ of@ @{<red>%a@}@ is@ not@ private@ but@ its@ type@ "^^
325 "contains@ a@ type@ private@ to@ the@ package.@ Type@ %a@ must@ " ^^
326 "not@ escape@ its@ scope.@]@\n" ^^
327 "@[<2>@{<bright>Hint@}:@\nAdd@ a@ @@private@ directive@ on@ this@ " ^^
328 "definition.@]@\n")
329 QmlPrint.pp#ident ident QmlPrint.pp#ty prv_ty
fccc685 Initial open-source release
MLstate authored
330 ) ;
331 (* If interface printing is requested, then print the type of the bound
332 value. *)
333 if env.QT.display then (
334 (* Reset the type vars to avoid variables names to be continuously
335 incremented and not restarted at "'v0" for this new value
336 definition. *)
337 QmlPrint.pp#reset_typevars ;
338 OManager.printf "@[<2>val %a :@\n%a@]@."
339 QmlPrint.pp#ident ident QmlPrint.pp#ty ty) ;
340 (** If we have free type vars in the top level of the qml language,
341 e.g. due to value restriction, then use [generalize]
342 instead of [quantify] *)
343 let sch =
344 let is_expansive = QmlAstUtils.is_expansive_with_options options.QT.value_restriction in
345 if not (QT.FreeVars.is_type_empty (QT.freevars_of_ty ty)) && is_expansive exp
346 then (
347 let context = QmlError.Context.annoted_expr annotmap exp in
348 QmlError.serror context
349 "Value restriction error@\n@[<2>This expression is not generalizable but it has type@ %a .@]"
350 QmlPrint.pp_value_restriction#ty_new_scope ty
351 );
352 QT.Scheme.quantify ty
353 in
354 let gamma = QT.Env.Ident.add ident sch gamma in
355 gamma, (ident, ty)
356 in
357 let gamma, maped =
358 List.fold_left_map2 fold_map gamma valrec fields
359 in
360 { env with QT.gamma = gamma ; QT.annotmap = annotmap }, maped
361 in
362 match code_elt with
363 | Q.Database (_label, ident, p, opts) ->
364 env, Q.M_Database (ident, p, opts)
365 | Q.NewDbValue (_label, Db.Db_TypeDecl (p, ty)) ->
366 env, Q.M_NewDbValue (p, ty)
367 | Q.NewDbValue (_label, Db.Db_Alias (p, p')) ->
368 env, Q.M_DbAlias (p, p')
369 | Q.NewDbValue (_label, Db.Db_Default (p, _dflt)) ->
370 env, Q.M_DbDefault p
371 | Q.NewDbValue (_, Db.Db_Constraint (p,c)) ->
372 env, Q.M_DbConstraint (p,c)
373 | Q.NewDbValue (_, Db.Db_Virtual (p, e)) ->
374 env, Q.M_DbVirtual(p, e)
375 | Q.NewType (_, l) ->
376 type_newtype env code_elt l
377
378 | Q.NewVal (_, val_list) | Q.NewValRec (_, val_list) ->
379 begin
380 try
381 let (fields, letin, _, _) = QmlAstCons.UnValRec.make_let code_elt in
382 begin
383 try
384 let env, maped = type_bndlist ~env val_list letin fields in
385 env, Q.M_NewVal maped
386 with
387 | e ->
388 exception_handler_with_env env (code_elt, (e, []));
389 { env with QT.had_error = true }, Q.M_Failure (code_elt, (e, []))
390 (* this try ... with has a better env for error reporting (more positions) *)
391 end
392 with
393 | e ->
394 exception_handler (code_elt, (e, []));
395 { env with QT.had_error = true }, Q.M_Failure (code_elt, (e, []))
396 end
397
398 let fold_map_expr env expr =
399 let code_elt, rebuilder = QmlAstCons.UnValRec.make_code_elt_maped expr in
400 let env, maped = fold_map_elt env code_elt in
401 let ty = rebuilder maped in
402 env, ty
403
404 let map_expr env expr =
405 let _, ty = fold_map_expr env expr in
406 ty
407
408 let map_elt env code_elt =
409 let _, maped = fold_map_elt env code_elt in
410 maped
411
412 let map env code =
413 let _, maped = Base.List.fold_left_map fold_map_elt env code in
414 maped
415
416 let fold_expr env expr =
417 let env, _ = fold_map_expr env expr in
418 env
419
420 let fold_elt env code_elt =
421 let env, _ = fold_map_elt env code_elt in
422 env
423
424 let fold = List.fold_left fold_elt
425
426 let fold_map = Base.List.fold_left_map fold_map_elt
427 end
Something went wrong with that request. Please try again.