-
Notifications
You must be signed in to change notification settings - Fork 125
/
surfaceAst.ml
436 lines (364 loc) · 13.7 KB
/
surfaceAst.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
(*
Copyright © 2011 MLstate
This file is part of OPA.
OPA is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.
OPA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
more details.
You should have received a copy of the GNU Affero General Public License
along with OPA. If not, see <http://www.gnu.org/licenses/>.
*)
(**
The OPA Surface AST.
@author David Rajchenbach-Teller
@author Rudy Sicard
*)
(**
{5 Definitions}
*)
type 'a label = 'a QmlLoc.label
(**
{6 Identifiers}
Not-quite-phantom types used to guarantee that we never confuse
unique identifiers and not-made-unique-yet identifiers.
*)
type uids = Ident.t
(**
A key to determine the (non)-equality of identifiers.
This is useful as the same source code can often contain two
identical identifiers (say [x]) with different definitions (say
[let x = 1 in let x = 2 in e]). While here both identifiers will
be called [x], they will have distinct hashes.
*)
type nonuid = string
(**A name as parsed in the source*)
let hash : string -> string -> uids =
fun name description -> Ident.next ~descr:description name
(** Generate a unique hash for a name.
Usage: [hash name description]. *)
let string_of_hash : uids -> string = Ident.stident
(**
{6 Expressions}
*)
(**
{7 Other expressions}
*)
type bind_directives = QmlAst.userland_visibility_directive (* TODO Move expand here *)
(**
Internal data structures.
Not all of these data structures are visible in the concrete syntax.
For instance, the concrete syntax offers [text] (Unicode ropes)
instead of [string] (character-neutral array-style strings).
*)
type const_expr_node =
| CInt of Big_int.big_int
| CFloat of float
(* | CFixed of fixed*)(**This is actually a user-level data structure.*)
| CString of string (**A UTF-8 encoded string.*)
and const_expr = const_expr_node label (* cf libqmlcompil/qmlLoc.ml *)
type ('ident, 'dir) record = ('ident, 'dir) record_node label
and ('ident, 'dir) record_node = (string * ('ident, 'dir) expr) list
(**
Type of an expression
@param 'ident The type of identifiers: either [nonuid] until identifiers have been made unique or [uids] once they have
@param 'dir The type of directives, i.e. stuff left by the compiler for a further phase to rewrite.
*)
and ('ident, 'dir) expr = ('ident, 'dir) expr_node label
and 'ident bind_ident = {ident :'ident ; directives : bind_directives list}
and ('ident, 'dir) expr_node =
| Apply of ('ident, 'dir) expr * ('ident, 'dir) record
(**
We may add a support for labeled arguement.
For now, those records are tuples ("f1", "f2", etc.)
*)
| Lambda of 'ident pat_record_node * ('ident, 'dir) expr
(**
cf remark for Apply node, about labeled argument.
*)
| Const of const_expr_node
| Ident of 'ident
| LetIn of bool (* rec *) * ('ident * ('ident, 'dir) expr) list * ('ident, 'dir) expr
| Match of ('ident, 'dir) expr * ('ident pat * ('ident, 'dir) expr) list
| Record of ('ident, 'dir) record_node
| ExtendRecord of ('ident, 'dir) record_node * ('ident, 'dir) expr (**[ExtendRecord r e] extends
the result of [e] with the
fields defined in [r].*)
| Dot of ('ident, 'dir) expr * string
| Bypass of BslKey.t (**A primitive, handled through the Bypass Standard Library*)
| DBPath of ('ident, 'dir) dbelt * QmlAst.Db.kind
| Directive of ('ident, 'dir) directive
(**
Instruction for a later compilation phase.
Usage: [Directive (directive, human_readable_name, lazy expr, how_to_type)].
[human_readable_name] is used only for pretty-printing
To obtain the type of the expression, apply [how_to_type] to the
type of [lazy expr] (only if lazy_expr is a one element list).
Expressions which should not be typeable (typically because they
are expected to be rewritten away before reaching the typer) should
have type None.
*)
and ('ident, 'dir) directive = 'dir * ('ident, 'dir) expr list * 'ident ty list
(**
{6 Database}
*)
and ('ident, 'dir) dbelt = ('ident, 'dir) dbelt_node label
and ('ident, 'dir) dbelt_node = ('ident, 'dir) preprocessed_db_element list
and ('ident, 'dir) preprocessed_db_element = ('ident, 'dir) preprocessed_db_element_node label
and ('ident, 'dir) preprocessed_db_element_node =
| FldKey of string
| ExprKey of ('ident, 'dir) expr (* not [expr_node], because consecutive labels, but unequal positions, because of brackets *)
| NewKey
(**
{6 Pattern}
*)
and 'ident pat = 'ident pat_node label
and 'ident pat_node =
| PatRecord of 'ident pat_record_node * QmlAst.pat_rowvar
| PatAny
| PatConst of const_expr_node
| PatVar of 'ident bind_ident
| PatCoerce of 'ident pat * 'ident ty
| PatAs of 'ident pat * 'ident bind_ident
and 'ident pat_record_node = (string * 'ident pat) list
(**
{6 Types}
*)
and 'ident ty = 'ident ty_node label
and 'ident ty_node =
| TypeConst of const_ty_node
| TypeVar of 'ident typevar
| TypeArrow of 'ident arrow_t_node
| TypeRecord of 'ident row_t_node
| TypeSumSugar of 'ident sum_t list
| TypeNamed of 'ident typeinstance_t_node
| TypeExternal
| TypeForall of 'ident typeforall
| TypeModule of 'ident fields_t_node
and 'ident typeforall = 'ident typevar list * 'ident ty
and 'ident typeinstance_t= 'ident typeinstance_t_node label
and 'ident typeinstance_t_node = 'ident typeident * 'ident ty list
and 'ident arrow_t = 'ident arrow_t_node label
and 'ident arrow_t_node = 'ident row_t * 'ident ty (**The type of a function.*)
and 'ident sum_t = 'ident sum_t_node label
and 'ident sum_t_node =
| SumName of 'ident typeinstance_t_node
| SumRecord of 'ident row_t_node (* warning: the typer won't be able to deal with row variables in columns *)
| SumVar of 'ident colvar
and 'ident fields_t_node = (string * 'ident ty) list
and 'ident row_t = 'ident row_t_node label
and 'ident row_t_node = TyRow of 'ident fields_t_node * 'ident rowvar option
and 'ident typevar = Flatvar of 'ident(**Type variables, e.g. ['a], ['b], etc.*)
and 'ident typeident = Typeident of 'ident(**Type identifiers, e.g. [list], [int]*)
and const_ty_node =
| TyInt
| TyFloat
| TyString
and 'ident rowvar = Rowvar of 'ident
and 'ident colvar = Colvar of 'ident
(**
{6 Declarations}
*)
and ('ident, 'dir) code_elt = ('ident, 'dir) code_elt_node label
and ('ident, 'dir) code_elt_node =
| Database of 'ident * string list * QmlAst.Db.options list
| NewDbDef of (('ident, 'dir) expr, 'ident ty) QmlAst.Db.db_def
| NewType of 'ident typedef list
| NewVal of ('ident pat * ('ident, 'dir) expr) list * bool (* rec *)
(* after dependency analysis, toplevel mutually recursive functions
* are regrouped in a NewVal *)
| Package of [`declaration | `import | `import_plugin] * string
and type_def_visibility =
| TDV_public (** Type definition is public, visible from anywhere. *)
| TDV_abstract (** Type definition is visible from anywhere but internal
representation is only visible inside the hosting package. Since
at parsing stage we don't know yet the currently compiled package,
the name of the package is not set and its determination is delayed
upon we create a QML visibility information. *)
| TDV_private (** Type definition is not exported outside the hosting
package, i.e. doesn't appear in the package's interface. Same remark
than above about the package name. *)
and 'ident typedef = 'ident typedef_node label
and 'ident typedef_node = {
ty_def_options : QmlAst.ty_def_options ;
ty_def_visibility : type_def_visibility ;
ty_def_name : 'ident typeident ;
ty_def_params : 'ident typevar list ;
ty_def_body :'ident ty
}
type ('ident, 'dir) code = ('ident, 'dir) code_elt list (**One (or more) complete source file(s)*)
(**
{5 The ast for pattern matching on xml }
*)
type 'expr namespace = {namespace : 'expr ; name : string label}
type 'expr xml_suffix =
| Xml_star
| Xml_plus
| Xml_question
| Xml_number of 'expr
| Xml_range of 'expr * 'expr
type 'expr xml_pattern_attribute_value =
| XmlExists
| XmlName
| XmlAttrStringParser of 'expr
| XmlAttrParser of 'expr
type 'expr xml_pattern_attribute =
(* string is a unique name used by the parser generator *)
'expr namespace * string option * 'expr xml_pattern_attribute_value
type 'expr xml_pattern =
| XmlLetIn of (string * 'expr) list * 'expr xml_pattern (* this node allows to bind namespaces *)
| XmlExpr of 'expr
| XmlNode of 'expr namespace *
'expr xml_pattern_attribute list *
'expr xml_named_pattern list
| XmlAny
| XmlParser of 'expr Trx_ast.item list (* no disjunction allowed to avoid parsing ambiguities *)
(* should we bring a node XmlSuffix -> we can write this in the syntax
already anyway
but then what about <toto a={e}>*
*)
and 'expr xml_named_pattern = string option * 'expr xml_pattern * 'expr xml_suffix label option
and 'expr xml_rule = 'expr xml_named_pattern list * 'expr (* one line of parser *)
type 'expr xml_parser =
'expr xml_rule list (* the alternatives *)
(**
{5 Various shorthands for directives}
*)
type magic_directive =
[ `magic_to_string
| `magic_to_xml
| `magic_do
(**
this directive is no longer used for executing a list of funaction,
this is just there for keeping the 'do' syntax when we reprint a parsed
opa code.
this directive is removed during the transformation into QmlAst.
*)
| `typeof
| `specialize of [ `strict | `polymorphic ]
]
type string_directive = [ `string ]
type internationalization_directive = [
| `i18n (* indicate a point of translation *)
| `i18n_lang (* return the current context lang, add a directive to later prune js code pattern matching at running time *)
]
type error_directive =
[ `assert_
]
type coding_directive = [
| `deprecated
| `todo
]
type insert_server_directive =
[ `server_entry_point
]
type concurrency_directive =
[ `spawn
| `wait
| `callcc
| `atomic
| `thread_context
| `with_thread_context
| `no_client_calls
| `throw
| `catch
| `may_cps
| `async
]
type distribution_directive = QmlAst.slicer_directive
type file_inclusion_directive =
[ `static_content of string (*Relative file name*)* bool (*[true] if a [string] is expected, [false] if a [-> string] is expected*)
| `static_resource of string (*Relative file name*)
| `static_content_directory of string (*Relative file name*)* bool (*[true] if a [string] is expected, [false] if a [-> string] is expected*)
| `static_resource_directory of string (*Relative file name*)
]
type access_directive =
[ `private_ (* visible only in the current module *)
| `public (* visible to everyone *)
| `package (* visible only in the current package *)
]
type hack_directive =
[ `unsafe_cast
| `fail
| `tracker of PassTracker.t
| `expand of Big_int.big_int option
| `compiletime of string (* see pass_CompileTimeDirective *)
| `opacapi (* see Opacapi, and checkopacapi *)
]
type type_directive =
[ `coerce
| `unsafe_cast
| `nonexpansive
| `opensums
| `openrecord
| `module_
| `module_field_lifting
| `warncoerce
]
type other_directive =
[ `fun_action
| `js_ident
| `sliced_expr (** the expressions is a two elements containing first the client expression and then the server expression *)
| `llarray
(** cf doc in QmlAst *)
| `recval (** see QmlAst *)
]
type alpha_renaming_directive =
[ `open_ (** not used anymore *)
| `toplevel_open
| `module_
| `toplevel
]
(**
path * access
*)
type documentation_directive =
[ `doctype of string list * QmlAst.doctype_access_directive ]
type opavalue_directive = [
| `stringifier
| `comparator
| `serializer
| `xmlizer
]
type closure_instrumentation_directive = QmlAst.closure_instrumentation_directive
type basic_directive =
[ magic_directive
| string_directive
| internationalization_directive
| coding_directive
| error_directive
| concurrency_directive
| file_inclusion_directive
| hack_directive
| type_directive
| other_directive
| documentation_directive
| insert_server_directive
| opavalue_directive
| `create_lazy_record
| distribution_directive
| closure_instrumentation_directive
]
(** these directives are the ones that are not taken care of in the surfaceAst
they go straight to qml (or fail at the conversion when not implemented)
If you are adding a directive that needs to go though opa to be taken care of
in qml, it must end up in this type
*)
type dependency_directive =
[ basic_directive
| access_directive
| `local of uids ]
type renaming_directive =
[ access_directive
| basic_directive
| alpha_renaming_directive ]
type parsing_directive =
[ `xml_parser of (string, parsing_directive) expr xml_parser
| `parser_ of (string, parsing_directive) expr Trx_ast.expr
| renaming_directive ]
type all_directives =
[ parsing_directive
| dependency_directive
| renaming_directive ]