Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100755 268 lines (239 sloc) 13.155 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 @author Fran�ois Pessaux
20 *)
21
22
23
24 (* ************************************************************************** *)
25 (** {b Descr}: See documentation in [w_TypingEnv.mli]. We export this function
26 to make it visible from [pass_Typing.ml].
27 {b Visibility}: Exported outside this module. *)
28 (* ************************************************************************** *)
29 let reset_toplevel_tydefs_schemes_env_memo () =
30 W_TypingEnv.reset_toplevel_tydefs_schemes_env_memo ()
31
32
33
34 (* ************************************************************************** *)
35 (** {b Descr}: See documentation in [w_TypingEnv.mli]. We export this function
36 to make it visible from [pass_Typing.ml].
37 {b Visibility}: Exported outside this module. *)
38 (* ************************************************************************** *)
39 let reset_toplevel_valdefs_schemes_env_memo () =
40 W_TypingEnv.reset_toplevel_valdefs_schemes_env_memo ()
41
42
43
44 let convert_to_qml ~expr ~inferred_ty ~inference_result_annotmap =
45 try
46 (* Convert the type obtained after inference. *)
47 let qml_ty = W_PublicExport.simple_type_to_qml_type inferred_ty in
48 (* Now, convert the annotation map obtained after inference into a QML
49 annotation map. *)
50 let qml_annotmap =
51 W_AnnotMap.annotmap_to_qml_annotmap inference_result_annotmap in
52 (qml_ty, qml_annotmap)
53 with
54 | W_PublicExport.Cyclic_type _
55 | W_PublicExport.Ill_formed_column_type _ ->
56 W_ReportErrors.report_cyclic_or_ill_formed_type_in_expr
57 inference_result_annotmap expr
58
59
60
61 (* ************************************************************************** *)
62 (** {b Descr}: See documentation in [w_Exceptions.mli]. We export this function
63 to make it visible from [pass_Typing.ml].
64 {b Visibility}: Exported outside this module. *)
65 (* ************************************************************************** *)
66 let reset_type_exception () =
67 W_Exceptions.reset_type_exception ()
68
69
70
71 (* ************************************************************************** *)
72 (** {b Descr}: Function allowing to populate the type of exceptions from a list
73 of (assumed to sums) types obtained from modules the current one depends
74 on. Each module manipulated exceptions, defined some, and these exceptions
75 definitions must be known to ensure that the current compilation unit uses
76 them with a consistent type, a consistent structure. We especially want to
77 avoid using an exception parameter with a type different from the type it
78 had in the exception definition.
79 ATTENTION: This function assumes that [Typer_w.reset_type_exception] was
80 previously called.
81 This function is especially made visible for [pass_Typing.ml].
82 {b Visibility}: Exported outside this module. *)
83 (* ************************************************************************** *)
84 let init_type_exception gamma tys =
85 let env = W_TypingEnv.from_qml_typing_env gamma in
86 W_TypingEnv.new_empty_variables_mapping () ;
87 List.iter
88 (fun qml_ty ->
89 let ty =
90 W_TypingEnv.qml_type_to_simple_type
91 env ~is_type_annotation: false qml_ty in
92 W_Exceptions.enrich_type_exception env ty)
93 tys ;
94 W_TypingEnv.release_variables_mapping ()
95
96
97
98 (* ************************************************************************** *)
99 (** {b Descr}: Function allowing to retrieve the type of exceptions as a QML
100 (assumed to be a sum) type. This function is made visible for
101 [pass_Typing.ml] in order to allow this latter so save the structure of the
102 type of exceptions we inferred during the typechecking of the current
103 compilation unit. Hence, all modules depending on the present compilation
104 unit will be able, to know our exceptions definitions.
105 {b Visibility}: Exported outside this module. *)
106 (* ************************************************************************** *)
107 let get_type_exception_description () =
108 let ty = W_Exceptions.type_exception () in
109 W_PublicExport.simple_type_to_qml_type ty
110
111
112
113 (* ************************************************************************** *)
114 (** {b Descr}: The main function of the typechecker that performs the type
115 inference of an expression. *)
116 (* ************************************************************************** *)
117 let type_of_expr ?options:_ ?annotmap ~bypass_typer ~gamma expr =
118 #<If:TYPER $minlevel 10> (* <---------- DEBUG *)
119 OManager.printf "@[TYPING:@ %a@]@." QmlPrint.pp#expr expr ;
120 #<End> ; (* <---------- END DEBUG *)
121 (* Gory detail to workaround the fact that while typechecking we don't have
122 the global annotation map with positions of the items of source code. And
123 we need this information to reveal precise location of typing error: to
124 report errors, use the annotmap we got as input and not the one we
125 obtained after type inference since the first one is the one that contains
126 source locations. Moreover, in case the inference failed, anyway we may
127 not yet have the annotations map of the type inference since this latter
128 failed !
129 If we were provided no annotations map, then use an empty one.
130 So we make this "global" annotation map available here by side effect. *)
131 W_ReportErrors.set_annotmap_for_error_report annotmap ;
132 (* Create the typing environment under a form suitable for the type
133 inference from the QML environment we were provided. *)
134 let typing_env = W_TypingEnv.from_qml_typing_env gamma in
135 try
136 (* Now, really infer the type fo the expression. *)
137 #<If:TYPER $minlevel 9> (* <---------- DEBUG *)
138 OManager.printf "typer_w: infer start@." ;
139 #<End> ; (* <---------- END DEBUG *)
140 W_TypingEnv.new_empty_variables_mapping () ;
141 let (ty, infered_annotmap) =
142 W_Infer.infer_expr_type ~bypass_typer typing_env expr in
143 W_TypingEnv.release_variables_mapping () ;
144 #<If:TYPER $minlevel 9> (* <---------- DEBUG *)
145 OManager.printf "typer_w: infer end@." ;
146 #<End> ; (* <---------- END DEBUG *)
147 (* Now, convert the obtained type and the annotations map obtained after
148 inference into a QML type and annotations map. *)
149 let (qml_ty, qml_infered_annotmap) =
150 convert_to_qml
151 ~expr ~inferred_ty: ty ~inference_result_annotmap: infered_annotmap in
152 #<If:TYPER $minlevel 9> (* <---------- DEBUG *)
153 OManager.printf "typer_w: annotmap export stop@." ;
154 #<End> ; (* <---------- END DEBUG *)
155 (* Merge the initially provided and inferred annotations maps, preferring to
156 keep the types of the second and the positions of the first.*)
157 let result_qml_annotmap =
158 (match annotmap with
159 | Some ann -> QmlAnnotMap.unsafe_mixed_overwrite ann qml_infered_annotmap
160 | None ->
161 (* No initially provided annotation map, hence the result is simply
162 the one we obtained after the inference. *)
163 qml_infered_annotmap) in
164 #<If:TYPER $minlevel 12> (* <---------- DEBUG *)
165 QmlPrint.debug_QmlAst_annotmap qml_infered_annotmap ;
166 #<End> ; (* <---------- END DEBUG *)
167 (gamma, result_qml_annotmap, qml_ty)
168 with killed_by ->
169 (
170 (* First, to allows opatop to continue after the error was reported, we
171 must reset the current binding level, in case where the exception who
172 killed us prevented the correct matching of [begin_definition] and
173 [end_definition] calls. This will prevent next phrases to be (wrongly)
174 typechecked starting with a binding level greater that 0. *)
175 W_CoreTypes.reset_toplevel_binding_level_on_error () ;
176 (* Same thing for the current variables mapping. *)
177 W_TypingEnv.reset_empty_variables_mapping_on_error () ;
178 (* Now, have a look at who killed us to issue an error message. *)
179 match killed_by with
180 | W_Unify.Unification_simple_type_conflict (ty1, ty2, detail) ->
181 (* Case of error during unification but with no more precise error
182 diagnosis. *)
183 (* Recover by side effect the annotation map that really contains
184 source locations. *)
185 let annotmap_for_err_report =
186 W_ReportErrors.get_annotmap_for_error_report () in
187 let err_ctxt =
188 QmlError.Context.annoted_expr annotmap_for_err_report expr in
189 QmlError.error err_ctxt
190 "@[Types@ @{<red>%a@}@ and@ @{<red>%a@}@ are@ not@ compatible@]%a"
191 W_PrintTypes.pp_simple_type_start_sequence ty1
192 W_PrintTypes.pp_simple_type_end_sequence ty2
193 W_ReportErrors.pp_unification_conflict_detail detail
194 | W_InferErrors.Infer_detailled_unification_conflict
195 (context, ty1, ty2, detail) ->
196 (* Case of error during unification with a precise error context (i.e.
197 expression of pattern, in other words language construct)
198 description. *)
199 W_ReportErrors.report_unification_conflict_with_context
200 typing_env (context, ty1, ty2, detail)
201 | W_InferErrors.Infer_private_type_not_opaque (name, body, whole_ty,
202 prv_ty) ->
203 let annotmap_for_err_report =
204 W_ReportErrors.get_annotmap_for_error_report () in
205 let err_ctxt =
206 QmlError.Context.annoted_expr annotmap_for_err_report body in
207 QmlError.error err_ctxt
208 ("@[Definition@ @{<red>%s@}@ of@ type@ @{<red>%a@}@ could@ " ^^
209 "not@ be@ generalized@ because@ it@ contains@ a@ private@ " ^^
210 "type@ @{<red>%a@}@ not@ turned@ opaque@]@\n" ^^
211 "@[<2>@{<bright>Hint@}:@\n" ^^
212 "@[Definition@ probably@ contains@ a@ @{<bright>@@wrap@}@ " ^^
213 "directive@ not@ coerced@ into@ a@ named@ @{<bright>private@}@ " ^^
214 "type.@ Consider@ adding@ a@ type@ annotation.@]@]")
215 (Ident.to_string name)
216 W_PrintTypes.pp_simple_type_start_sequence whole_ty
217 W_PrintTypes.pp_simple_type_end_sequence prv_ty
b4ea47d @fpessaux [cleanup] Typer errors: Move/change some exceptions to be sure to have s...
fpessaux authored
218 | W_InferErrors.Infer_bypass_type_not_found (bp_key, bp_expr) ->
219 let annotmap_for_err_report =
220 W_ReportErrors.get_annotmap_for_error_report () in
221 let err_ctxt =
222 QmlError.Context.annoted_expr annotmap_for_err_report bp_expr in
223 QmlError.error err_ctxt
224 "Unable@ to@ type@ bypass@ @{<red>%s@}.@\n"
225 (BslKey.to_string bp_key)
fccc685 Initial open-source release
MLstate authored
226 | W_SchemeGenAndInst.Non_generalizable_type_var (global_ty, var_ty)
227 | W_SchemeGenAndInst.Non_generalizable_row_var (global_ty, var_ty)
228 | W_SchemeGenAndInst.Non_generalizable_column_var (global_ty, var_ty) -> (
229 (* Let's make only one case for these 3 similar exceptions and make
230 the error message slightly differ according to the kind of faulty
231 variable. *)
232 let var_kind_str =
233 (match killed_by with
234 | W_SchemeGenAndInst.Non_generalizable_type_var _ -> "type"
235 | W_SchemeGenAndInst.Non_generalizable_row_var _ -> "row"
236 | W_SchemeGenAndInst.Non_generalizable_column_var _ -> "column"
237 | _ -> assert false) in
238 let annotmap_for_err_report =
239 W_ReportErrors.get_annotmap_for_error_report () in
240 let err_ctxt =
241 QmlError.Context.annoted_expr annotmap_for_err_report expr in
242 QmlError.error err_ctxt
243 ("@[In@ type@ @{<red>%a@},@ %s@ variable@ @{<red>%a@}@ cannot@ " ^^
244 "be@ generalized.@]@.")
245 W_PrintTypes.pp_simple_type_start_sequence global_ty
246 var_kind_str
247 W_PrintTypes.pp_simple_type_end_sequence var_ty
248 )
249 | other_exn -> raise other_exn
250 )
251
252
253
254 (* ************************************************************************** *)
255 (** {b Descr}: The main module to provide as argument to [QmlMakeTyper] in
256 order to get a high-level typechecker. *)
257 (* ************************************************************************** *)
258 module Main : QmlTypes.QML_LOW_LEVEL_TYPER =
259 struct
260 let type_of_expr =
261 (type_of_expr :
262 ?options: QmlTypes.options ->
263 ?annotmap: QmlAst.annotmap ->
264 bypass_typer: QmlTypes.bypass_typer ->
265 gamma: QmlTypes.gamma ->
266 QmlAst.expr -> (QmlTypes.gamma * QmlAst.annotmap * QmlAst.ty))
267 end
Something went wrong with that request. Please try again.