/
opa_parser.trx
1327 lines (1158 loc) · 47.4 KB
/
opa_parser.trx
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
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
(*
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 general OPA parser, with HMX.
@TODO: Rule [deco] should return the correct line/char number,
which requires either advanced TRX hackery or a preliminary phase
to associate to each file a mapping from char number to line/column number.
*)
read opa_lexer.trx
read parser_path.trx
read string_expr.trx
read action.trx
read xml.trx
read css.trx
read trx.trx
read xml_parser.trx
%%imperative-errors = true
%%opt-errors = true
{{
open SurfaceAst
open Parser_utils
module SA = SurfaceAst
(* some types for IDEs; please maintain this in particular when you add/remove/change directives *)
(* IF YOU WANT TO CHANGE THIS UPDATE THE IDE REPO *)
type fixed_code_for_ide = (string, parsing_directive) code
}}
(**
General convention:
each rule exists in two versions
- [just_foo], which performs the actual parsing and returns the result
- [foo], which is defined as
[deco = deco just_foo]
As a general guideline, you should always call rule [foo] from your other rules,
never [just_foo].
*)
(**
{6 Entry points}
*)
;main <- init declarations:d {{ d }}
;+main_eoi : {(SurfaceAst.nonuid, SurfaceAst.parsing_directive) SurfaceAst.code} <- init declarations:d !. {{ d }}
;+expr_eoi : {(SurfaceAst.nonuid, SurfaceAst.parsing_directive) SurfaceAst.expr} <- init expr:e spacing !. {{ e }}
;+ty_eoi : {SurfaceAst.nonuid SurfaceAst.ty} <- init typ:t spacing !. {{ t }}
(**
{6 Initialization}
*)
init <- _succeed {{ Parser_utils.filename := _filename }}
(**
{6 Stuff for IDEs}
*)
;+maybe_declaration : {[`failure of string * Trx_runtime.pos * Trx_runtime.pos
| `success of (SurfaceAst.nonuid, SurfaceAst.parsing_directive) SurfaceAst.code ]} <-
/ declaration:d {{ `success (d : (string, parsing_directive) code) }}
/ ((!declaration .)+ $_):d {{ `failure (d, _pos_beg, _pos_end) }} ;
(**
{6 Declarations}
A toplevel open is rewritten into [_ = @toplevel_open(e)]
*)
;declarations <- spacing (=list0(declaration,semic?)):l semic? spacing {{ List.flatten l }}
;declaration <- (=deco(just_declaration)):p {{ let (l,label) = p in List.map (fun x -> (x, copy_label label)) l }}
;/** toplevel declaration **/
just_declaration <-
/ (_succeed {{ clear_hints () }}) _fail {{ assert false }}
/ (pos:p !(spacing "=") {{ push_hint (`declaration p) }}) _fail {{ assert false }}
/ database:d {{ d }}
/ declaration_directives:dirs Opa_lexer.REC (=list1(rec_binding_pat, and)):bindings {{
let bindings = declaration_directive dirs bindings in
[NewVal (bindings,true)]
}}
(* this case needs to come before val_binding so that css = ... is parsed by this rule *)
/ Css.css:d {{ [d] }}
/ declaration_directives:dirs deco_fun_binding:d
{{ let ident,e = d in
let bindings = [var_to_patvar ident, e] in
let bindings = declaration_directive dirs bindings in
[NewVal (bindings,false)] }}
(* this case needs to come before pattern so that f (2) doesn't get parsed *)
/ (=deco(ml_identifier_nosp:i strict_spacing lpar)):p {{ error_fun_space (label p) }}
/ declaration_directives:dirs val_binding:b {{ [NewVal (declaration_directive dirs [b], false)] }}
(* 'do' is a keyword, so situation like do(1,2) is not ambiguous *)
/ do_block:b {{ [NewVal ([b],false) ] }}
/ typedef_directives:dirs Opa_lexer.TYPE (=list1(type_binding,Opa_lexer.AND)):typedefs
{{
let ty_def_options, visibility_dirs = dirs in
(* First, update the visibility of each individual defined type with the
visibility directives that are global here for all types
and-defined. *)
let updated_typedefs =
List.map
(fun (ty_def, pos) ->
(*
merging the options between the global (before the type keyword)
and the local options, in case of several definitions
*)
let ty_def_options =
let global = ty_def_options in
let local = ty_def.SurfaceAst.ty_def_options in
Parser_utils.merge_type_def_options ~global ~local
in
let updated_visibility =
Parser_utils.merge_type_def_visibility
(ty_def.SurfaceAst.ty_def_visibility :: visibility_dirs) pos
in
({ ty_def with SurfaceAst.
ty_def_options ;
ty_def_visibility = updated_visibility ;
},
pos))
typedefs in
[NewType updated_typedefs]
}}
/ (=Opa_lexer.exact_ident("package")) package_identifier:name {{ [Package (`declaration, name)] }}
/ (=Opa_lexer.exact_ident("import-plugin")) package_expr_list:s {{ [Package (`import_plugin, s)] }}
/ (=Opa_lexer.exact_ident("import")) package_expr_list:s {{ [Package (`import, s)] }}
/ (&. {{ print_hints () }}) _fail {{ assert false }}
; typedef_directives <-
/ ("@" !strict_spacing deco_ml_identifier_nosp:v spacing {{ undecorate v }})*:list
{|
(*
Return in case of a syntax error,
the production {| will return None, and trx gets a syntax error
*)
Return.set_checkpoint_none (
fun label ->
let parse_error () = Return.return label () in
let rec fold (ty_def_options, visibility_dirs) = function
| "abstract" ->
let visibility_dirs = SurfaceAst.TDV_abstract :: visibility_dirs in
ty_def_options, visibility_dirs
| "private" ->
let visibility_dirs = SurfaceAst.TDV_private :: visibility_dirs in
ty_def_options, visibility_dirs
| "opacapi" ->
let ty_def_options =
{ ty_def_options with QmlAst.
opacapi = true ;
} in
ty_def_options, visibility_dirs
| _ -> parse_error ()
in
let ty_def_options = QmlAst.ty_def_options in
List.fold_left fold (ty_def_options, []) list
)
|}
; /** package **/
package_identifier <- spacing ([a-zA-Z0-9_.\-]+ $_):s {{ s }}
; /** package expression **/
package_expr <- spacing package_expr_no_spacing+:l {{ String.concat "" l }}
package_expr_no_spacing <-
/ [a-zA-Z0-9_.\-*]+ $_
/ "{" package_expr_list:s rbrace {{ s }}
package_expr_list <-
(=list1(package_expr,comma)):l
{{ Base.String.sconcat ~left:"{" ~right:"}" "," l }}
;/** file path **/
file_path <- [ a-zA-Z0-9-._~]* '/' [ a-zA-Z0-9-._/~]* $_
;/** network hostname (or IPv4 address) **/
network_hostname <- [a-zA-Z0-9-.]+ $_
;/** colon and network server port **/
network_port <- Opa_lexer.colon_nosp Opa_lexer.int:p {{ p }}
(**
{6 Database}
*)/** database declaration **/
database <-
(* single database, short form and full form *)
/ Opa_lexer.DATABASE spacing file_path:s {{ [Database ("database", [], [`engine (`db3 (Some s))])] }}
/ Opa_lexer.DATABASE spacing db_options:dbo {{ [Database ("database", [], dbo)] }}
(* many-db or one, but named, db *)
/ Opa_lexer.DATABASE ml_identifier:i assign spacing db_options:dbo {{ [Database (i, [i], dbo)] }}
(* a common error *)
/ Opa_lexer.DATABASE deco_ml_identifier:e !assign {{ error_db_file_without_slash e }}
(* other db specifications *)
/ (=exact_ident("db")) db_pathdef:d db_virtual?:v
{{ match v with
| None -> d
| Some v ->
match d with
| (NewDbDef(
QmlAst.Db.Db_TypeDecl(l,_)
| QmlAst.Db.Db_Default(l,_)
| QmlAst.Db.Db_Alias(l,_)
| QmlAst.Db.Db_Constraint(l,_)))::_ ->
d@[NewDbDef(QmlAst.Db.Db_Virtual(l, v))]
| _ -> assert false (* see db_pathdef *)
}}
/** database path declaration **/
db_pathdef <-
/ Parser_path.pathdef_type:l colon typ:t (assign expr:e{{e}})?:o
{{ let dec = [NewDbDef(QmlAst.Db.Db_TypeDecl(l, t))] in
match o with
| None -> dec
| Some e -> NewDbDef(QmlAst.Db.Db_Default(l, e)) :: dec
}}
/ Parser_path.pathdef:l assign expr:e
{{ [NewDbDef(QmlAst.Db.Db_Default(l, e))] }}
/ (Parser_path.pathdef / (=exact_ident("/")) {{ [] }}):l (=exact_ident("alias")) Parser_path.pathdef:l2
{{ [NewDbDef(QmlAst.Db.Db_Alias(l, l2))] }}
/ Parser_path.pathdef:l db_constraint:c
{{ [NewDbDef(QmlAst.Db.Db_Constraint(l, c))] }}
/** database constraint **/
db_constraint <-
/ (=exact_ident("full")) {{ QmlAst.Db.C_Private }}
/** database virtual path **/
db_virtual <-
/ (=exact_ident(":=")) expr:e {{ e }}
/** database options **/
db_options <-
/ "@" "local" Opa_lexer.lpar_nosp spacing '"' file_path:s '"' rpar {{ [`engine (`db3 (Some s))] }}
/ "@" "local" {{ [`engine (`db3 None)] }}
/ "@" "light" Opa_lexer.lpar_nosp spacing '"' file_path:s '"' rpar {{ [`engine (`db3light (Some s))] }}
/ "@" "light" {{ [`engine (`db3light None)] }}
/ "@" "meta" {{ [`engine (`meta)] }}
/ "@" "shared" Opa_lexer.lpar_nosp spacing '"' network_hostname?:h network_port?:p '"' rpar {{ [`engine (`client (h, p))] }}
/ "@" "shared" {{ [`engine (`client (None, None))] }}
(**
{6 Bindings}
Bindings or assimilated (like do)
*)
(* Regrouped here so that toplevel bindings and local bindings reuse the same rules *)
may_coerce <- (colon typ:t{{t}})?
;let deco_fun_binding_gen Ident =
Ident:ident function_parameters_nosp+:argss may_coerce:t assign expr:e
{{ let e = List.fold_right (fun (args,label) acc -> args_expr_to_lambda ~zero_ary:label args acc) argss (may_coerce_expr e t) in
(ident, e) }}
deco_fun_binding <- (=deco_fun_binding_gen(deco_ml_identifier_nosp))
/** function binding **/
fun_binding <- deco_fun_binding:d {{ let (i,e) = d in (undecorate i, e) }}
fun_binding_ <- deco_fun_binding:d {{ let (i,e) = d in (var_to_patvar i, e) }}
/** pattern binding **/
val_binding <- pattern:p assign expr:e {{ (p,e) }}
/** identifier binding **/
ident_binding <- fun_binding
/ ml_identifier:i may_coerce:t assign expr:e {{ (i,may_coerce_expr e t) }}
(* this rule is meant for modules only, where the fact of writing a rec doesn't matter
* but you must write to be able to write rec val ... *)
rec_ident_binding <-
/ Opa_lexer.REC? ident_binding:b {{ b }}
/ Opa_lexer.REC (=deco((=exact_ident("val")))):o ident_binding:b {{
let (_, label) = o in
let (i, e) = b in
(i, (Directive (`recval, [e], []), label))
}}
binding_pat <- fun_binding_ / val_binding
rec_binding_pat <- (=deco((=exact_ident("val"))))?:o binding_pat:b
{{ let _ = (b : string pat * (_,_) expr) in
let r =
match o with
| None -> b
| Some (_, label) ->
let (p, e) = b in
(p, (Directive (`recval, [e], []), label)) in
r : string pat * (_,_) expr
}}
/** long binding **/
long_ident_nosp <- deco_ml_identifier_nosp:i ('.' deco_ml_identifier_nosp:i {{i}})*:l {{ i :: l }}
long_ident <- spacing long_ident_nosp:l {{ l }}
long_binding <- (=deco_fun_binding_gen(long_ident_nosp))
/ long_ident:i may_coerce:t assign expr:e {{ (i,may_coerce_expr e t) }}
;/** do block **/
do_block <- Opa_lexer.DO expr:e {{ let e = magic_do e in
let p = (PatAny, nlabel e) in
(p,e)
}}
;/** type binding **/
type_binding = deco(just_type_binding)
;just_type_binding <-
/ type_const:s {{ error_redefinition_basic_type s }}
/ !external typedef_directives:dirs type_identifier:i (lpar (=list1(just_flatvar,comma)):l rpar {{l}})?:o assign typ:t
{{
let _,loc = t in
let l = Option.default [] o in
let ty_def_options, visibility_dirs = dirs in
(* Record the visibility of the type definition. However, since the parser
can't know yet which package it is processing, we delay the
determination of the package to later. For the moment, it is just
sufficient to know if the definition is public, private or abstract.
Note that the visibility set in the definition is the one attached to
the type individually defined at this point. If some directives are
set outside for the bunch of types defined in the global type
definition, they will be taken into account (and hence modify the
visibility of the current type) afterwards. *)
let visibility = Parser_utils.merge_type_def_visibility visibility_dirs loc in
{
SurfaceAst.ty_def_options ;
SurfaceAst.ty_def_visibility = visibility ;
SurfaceAst.ty_def_name = Typeident i ;
SurfaceAst.ty_def_params = l ;
SurfaceAst.ty_def_body = t ;
} : string typedef_node
}}
(**
{6 Patterns}
*)
(**
Function parameters, ie the [((a,b))] in [f((a,b)) = ...]
*)
;/** function parameters **/
function_parameters_nosp <- (=careful_deco(just_function_parameters_nosp)):l {{ l }}
;just_function_parameters_nosp <- Opa_lexer.lpar_nosp (=list0(pattern,comma)):l rpar {{ l }}
(**
{7 Tuples}
Tuple pattern
(a,b,c,...)
(a,) is a 1-uple, () doesn't exists
it may contain [...] (like (a,...) but [(...)] and [(,...)] are not valid
*)
/** tuple pattern or parenthized pattern **/
tuple_pat <- lpar tuple_pat_inside:p rpar {{ p }}
tuple_pat_inside <- (=list1(pattern,comma)):l tuple_pat_end:e
{{ match l,e with
| [p], `nothing -> undecorate p
| _ , _ -> undecorate (coerce_name_pat (tuple_pat l) (tuple_string l))
}}
tuple_pat_end <- comma {{ `tuple1 }}
/ _succeed {{ `nothing }}
;row_pattern <- (=exact_symbol("...")) {{ () }}
(**
{7 Record pattern}
A record may be empty: [{}]
A record can contain an ellipsis (even the empty record): [{...}]
*)
tilda <- (spacing "~")?:o {{ Option.is_some o }}
/** record pattern **/
record_pat <-
(* null case only for speed, very common: *)
/ tilda lbrace rbrace {{ PatRecord ([], `closed) }}
/ tilda:tilda lbrace record_pat_inside:ri rbrace
{{ let (f,row) = ri in
let l = default_value_in_pat_record tilda f in
match row with
| None -> undecorate (record_pat l)
| Some () -> PatRecord (encode_record l, `open_)
}}
;record_pat_inside <- (=list0(field_pat,(spacing semic? $))):l semic? row_pattern?:r {{ (l,r) }}
;field_pat <- tilda:tilda deco_ml_identifier:i may_coerce:t (assign pattern:p {{ p }})?:p
{{ let ident,label = i in
let p =
match p,tilda with
| None,true -> `value (var_to_patvar i)
| None,false -> `novalue i
| Some p,true -> `value (PatAs (p,{ident=ident;directives=[]}),label)
| Some p,false -> `value p in
(ident, p, t)
}}
(**
{7 List patterns}
*)
list_pat <-
/ lbracket (=list0(pattern,comma)):l pos:p comma? (Opa_lexer.BAR pattern:p {{p}})?:tl rbracket
{{ undecorate (list_pat_of_pat_list ?tl l p) }}
(**
{7 Patterns}
A pattern is a basic pattern, with optionally a 'as' and a coerce around it
*)
;/** pattern **/
pattern = deco just_pattern_as_coerce
;just_pattern_as_coerce <- pattern_as:p (colon typ:te {{ te }})?:o
{{ match o with
| None -> undecorate p
| Some te -> PatCoerce (p, te)
}}
;pattern_as = deco just_pattern_as
;just_pattern_as <- pattern_no_as_coerce:p (Opa_lexer.AS ml_identifier:v {{ v }})?:o
{{ match o with
| None -> undecorate p
| Some i -> PatAs (p,{ident=i;directives=[]})
}}
;pattern_no_as_coerce = deco just_pattern_no_as_coerce
;just_pattern_no_as_coerce <-
Opa_lexer.UNDERSCORE {{ PatAny }}
/ ml_identifier_nosp:i !"(" {{ PatVar {ident=i;directives=[]} }}
/ const:c {{ PatConst c }}
/ tuple_pat
/ record_pat
/ list_pat
(**
{6 Expressions}
Expressions are divided into differents to take care of operators priorities
- <-
- %
- |
- &
- <
- *
- unary -
- : (coercion)
- and then expressions without operators (at the top)
*)
;/** expression **/
expr <- top_expr
;top_expr = deco just_top_expr;
;expr0 = deco just_expr0;
;expr7 = deco just_expr7;
;expr8 = deco just_expr8;
;expr9 = deco just_expr9;
;expr10 = deco just_expr10;
(**
{7 Operators }
*)
(* no spaces are parsed around operators on purpose
* it is because spaces matters to see if the operators is actually infix
* the infix rule takes care of them *)
let ident_careful_deco rule = (=careful_deco(rule)):t {{let (i,label) = t in (Ident i, label)}}
;OpCont <- !"/*" [.+\-^*/<>=@|&!]
(* Operatort beginning with ('|' [&!.]) are forbidden because parser syntax *)
;OpPipe = ident_careful_deco(!"||" "|" ![&!.] OpCont+ $_ / "@" OpCont* $_)
;OpOr = ident_careful_deco("||" OpCont* $_ / "?" OpCont* $_)
;OpAnd = ident_careful_deco("&" OpCont* $_)
;OpComp = ident_careful_deco( ( "=" OpCont+ $_
/ ( ">" / "<=" / ">=" / "!=" / (!"<-" !Xml.xhtml "<":s {{s}}) ) OpCont* $_))
;OpAdd = ident_careful_deco(!"->" [+\-^] OpCont* $_)
;OpMul = ident_careful_deco("*" OpCont* $_ / !"/*" !"//" "/" OpCont* $_)
;NegOp = ident_careful_deco( "-." !OpCont {{ Opacapi.unary_minus_dot }}
/ "-" !OpCont {{ Opacapi.unary_minus }})
(**
{7 The different levels of expressions }
*)
/** db path write **/
write_expr <- (=deco(larrow)):p expr0:e2 {{ e2 }}
/** side effect expr **/
se_expr = deco just_se_expr;
just_se_expr <-
(* on dom *)
/ pos:p Action.action:a
{{
let l = list_expr_of_expr_list [a] p in
dom_transform l
}}
(* dbpath update *)
/ Parser_path.path_update
/** top expr **/
just_top_expr <-
/ just_se_expr
/ expr0:e1
{{ undecorate e1
}}
just_expr0 <- expr1:e (=exact_symbol("%"))?:o
{{ match o with
| None -> undecorate e
| Some _ -> undecorate (record [("percent",e)])
}}
/ deco_underscore pos:p (=exact_symbol("%"))
{{ undecorate (lambda_to_lambda (fun e -> record [("percent",e)]) p) }}
(* would probably be more efficient to have list1sleft and list1sright *)
/** expression `|' `@' **/
expr1 <- (=list1s(expr2,OpPipe)):v {{ apply_operators `left v }}
/** expression `||' `?' **/
expr2 <- (=list1s(expr3,OpOr )):v {{ apply_operators `right v }}
/** expression `&' **/
expr3 <- (=list1s(expr4,OpAnd )):v {{ apply_operators `right v }}
/** expression `<' `=' **/
expr4 <- (=list1s(expr5,OpComp)):v {{ apply_operators `left v }}
/** expression `+' `-' **/
expr5 <- (=list1s(expr6,OpAdd )):v {{ apply_operators `left v }}
/** expression `*' `/' **/
expr6 <- (=list1s(expr7,OpMul )):v {{ apply_operators `left v }}
/** expression unary '-' **/
just_expr7 <- NegOp?:i expr8:e
{{ match i with
| None -> undecorate e
| Some i -> i &. [e]
}}
/ NegOp:i deco_underscore:p {{ undecorate (apply_f_with_holes i [`hole p]) }}
/** subsumption of sum types **/
just_expr8 <- expr9:e (ltcolon typ:t {{ t }})?:t
{{ match t with
| None -> undecorate e
| Some t -> coerce (directive1 `opensums e, label e) t
}}
/** coerced expression **/
just_expr9 <- expr10:e (colon typ:t {{ t }})?:t
{{ match t with
| None -> undecorate e
| Some t -> coerce e t
}}
/** expression without operators **/
just_expr10 <-
/ function_call_dot (* also contains directives, ids and bypasses *)
/ match
/ lambda
/ letin
/ Parser_path.path_kind:v {{ let (path,access_kind) = v in DBPath (path, access_kind)}}
(* FIXME: useful? / paths_opa_expr / props_aux*)
/ Css.css_map:e {{ undecorate e }} (* useful when saying some_style = ... *)
/ Trx.ExpressionAsFunction:e {{ parser_ e }}
/ Xml.xhtml:v {{ undecorate v }}
/ ip
/ just_module
/ just_record
/ tuple_expr (* or parenthesized expr *)
/ __position__
/ Opa_lexer.CSS lbrace Xml.css_properties:e rbrace {{ undecorate e }}
/ list
/ Opa_lexer.BEGIN expr:e Opa_lexer.END {{ undecorate e }}
/ ml_identifier_nosp:i hint_end_of_callable {{ Ident i }}
/ const:c {{ Const c }}
/ String_expr.string_with_opa:e {{ undecorate e }} (* need to come after const so that constant strings are just parsed as constants *)
/ Css.prop_value_expr_opa:e {{ undecorate e }} (* useful when constructing colors as #123456 *)
(**
{7 Hint utils}
*)
;hint_end_of_callable <- (=careful_deco(& " (")):p {{ push_hint (`function_call (label p)); () }}
/ !"(" $
(*/ (=careful_deco("(")):p {{ error_neither_ident_nor_call (label p) }}*)
(**
{7 Declaration directives}
These directives are linked to the identifier (even if in the ast, they end up
in an expression)
*)
declaration_directive_any <-
/ "specialize_strict" {{ `specialize `strict }}
/ "specialize" {{ `specialize `polymorphic }}
declaration_directive1 <-
/ "deprecated" {{ `deprecated }}
declaration_directive0 <-
/ "async" {{ `async }}
/ "opacapi" {{ `opacapi }}
/ "package" {{ `package }}
/ "public_env" {{ `public_env }}
/ "private" {{ `private_ }}
/ "public" {{ `public }}
/ "expand" {{ `expand None }} (* not allowing anymore to give an integer to expand, could be put back *)
/ slicing_directive0
declaration_directive1_typ <-
/ "stringifier" {{ `stringifier }}
/ "comparator" {{ `comparator }}
/ "serializer" {{ `serializer }}
/ "xmlizer" {{ `xmlizer }}
/** toplevel directive **/
declaration_directives <- (=deco(declaration_directive))*
declaration_directive <-
/ "@" (=exact_ident(declaration_directive1)):v Opa_lexer.lpar_nosp expr:e rpar
{{ (v, [e], []) }}
/ "@" (=exact_ident(declaration_directive0)):v !"("
{{ (v, [], []) }}
/ "@" (=exact_ident(declaration_directive_any)):v Opa_lexer.lpar_nosp (=list0(expr,comma)):el rpar
{{ (v, el, []) }}
/ "@" (=exact_ident(declaration_directive1_typ)):v Opa_lexer.lpar_nosp typ:t rpar
{{ (v, [], [t]) }}
slicing_directive0 <-
/ "both_implem" {{ `side_annotation `both_implem }}
/ "both" {{ `side_annotation `both }}
/ "client" {{ `side_annotation `client }}
/ "prefer_both" {{ `side_annotation `prefer_both }}
/ "prefer_client" {{ `side_annotation `prefer_client }}
/ "prefer_server" {{ `side_annotation `prefer_server }}
/ "publish_async" {{ `visibility_annotation (`public `async) }}
/ "publish" {{ `visibility_annotation (`public `sync) }}
/ "server_private" {{ `visibility_annotation `private_ }}
/ "server" {{ `side_annotation `server }}
/ "no_client_calls" {{ `no_client_calls }}
closure_instrumentation_directive <- "public_env" {{ `public_env }}
local_binding_directive <- "@" (=exact_ident(slicing_directive0
/closure_instrumentation_directive)):v !"("
{{ (v, [], []) }}
local_binding_directives <- (=deco(local_binding_directive:v))*
(**
{7 Directives}
Everything with @ident syntax
*)
;
directive0 <-
/ "i18n_lang" {{ `i18n_lang }}
/ "thread_context" {{ `thread_context }}
/ "todo" {{ `todo }}
/ "toplevel" {{ `toplevel }}
directive1 <-
/ closure_instrumentation_directive
/ "assert" {{ `assert_ }}
/ "atomic" {{ `atomic }}
/ "callcc" {{ `callcc }}
/ "i18n" {{ `i18n }}
/ "js_ident" {{ `js_ident }}
/ "may_cps" {{ `may_cps }}
/ "nonexpansive" {{ `nonexpansive }}
/ "openrecord" {{ `openrecord }}
/ "opensums" {{ `opensums }}
/ "throw" {{ `throw }}
/ "typeof" {{ `typeof }}
/ "unsafe_cast" {{ `unsafe_cast }}
/ "wait" {{ `wait }}
directive2 <-
/ "catch" {{ `catch }}
/ "deprecated" {{ `deprecated }}
/ "with_thread_context" {{ `with_thread_context }}
directive1str <-
/ ("static_source_content" / "static_binary_content") {{ fun x -> `static_content (x, true) }}
/ "compiletime" {{ fun x -> `compiletime x }}
directive1rec <-
/ "lazy_record" {{ `create_lazy_record }}
/ "spawn" {{ `spawn }}
directive1or2str <-
/ "static_content_directory" {{ (fun x -> `static_content_directory (x, false)) }}
/ "static_content" {{ (fun x -> `static_content (x, false)) }}
/ ("static_include_directory" / "static_resource_directory" ) {{ fun x -> `static_resource_directory x }}
/ "static_resource" {{ fun x -> `static_resource x }}
;/** directive **/
directive <-
(* FIXME: could accept assert_message(,_e)(s)
* instead of just assert_message(s,e) *)
/ "@xml(" spacing Xml.xmlns:xmlns rpar {{ undecorate xmlns }}
/ "@typeval(" typ:t rpar {{
(* For convenience, directive [@typeval] is handled as thin syntactic sugar.
Therefore [@typeval(t)] is parsed as [@typeof(@unsafe_cast("dummy_for_typeval"):t)]
*)
let expr_cast = (directive1 `unsafe_cast (void (nlabel t)), nlabel t) in
let expr_coerced = coerce_expr expr_cast t in
let just_typeof = directive1 `typeof expr_coerced in
just_typeof
}}
/ "@" (=exact_ident(directive0)):v !"("
{{ Directive (v,[],[]) }}
/ "@" (=exact_ident(directive1)):v Opa_lexer.lpar_nosp expr:e rpar
{{ Directive (v,[e],[]) }}
/ "@" (=exact_ident(directive1str)):v Opa_lexer.lpar_nosp string:str rpar
{{ Directive (v str,[],[]) }}
/ "@" (=exact_ident(directive1rec)):v Opa_lexer.lpar_nosp (=deco(just_record)):e rpar
{{ Directive (v,[e],[]) }}
/ "@" (=exact_ident(directive2)):v Opa_lexer.lpar_nosp expr:e1 comma expr:e2 rpar
{{ Directive (v,[e1;e2],[]) }}
/ "@" (=exact_ident(directive1or2str)):v Opa_lexer.lpar_nosp string:str (comma expr:e {{ [e] }} / _succeed {{ [] }}):el rpar
{{ Directive (v str,el,[]) }}
/ "@" !strict_spacing deco_ml_identifier_nosp:v (function_arguments_nosp / !"(" {{ [] }}):l
{|
(* the directives in here are the ones that inspect a little too much
* their arguments, and so it is difficult to factorize them *)
let s = undecorate v in
match s with
| "fail" ->
(*
Argument of directive @fail is optional.
Add the empty string in case of no argument.
*)
Return.set_checkpoint_none (
fun parse_error ->
let l =
match l with
| [] ->
let label = label v in
[ SA.Const (SA.CString ""), label ]
| [ _ ] -> l
| _ -> Return.return parse_error ()
in
SurfaceAst.Directive (`fail, l, [])
)
| "llarray" -> Some (SurfaceAst.Directive (`llarray, l, []))
| "sliced_expr" ->
let (client,server) =
match l with
| [(Record l,_)] ->
(match l with
| ["server", server; "client", client] -> (client,server)
| ["client", client; "server", server] -> (client,server)
| _ -> error_sliced_expr (snd v))
| _ -> error_static_record v in
Some (Directive (`sliced_expr, [client; server], []))
| "track" -> (
match l with
| [(Const (CString s1), label); expr] ->
let pos = SurfaceAstHelper.Annot.to_string label in
let tracker = PassTracker.next (Printf.sprintf "%s : %s" s1 pos) in
Some (Directive (`tracker tracker, [ expr ], []))
| [expr] ->
let pos = SurfaceAstHelper.Annot.to_string' expr in
let tracker = PassTracker.next pos in
Some (Directive (`tracker tracker, [ expr ], []))
| _ -> error_directive_wrong_arguments_type v
)
| _ -> None
|}
(**
{7 Position}
*)
;__position__ <-
/ (=deco((=exact_ident("__POSITION__")))):p
{{ let pos = label p in
Const (CString (FilePos.to_string pos.QmlLoc.pos))
}}
(**
{7 Function call, field access and method call}
Function call, field access and method call are left associative and with
the same priority
When taking care of holes, the whole list of application/field access/...
is looked at: [f(_).x(_)] is transformed in [y,z -> f(z).x(z)]
An underscore at the beginning of the series of calls is valid:
[_(x)] means [f -> f(x)], [_.x] means [fun r -> r.x], etc.
*)
/** function calls, field access **/
function_call_dot <-
/ ident_call_dot
/ paren_expr_call_dot
/ (=careful_deco(Opa_lexer.underscore_nosp)):p function_arguments_dot_method_nosp+:params hint_end_of_callable not_assign
{{ make_function2 letins double_dot (`hole (label p)) params }}
/ expr_before_possible_function_call:e ( function_arguments_dot_method_nosp+:params hint_end_of_callable not_assign
{{ fun e -> make_function2 letins double_dot (`expr e) params }}
/ _succeed
{{ fun e -> undecorate e }}):f {{ f e }}
(* Only certain kind of expression can be applied *)
let call_dot func = (=careful_deco(func)):e function_arguments_dot_method_nosp+:params hint_end_of_callable not_assign
{{ make_function2 letins double_dot (`expr e) params }}
;expr_before_possible_function_call = careful_deco just_expr_before_possible_function_call
ident_call_dot <- (=call_dot(just_ident_before_mandatory_function_call))
paren_expr_call_dot <- (=call_dot(just_paren_expr_before_mandatory_function_call))
just_ident_before_mandatory_function_call <-
/ ml_identifier_nosp:i {{ Ident i }}
just_paren_expr_before_mandatory_function_call <-
/ lpar expr:e rpar {{ undecorate e }}
just_expr_before_possible_function_call <-
/ id
/ directive
/ bypass
(**
{7 Id}
*)
id <- (=careful_deco("#")):p deco_ml_identifier_nosp:s
{{ undecorate ((Ident "$",label p) & [string2 s]) }}
/ (=careful_deco("#")):p opa_in_braces_nosp:e
{{ undecorate ((Ident "$",label p) & [e]) }}
naked_id <-
(=careful_deco("#")):p deco_ml_identifier_nosp:s
{{ string2 s }}
/ (=careful_deco("#")):p opa_in_braces_nosp:e
{{ e }}
(**
{7 Pattern matching}
Or if-then-else construct
Disjunctive patterns are allowed only at the toplevel in the pattern:
[match e with p | p -> e] is allowed, not [match o with Some (1|2) -> e]
Disjunctive pattern are removed right away by duplicating the pattern
*)
/** pattern/if then else **/
match <- Opa_lexer.MATCH expr:e Opa_lexer.WITH?
Opa_lexer.BAR? (=list1(rule,match_sep)):l
match_end
{{ Match (e, List.flatten l) }}
/ Opa_lexer.IF expr:e1 Opa_lexer.THEN expr:e2 (Opa_lexer.ELSE expr:e {{ e }})?:o
{{ if_then_else e1 e2 o }}
/ Opa_lexer.IF pos:p1 binding_pat separator pos:p2 Opa_lexer.THEN
{{ Parser_utils.error_bad_compare (union_annot p1 p2) }}
/ Xml_parser.xml_parser
match_sep <- !Opa_lexer.END Opa_lexer.BAR?
match_end <- (Opa_lexer.END $ / (=exact_ident("|_")) $)?
rule <- (=list1(pattern,Opa_lexer.BAR?)):l rarrow expr:e {{ match l with
| [] -> assert false
(* avoid duplication in the usual case where there is only one pattern *)
| h :: l -> (h,e) :: List.map (fun p -> (p,SurfaceAstCons.Refresh.expr e)) l
}}
(**
{7 Lambda}
The syntax is either:
[pattern,pattern,... -> e] (the equivalent of ocaml 'fun')
[| pattern -> e
| pattern -> e
| ... ] (the equivalent of ocaml 'function')
[-> e] which means [{} -> e]
*)
/** anonymous function **/
lambda <-
rarrow expr:e
{{ Lambda ([], e) }}
/ (=list1(pattern,comma)):l rarrow expr:e {{ Lambda (encode_args_as_record l, e) }}
(* making the BAR optional below causes problem
* When it is:
* do a -> b(2)
| c -> d
is understood as
do function a -> b(2)
| c -> d
but
do a -> b
| c -> d
is understood as
fun a -> (function b|c -> d)
*)
/ (=deco(Opa_lexer.BAR)):p (=list1(rule,Opa_lexer.BAR)):l match_end {{ function_ (List.flatten l) (label p)}}
(**
{7 Letin}
Bindings and assimilated
Only identifiers on the left hand side of recursive values
*)
/** local binding **/
letin <- pos:pos1 local_binding_directives:dirs Opa_lexer.REC (=list1pos(rec_binding_pat, and)):l separator pos:pos_f expr:e
{{ let l,posl = l in
push_hint (`same_indents ((pos1::posl) @ [pos_f]));
let l = List.concat_map pat_in_to_simple_bindings l in
let l = declaration_directive dirs l in
LetIn (true, l, e)
}}
/ pos:pos1 local_binding_directives:dirs (binding_pat / do_block):b separator:pos2 expr:e
{{ push_hint (`same_indent (pos1,pos2));
bind_in_to_expr_in dirs b e
}}
/ pos:pos1 Opa_lexer.OPEN (=list1(expr,Opa_lexer.comma)):l separator:pos2 expr:e
{{ push_hint (`same_indent (pos1,pos2)); undecorate (open_ l e) }}
and <- spacing pos:p Opa_lexer.AND {{ p }}
(* the ! here is here to prevent code such as {r=123x} to parse as {r=123 x}
* because the user then have ununderstandable type errors *)
strict_separator <- spacing semic
separator <- (strict_separator / not_assign ![~a-zA-Z`_]) pos:p {{ p }}
not_assign <- !(spacing may_coerce assign)
(**
{7 Ip address}
The parsing only allows for integers between 0 and 255, so writing
0.0.0.256 is a parse error
*)
;int3 <- Opa_lexer.int3:i {{ CInt (Big_int.big_int_of_string i) }}
;ip_item = deco just_ip_item
;just_ip_item <- int3:v {{ Const v }}
;just_ip <- ip_item:a [.] ip_item:b [.] ip_item:c [.] ip_item:d {{ Record (encode_record [("a",a);("b",b);("c",c);("d",d)]) }}
;/** ip address **/
ip <- (=deco(just_ip)):p {{ coerce_name p Opacapi.Types.ip }}
(**
{7 Lists }
Either ml lists or action lists
Empty list are just treated as action lists, but it doesn't make any difference
since an empty action will be transformed into a regular empty list
Action lists come first or else [ a +<- b ] is going to be parsed as [`+<-`(a,b) ]
*)
/** expression/action list **/
list <-
/ lbracket (=list0(Action.action,comma)):l pos:p comma? (Opa_lexer.BAR expr:e {{e}})?:tl rbracket
{{ undecorate (list_expr_of_expr_list ?tl l p) }}
/ lbracket (=list0(expr, comma)):l pos:p comma? (Opa_lexer.BAR expr:e {{e}})?:tl rbracket
{{ undecorate (list_expr_of_expr_list ?tl l p) }}
(**
{7 Bypasses }
may contain any character except %% ?
*)
/** bypass **/
bypass <- Opa_lexer.BYPASS ((!Opa_lexer.BYPASS .)* $_):content Opa_lexer.BYPASS
{{ bypass content }}
(**
{7 Tuples, or parenthesized expression}
[()] is not in the syntax
[(e)] is [e] parenthesized
[(e,)] is the 1-uple made of [e]
[(e,...,e)] or [(e,...,e,)] is a tuple
*)
/** tuple expression / parenthesized expression **/
tuple_expr <- lpar tuple_expr_inside:t rpar {{ t }}
tuple_expr_inside <- (=list1(expr,comma)):l comma?:o
{{ match l,o with
| [], _ -> assert false
| [e],None -> undecorate e
| _,_ -> coerce_name (tuple l) (tuple_string l)
}}
(**
{7 Record or module expression}
*)
module_element <- declaration_directives:dirs spacing rec_ident_binding:d
{{ List.hd (declaration_directive dirs [d]) }}
/** module **/
just_module <-
/ spacing "{{" spacing pos:pos (=deco((=list0pos(module_element,separator)))):r separator spacing "}}"
{{ let (r,posl),label = r in
push_hint (`same_indents (pos :: posl));
module_ (Record r,label) }}
/** record **/
just_record <- tilda:tilda lbrace record_fields:f rbrace {{
Record (default_value_in_expr_record tilda f)
}}
/ tilda:tilda lbrace expr:e Opa_lexer.WITH extend_record_fields:f rbrace {{
let long_bindings = default_value_in_expr_record tilda f in
undecorate (rewrite_long_extend_record long_bindings e)
}}
;record_fields <- (=list0(record_element,separator)):l separator {{ l }}
;extend_record_fields <- (=list0(extend_record_element,separator)):l separator {{ l }}
record_fields_separator <- separator
record_fields_assign <- assign
record_long_ident <- long_ident
extend_record_element <-
/ long_binding:b {{ `binding b }}
/ tilda:tilda (=deco(long_ident)):lp may_coerce:t not_assign
{{ let (l,pos) = lp in
let p = (undecorate (List.last l), pos) in
let rhs = if tilda then `value (var_to_exprvar p) else `novalue p in
`noassign (l, rhs, t)
}}
record_element <-
/ ident_binding:b {{ `binding b }}