open Camlp4; (* -*- camlp4r -*- *)
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2002-2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the Camlp4 *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Daniel de Rauglaudre: initial version
* - Nicolas Pouillard: refactoring
*)
module Id : Sig.Id = struct
value name = "Camlp4OCamlParser";
value version = Sys.ocaml_version;
end;
module Make (Syntax : Sig.Camlp4Syntax) = struct
open Sig;
include Syntax;
Camlp4_config.constructors_arity.val := False;
(*FIXME remove this and use OCaml ones *)
value bigarray_set _loc var newval =
match var with
[ <:expr< Bigarray.Array1.get $arr$ $c1$ >> ->
Some <:expr< Bigarray.Array1.set $arr$ $c1$ $newval$ >>
| <:expr< Bigarray.Array2.get $arr$ $c1$ $c2$ >> ->
Some <:expr< Bigarray.Array2.set $arr$ $c1$ $c2$ $newval$ >>
| <:expr< Bigarray.Array3.get $arr$ $c1$ $c2$ $c3$ >> ->
Some <:expr< Bigarray.Array3.set $arr$ $c1$ $c2$ $c3$ $newval$ >>
| <:expr< Bigarray.Genarray.get $arr$ [| $coords$ |] >> ->
Some <:expr< Bigarray.Genarray.set $arr$ [| $coords$ |] $newval$ >>
| _ -> None ];
value mk_anti ?(c = "") n s = "\\$"^n^c^":"^s;
(*FIXME*)
value conc_seq e1 e2 =
match (e1, e2) with
[ (<:expr@_loc< do { $e1$ } >>, <:expr< do { $e2$ } >>) ->
<:expr< do { $e1$; $e2$ } >>
| (<:expr@_loc< do { $e1$ } >>, _) ->
<:expr< do { $e1$; $e2$ } >>
| (_, <:expr@_loc< do { $e2$ } >>) ->
<:expr< do { $e1$; $e2$ } >>
| _ ->
let _loc =
Loc.merge (Ast.loc_of_expr e1)
(Ast.loc_of_expr e2) in
<:expr< do { $e1$; $e2$ } >> ];
value stream_peek_nth n strm =
loop n (Stream.npeek n strm) where rec loop n =
fun
[ [] -> None
| [(x, _)] -> if n == 1 then Some x else None
| [_ :: l] -> loop (n - 1) l ]
;
value test_not_dot_nor_lparen =
Gram.Entry.of_parser "test_not_dot_nor_lparen" (fun strm ->
match Stream.peek strm with
[ Some (KEYWORD ("."|"("),_) -> raise Stream.Failure
| _ -> () ]);
(* horrible hacks to be able to parse class_types *)
value test_ctyp_minusgreater =
Gram.Entry.of_parser "test_ctyp_minusgreater"
(fun strm ->
let rec skip_simple_ctyp n =
match stream_peek_nth n strm with
[ Some (KEYWORD "->") -> n
| Some (KEYWORD ("[" | "[<")) ->
skip_simple_ctyp (ignore_upto "]" (n + 1) + 1)
| Some (KEYWORD "(") -> skip_simple_ctyp (ignore_upto ")" (n + 1) + 1)
| Some
(KEYWORD
("as" | "'" | ":" | "*" | "." | "#" | "<" | ">" | ".." | ";" |
"_" | "?")) ->
skip_simple_ctyp (n + 1)
| Some (LIDENT _ | UIDENT _) ->
skip_simple_ctyp (n + 1)
| Some _ | None -> raise Stream.Failure ]
and ignore_upto end_kwd n =
match stream_peek_nth n strm with
[ Some (KEYWORD prm) when prm = end_kwd -> n
| Some (KEYWORD ("[" | "[<")) ->
ignore_upto end_kwd (ignore_upto "]" (n + 1) + 1)
| Some (KEYWORD "(") -> ignore_upto end_kwd (ignore_upto ")" (n + 1) + 1)
| Some _ -> ignore_upto end_kwd (n + 1)
| None -> raise Stream.Failure ]
in
match Stream.peek strm with
[ Some ((KEYWORD "[" | LIDENT _ | UIDENT _), _) -> skip_simple_ctyp 1
| Some (KEYWORD "object", _) -> raise Stream.Failure
| _ -> 1 ])
;
(* Yet another horrible hack, this one to improve error locations when parsing
[{ blah }] in expressions *)
value test_record_field =
Gram.Entry.of_parser "record_field" (fun strm ->
let rec loop = fun
[ [] -> ()
| [ (UIDENT _, _) :: [ (KEYWORD ".", _) :: rest ] ] -> loop rest
| [ (LIDENT _, _) :: [ (KEYWORD ("="|";"|"}"), _) :: _ ] ] -> ()
| [ (LIDENT _, _) ] -> ()
| _ -> raise Stream.Failure
]
in
loop (Stream.npeek 100 strm))
;
value lident_colon =
Gram.Entry.of_parser "lident_colon"
(fun strm ->
match Stream.npeek 2 strm with
[ [(LIDENT i, _); (KEYWORD ":", _)] ->
do { Stream.junk strm; Stream.junk strm; i }
| _ -> raise Stream.Failure ])
;
value rec is_ident_constr_call =
fun
[ <:ident< $uid:_$ >> -> True
| <:ident< $_$.$i$ >> -> is_ident_constr_call i
| _ -> False ];
value rec is_expr_constr_call =
fun
[ <:expr< $id:i$ >> -> is_ident_constr_call i
| <:expr< `$_$ >> -> True
| <:expr< $_$.$e$ >> -> is_expr_constr_call e
| <:expr@_loc< $e$ $_$ >> ->
let res = is_expr_constr_call e in
if (not Camlp4_config.constructors_arity.val) && res then
Loc.raise _loc (Stream.Error "currified constructor")
else res
| _ -> False ];
DELETE_RULE Gram expr: SELF; "where"; opt_rec; let_binding END;
DELETE_RULE Gram value_let: "value" END;
DELETE_RULE Gram value_val: "value" END;
DELETE_RULE Gram str_item: value_let; opt_rec; binding END;
DELETE_RULE Gram module_type: "'"; a_ident END;
DELETE_RULE Gram module_type: SELF; SELF; dummy END;
DELETE_RULE Gram module_type: SELF; "."; SELF END;
DELETE_RULE Gram label_expr: label_longident; fun_binding END;
DELETE_RULE Gram meth_list: meth_decl; opt_dot_dot END;
DELETE_RULE Gram expr: "let"; opt_rec; binding; "in"; SELF END;
DELETE_RULE Gram expr: "let"; "module"; a_UIDENT; module_binding0; "in"; SELF END;
DELETE_RULE Gram expr: "let"; "open"; "!"; module_longident; "in"; SELF END;
DELETE_RULE Gram expr: "let"; "open"; module_longident; "in"; SELF END;
DELETE_RULE Gram expr: "fun"; "["; LIST0 match_case0 SEP "|"; "]" END;
DELETE_RULE Gram expr: "if"; SELF; "then"; SELF; "else"; SELF END;
DELETE_RULE Gram expr: "do"; do_sequence END;
DELETE_RULE Gram expr: SELF; SELF END;
DELETE_RULE Gram expr: "new"; class_longident END;
DELETE_RULE Gram expr: "["; sem_expr_for_list; "::"; expr; "]" END;
DELETE_RULE Gram expr: "{"; label_expr_list; "}" END;
DELETE_RULE Gram expr: "{"; "("; SELF; ")"; "with"; label_expr_list; "}" END;
DELETE_RULE Gram expr: "("; SELF; ","; comma_expr; ")" END;
DELETE_RULE Gram expr: SELF; ":="; SELF; dummy END;
DELETE_RULE Gram expr: "~"; a_LIDENT; ":"; SELF END;
DELETE_RULE Gram expr: "?"; a_LIDENT; ":"; SELF END;
DELETE_RULE Gram constructor_declarations: a_UIDENT; ":"; ctyp END;
DELETE_RULE Gram constructor_declarations: a_UIDENT; "=="; ident END;
(* Some other DELETE_RULE are after the grammar *)
value clear = Gram.Entry.clear;
clear ctyp;
clear patt;
clear a_UIDENT;
clear type_longident_and_parameters;
clear type_parameters;
clear ipatt;
clear labeled_ipatt;
clear semi;
clear do_sequence;
clear type_kind;
clear constructor_arg_list;
clear poly_type;
clear class_name_and_param;
clear class_longident_and_param;
clear class_type_longident_and_param;
clear class_type_plus;
clear type_constraint;
clear comma_patt;
clear sequence;
clear sem_expr_for_list;
clear sem_expr;
clear label_declaration;
clear star_ctyp;
clear match_case;
clear with_constr;
clear package_type;
clear top_phrase;
let apply () = EXTEND Gram
GLOBAL:
a_CHAR a_FLOAT a_INT a_INT32 a_INT64 a_LABEL a_LIDENT
a_NATIVEINT a_OPTLABEL a_STRING a_UIDENT a_ident
amp_ctyp and_ctyp match_case match_case0 match_case_quot binding binding_quot
class_declaration class_description class_expr class_expr_quot
class_fun_binding class_fun_def class_info_for_class_expr
class_info_for_class_type class_longident class_longident_and_param
class_name_and_param class_sig_item class_sig_item_quot class_signature
class_str_item class_str_item_quot class_structure class_type
class_type_declaration class_type_longident
class_type_longident_and_param class_type_plus class_type_quot
comma_ctyp comma_expr comma_ipatt comma_patt comma_type_parameter
constrain constructor_arg_list constructor_declaration
constructor_declarations ctyp ctyp_quot cvalue_binding direction_flag
dummy eq_expr expr expr_eoi expr_quot fun_binding
fun_def ident ident_quot implem interf ipatt ipatt_tcon label
label_declaration label_declaration_list label_expr label_expr_list
label_longident label_patt_list meth_list
labeled_ipatt let_binding module_binding module_binding0
module_binding_quot module_declaration module_expr module_expr_quot
module_longident module_longident_with_app module_rec_declaration
module_type module_type_quot more_ctyp name_tags opt_as_lident
opt_class_self_patt opt_class_self_type
opt_comma_ctyp opt_dot_dot opt_eq_ctyp opt_expr
opt_meth_list opt_mutable opt_polyt opt_private opt_rec
opt_virtual opt_when_expr patt patt_as_patt_opt patt_eoi
patt_quot patt_tcon phrase poly_type row_field
sem_expr sem_expr_for_list sem_patt sem_patt_for_list semi sequence
sig_item sig_item_quot sig_items star_ctyp str_item str_item_quot
str_items top_phrase type_constraint type_declaration
type_ident_and_parameters type_kind type_longident
type_longident_and_parameters type_parameter type_parameters typevars
use_file val_longident value_let value_val with_constr with_constr_quot
infixop0 infixop1 infixop2 infixop3 infixop4 do_sequence package_type
;
sem_expr:
[ [ e1 = expr LEVEL "top"; ";"; e2 = SELF -> <:expr< $e1$; $e2$ >>
| e = expr LEVEL "top"; ";" -> e
| e = expr LEVEL "top" -> e ] ]
;
sequence:
[ [ e = sem_expr -> e ] ]
;
do_sequence:
[ [ seq = sequence; "done" -> seq
] ]
;
sem_expr_for_list:
[ [ e = expr LEVEL "top"; ";"; el = SELF -> fun acc -> <:expr< [ $e$ :: $el acc$ ] >>
| e = expr LEVEL "top"; ";" -> fun acc -> <:expr< [ $e$ :: $acc$ ] >>
| e = expr LEVEL "top" -> fun acc -> <:expr< [ $e$ :: $acc$ ] >>
] ]
;
str_item:
[ "top"
[ "let"; r = opt_rec; bi = binding; "in"; x = expr ->
<:str_item< let $rec:r$ $bi$ in $x$ >>
| "let"; r = opt_rec; bi = binding ->
match bi with
[ <:binding< _ = $e$ >> -> <:str_item< $exp:e$ >>
| _ -> <:str_item< value $rec:r$ $bi$ >> ]
| "let"; "module"; m = a_UIDENT; mb = module_binding0; "in"; e = expr ->
<:str_item< let module $m$ = $mb$ in $e$ >>
| "let"; "open"; "!"; i = module_longident; "in"; e = expr ->
<:str_item< let open! $id:i$ in $e$ >>
| "let"; "open"; i = module_longident; "in"; e = expr ->
<:str_item< let open $id:i$ in $e$ >>
] ]
;
seq_expr:
[ [ e1 = expr LEVEL "top"; ";"; e2 = SELF ->
conc_seq e1 e2
| e1 = expr LEVEL "top"; ";" -> e1
| e1 = expr LEVEL "top" -> e1 ] ];
expr: BEFORE "top"
[ ";" [ e = seq_expr -> e ] ];
expr: LEVEL "top"
[ [ "let"; r = opt_rec; bi = binding; "in";
x = expr LEVEL ";" ->
<:expr< let $rec:r$ $bi$ in $x$ >>
| "let"; "module"; m = a_UIDENT; mb = module_binding0; "in";
e = expr LEVEL ";" ->
<:expr< let module $m$ = $mb$ in $e$ >>
| "let"; "open"; "!"; i = module_longident; "in"; e = expr LEVEL ";" ->
<:expr< let open! $id:i$ in $e$ >>
| "let"; "open"; i = module_longident; "in"; e = expr LEVEL ";" ->
<:expr< let open $id:i$ in $e$ >>
| "function"; a = match_case ->
<:expr< fun [ $a$ ] >>
| "if"; e1 = SELF; "then"; e2 = expr LEVEL "top";
"else"; e3 = expr LEVEL "top" ->
<:expr< if $e1$ then $e2$ else $e3$ >>
| "if"; e1 = SELF; "then"; e2 = expr LEVEL "top" ->
<:expr< if $e1$ then $e2$ else () >>
] ];
expr: BEFORE "||"
[ ","
[ e1 = SELF; ","; e2 = comma_expr ->
<:expr< ( $e1$, $e2$ ) >> ]
| ":=" NONA
[ e1 = SELF; ":="; e2 = expr LEVEL "top" ->
<:expr< $e1$.val := $e2$ >>
| e1 = SELF; "<-"; e2 = expr LEVEL "top" ->
match bigarray_set _loc e1 e2 with
[ Some e -> e
| None -> <:expr< $e1$ := $e2$ >> ]
] ];
expr: AFTER "^"
[ "::" RIGHTA
[ e1 = SELF; "::"; e2 = SELF -> <:expr< [$e1$ :: $e2$] >> ]
];
expr: LEVEL "apply" (* LEFTA *)
[ [ e1 = SELF; e2 = SELF ->
match (is_expr_constr_call e1, e2) with
[ (True, <:expr< ( $tup:e$ ) >>) ->
List.fold_left (fun e1 e2 -> <:expr< $e1$ $e2$ >>) e1
(Ast.list_of_expr e [])
| _ -> <:expr< $e1$ $e2$ >> ]
] ];
expr: LEVEL "simple" (* LEFTA *)
[ [ "false" -> <:expr< False >>
| "true" -> <:expr< True >>
| "{"; test_record_field; lel = label_expr_list; "}" ->
<:expr< { $lel$ } >>
| "{"; e = TRY [e = expr LEVEL "."; "with" -> e]; lel = label_expr_list; "}" ->
<:expr< { ($e$) with $lel$ } >>
| "new"; i = class_longident -> <:expr< new $i$ >>
] ]
;
val_longident:
[ [ `ANTIQUOT (""|"id"|"anti"|"list" as n) s ->
<:ident< $anti:mk_anti ~c:"ident" n s$ >>
| i = a_UIDENT -> <:ident< $uid:i$ >>
| i = a_LIDENT -> <:ident< $lid:i$ >>
| `ANTIQUOT (""|"id"|"anti"|"list" as n) s; "."; i = SELF ->
<:ident< $anti:mk_anti ~c:"ident" n s$.$i$ >>
| i = a_UIDENT; "."; j = SELF -> <:ident< $uid:i$.$j$ >> ] ]
;
match_case:
[ [ OPT "|"; l = LIST1 match_case0 SEP "|" -> Ast.mcOr_of_list l ] ]
;
patt_constr:
[ [ i = module_longident -> <:patt< $id:i$ >>
| "`"; s = a_ident -> <:patt< `$s$ >> ] ]
;
(* Patterns *)
patt:
[ "attribute"
[ e = SELF; "[@"; s = a_LIDENT; str = str_items; "]" ->
Ast.PaAtt _loc s str e ]
| "as" LEFTA
[ p1 = SELF; "as"; i = a_LIDENT -> <:patt< ($p1$ as $lid:i$) >> ]
| "|" LEFTA
[ p1 = SELF; "|"; p2 = SELF -> <:patt< $p1$ | $p2$ >> ]
| ","
[ p = SELF; ","; pl = (*FIXME comma_patt*) LIST1 NEXT SEP "," ->
<:patt< ( $p$, $Ast.paCom_of_list pl$ ) >> ]
| "::" RIGHTA
[ p1 = SELF; "::"; p2 = SELF -> <:patt< [$p1$ :: $p2$] >> ]
| "apply" RIGHTA
[ p1 = patt_constr; p2 = SELF ->
match p2 with
[ <:patt< ( $tup:p$ ) >> ->
List.fold_left (fun p1 p2 -> <:patt< $p1$ $p2$ >>) p1
(Ast.list_of_patt p [])
| _ -> <:patt< $p1$ $p2$ >> ]
| "lazy"; p = SELF -> <:patt< lazy $p$ >>
| "exception"; p = SELF -> Ast.PaExc _loc p
| `ANTIQUOT (""|"pat"|"anti" as n) s ->
<:patt< $anti:mk_anti ~c:"patt" n s$ >>
| p = patt_constr -> p ]
| "simple"
[ `ANTIQUOT (""|"pat"|"anti" as n) s ->
<:patt< $anti:mk_anti ~c:"patt" n s$ >>
| `ANTIQUOT ("tup" as n) s -> <:patt< ($tup:<:patt< $anti:mk_anti ~c:"patt" n s$ >>$) >>
| `ANTIQUOT ("`bool" as n) s -> <:patt< $anti:mk_anti n s$ >>
| `QUOTATION x -> Quotation.expand _loc x Quotation.DynAst.patt_tag
| i = ident -> <:patt< $id:i$ >>
| s = a_INT -> <:patt< $int:s$ >>
| s = a_INT32 -> <:patt< $int32:s$ >>
| s = a_INT64 -> <:patt< $int64:s$ >>
| s = a_NATIVEINT -> <:patt< $nativeint:s$ >>
| "-"; s = a_INT -> <:patt< $int:"-" ^ s$ >>
| "-"; s = a_INT32 -> <:patt< $int32:"-" ^ s$ >>
| "-"; s = a_INT64 -> <:patt< $int64:"-" ^ s$ >>
| "-"; s = a_NATIVEINT -> <:patt< $nativeint:"-" ^ s$ >>
| "-"; s = a_FLOAT -> <:patt< $flo:"-" ^ s$ >>
| s = a_FLOAT -> <:patt< $flo:s$ >>
| s = a_STRING -> <:patt< $str:s$ >>
| s1 = a_CHAR; ".."; s2 = a_CHAR -> <:patt< $chr:s1$ .. $chr:s2$ >>
| s = a_CHAR -> <:patt< $chr:s$ >>
| "false" -> <:patt< False >>
| "true" -> <:patt< True >>
| "["; "]" -> <:patt< [] >>
| "["; mk_list = sem_patt_for_list; "::"; last = patt; "]" ->
mk_list last
| "["; mk_list = sem_patt_for_list; "]" ->
mk_list <:patt< [] >>
| "[|"; "|]" -> <:patt< [||] >>
| "[|"; pl = sem_patt; "|]" -> <:patt< [| $pl$ |] >>
| "{"; pl = label_patt_list; "}" -> <:patt< { $pl$ } >>
| "("; ")" -> <:patt< () >>
| "("; "module"; m = a_UIDENT; ")" -> <:patt< (module $m$) >>
| "("; "module"; m = a_UIDENT; ":"; pt = package_type; ")" ->
<:patt< ((module $m$) : (module $pt$)) >>
| "("; p = patt; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >>
| "("; p = patt; ")" -> <:patt< $p$ >>
| "_" -> <:patt< _ >>
| "`"; s = a_ident -> <:patt< ` $s$ >>
| "#"; i = type_longident -> <:patt< # $i$ >> ] ]
;
comma_expr:
[ [ e1 = expr LEVEL ":="; ","; e2 = SELF -> <:expr< $e1$, $e2$ >>
| e1 = expr LEVEL ":=" -> e1 ] ]
;
(* comma_patt:
[ [ p1 = SELF; ","; p2 = SELF -> <:patt< $p1$, $p2$ >>
| p = patt LEVEL ".." -> p ] ]
; *)
type_constraint:
[ [ "constraint" -> () ] ]
;
with_constr:
[ LEFTA
[ wc1 = SELF; "and"; wc2 = SELF -> <:with_constr< $wc1$ and $wc2$ >>
| `ANTIQUOT (""|"with_constr"|"anti"|"list" as n) s ->
<:with_constr< $anti:mk_anti ~c:"with_constr" n s$ >>
| `QUOTATION x -> Quotation.expand _loc x Quotation.DynAst.with_constr_tag
| "type"; `ANTIQUOT (""|"typ"|"anti" as n) s; "="; t = opt_private_ctyp ->
<:with_constr< type $anti:mk_anti ~c:"ctyp" n s$ = $t$ >>
| "type"; t1 = type_longident_and_parameters; "="; t2 = opt_private_ctyp ->
<:with_constr< type $t1$ = $t2$ >>
| "module"; i1 = module_longident; "="; i2 = module_longident_with_app ->
<:with_constr< module $i1$ = $i2$ >>
| "type"; `ANTIQUOT (""|"typ"|"anti" as n) s; ":="; t = opt_private_ctyp ->
<:with_constr< type $anti:mk_anti ~c:"ctyp" n s$ := $t$ >>
| "type"; t1 = type_longident_and_parameters; ":="; t2 = opt_private_ctyp ->
<:with_constr< type $t1$ := $t2$ >>
| "module"; i1 = module_longident; ":="; i2 = module_longident_with_app ->
<:with_constr< module $i1$ := $i2$ >> ] ]
;
package_type:
[ [ i = module_longident_with_app -> <:module_type< $id:i$ >>
| i = module_longident_with_app; "with"; cs = package_type_cstrs ->
<:module_type< $id:i$ with $cs$ >>
] ]
;
package_type_cstr:
[ [ "type"; i = ident; "="; ty = ctyp ->
<:with_constr< type $id:i$ = $ty$ >>
] ]
;
package_type_cstrs:
[ [ c = package_type_cstr -> c
| c = package_type_cstr; "and"; cs = package_type_cstrs ->
<:with_constr< $c$ and $cs$ >>
] ]
;
opt_private_ctyp:
[ [ "private"; t = ctyp -> <:ctyp< private $t$ >>
| t = ctyp -> t ] ]
;
class_type_plus:
[ [ i = lident_colon; t = ctyp LEVEL "star"; "->"; ct = SELF ->
<:class_type< [ ~ $i$ : $t$ ] -> $ct$ >>
| "?"; i = a_LIDENT; ":"; t = ctyp LEVEL "star"; "->"; ct = SELF ->
<:class_type< [ ? $i$ : $t$ ] -> $ct$ >>
| i = OPTLABEL (* FIXME inline a_OPTLABEL *); t = ctyp LEVEL "star"; "->"; ct = SELF ->
<:class_type< [ ? $i$ : $t$ ] -> $ct$ >>
| test_ctyp_minusgreater; t = ctyp LEVEL "star"; "->"; ct = SELF ->
<:class_type< [ $t$ ] -> $ct$ >>
| ct = class_type -> ct ] ]
;
class_type_longident_and_param:
[ [ "["; t = comma_ctyp; "]"; i = class_type_longident ->
<:class_type< $id:i$ [ $t$ ] >>
| i = class_type_longident -> <:class_type< $id:i$ >> ] ]
;
class_longident_and_param:
[ [ "["; t = comma_ctyp; "]"; ci = class_longident ->
<:class_expr< $id:ci$ [ $t$ ] >>
| ci = class_longident -> <:class_expr< $id:ci$ >>
] ]
;
class_name_and_param:
[ [ "["; x = comma_type_parameter; "]"; i = a_LIDENT -> (i, x)
| i = a_LIDENT -> (i, <:ctyp<>>)
] ]
;
ctyp:
[ [ t1 = SELF; "as"; "'"; i = a_ident -> <:ctyp< $t1$ as '$i$ >> ]
| "arrow" RIGHTA
[ t1 = SELF; "->"; t2 = SELF -> <:ctyp< $t1$ -> $t2$ >>
| (i, t1) = TRY [i = a_LIDENT; ":"; t1 = ctyp LEVEL "star"; "->" -> (i, t1)]; t2 = SELF ->
<:ctyp< ( ~ $i$ : $t1$ ) -> $t2$ >>
| i = a_OPTLABEL; t1 = ctyp LEVEL "star"; "->"; t2 = SELF ->
<:ctyp< ( ? $i$ : $t1$ ) -> $t2$ >>
| "?"; i = a_LIDENT; ":"; t1 = ctyp LEVEL "star"; "->"; t2 = SELF ->
<:ctyp< ( ? $i$ : $t1$ ) -> $t2$ >> ]
| "star"
[ t = SELF; "*"; tl = star_ctyp ->
<:ctyp< ( $t$ * $tl$ ) >> ]
| "ctyp1"
[ t1 = SELF; t2 = SELF -> <:ctyp< $t2$ $t1$ >> ]
| "ctyp2"
[ t1 = SELF; "."; t2 = SELF ->
try <:ctyp< $id:Ast.ident_of_ctyp t1$.$id:Ast.ident_of_ctyp t2$ >>
with [ Invalid_argument s -> raise (Stream.Error s) ]
| t1 = SELF; "("; t2 = SELF; ")" ->
let t = <:ctyp< $t1$ $t2$ >> in
try <:ctyp< $id:Ast.ident_of_ctyp t$ >>
with [ Invalid_argument s -> raise (Stream.Error s) ] ]
| "attribute"
[ e = SELF; "[@"; s = a_LIDENT; str = str_items; "]" ->
Ast.TyAtt _loc s str e ]
| "simple"
[ "'"; i = a_ident -> <:ctyp< '$i$ >>
| "_" -> <:ctyp< _ >>
| ".." -> Ast.TyOpn _loc
| i = a_LIDENT -> <:ctyp< $lid:i$ >>
| i = a_UIDENT -> <:ctyp< $uid:i$ >>
| `ANTIQUOT (""|"typ"|"anti" as n) s ->
<:ctyp< $anti:mk_anti ~c:"ctyp" n s$ >>
| `ANTIQUOT ("tup" as n) s ->
<:ctyp< ($tup:<:ctyp< $anti:mk_anti ~c:"ctyp" n s$ >>$) >>
| `ANTIQUOT ("id" as n) s ->
<:ctyp< $id:<:ident< $anti:mk_anti ~c:"ident" n s$ >>$ >>
| `QUOTATION x -> Quotation.expand _loc x Quotation.DynAst.ctyp_tag
| "("; t = SELF; ","; mk = comma_ctyp_app; ")";
i = ctyp LEVEL "ctyp2" ->
mk <:ctyp< $i$ $t$ >>
| "("; t = SELF; ")" -> <:ctyp< $t$ >>
| "#"; i = class_longident -> <:ctyp< # $i$ >>
| "<"; t = opt_meth_list; ">" -> t
| "["; OPT "|"; rfl = row_field; "]" ->
<:ctyp< [ = $rfl$ ] >>
| "["; ">"; "]" -> <:ctyp< [ > $<:ctyp<>>$ ] >>
| "["; ">"; OPT "|"; rfl = row_field; "]" ->
<:ctyp< [ > $rfl$ ] >>
| "[<"; OPT "|"; rfl = row_field; "]" ->
<:ctyp< [ < $rfl$ ] >>
| "[<"; OPT "|"; rfl = row_field; ">"; ntl = name_tags; "]" ->
<:ctyp< [ < $rfl$ > $ntl$ ] >>
| "("; "module"; p = package_type; ")" -> <:ctyp< (module $p$) >>
] ]
;
meth_list:
[ [ m = meth_decl -> (m, <:row_var_flag<>>) ] ];
comma_ctyp_app:
[ [ t1 = ctyp; ","; t2 = SELF -> fun acc -> t2 <:ctyp< $acc$ $t1$ >>
| t = ctyp -> fun acc -> <:ctyp< $acc$ $t$ >>
] ]
;
star_ctyp:
[ [ `ANTIQUOT (""|"typ" as n) s ->
<:ctyp< $anti:mk_anti ~c:"ctyp" n s$ >>
| `ANTIQUOT ("list" as n) s ->
<:ctyp< $anti:mk_anti ~c:"ctyp*" n s$ >>
| t1 = ctyp LEVEL "ctyp1"; "*"; t2 = SELF ->
<:ctyp< $t1$ * $t2$ >>
| t = ctyp LEVEL "ctyp1" -> t
] ]
;
constructor_declarations:
[ [ s = a_UIDENT; ":"; t = constructor_arg_list ; "->" ; ret = ctyp ->
<:ctyp< $uid:s$ : ($t$ -> $ret$) >>
| s = a_UIDENT; ":"; ret = constructor_arg_list ->
match Ast.list_of_ctyp ret [] with
[ [c] -> <:ctyp< $uid:s$ : $c$ >>
| _ -> raise (Stream.Error "invalid generalized constructor type") ]
| s = a_UIDENT; "="; i = ident ->
<:ctyp< $uid:s$ == $id:i$>>
] ]
;
semi:
[ [ ";;" -> () | -> () ] ]
;
ipatt:
[ [ p = patt -> p ] ]
;
type_longident_and_parameters:
[ [ "("; tpl = type_parameters; ")"; i = type_longident ->
tpl <:ctyp< $id:i$ >>
| tp = type_parameter; i = type_longident ->
<:ctyp< $id:i$ $tp$ >>
| i = type_longident ->
<:ctyp< $id:i$ >>
] ]
;
type_parameters:
[ [ t1 = type_parameter; ","; t2 = SELF ->
fun acc -> t2 <:ctyp< $acc$ $t1$ >>
| t = type_parameter -> fun acc -> <:ctyp< $acc$ $t$ >>
] ]
;
optional_type_parameter:
[ [ `ANTIQUOT (""|"typ"|"anti" as n) s -> <:ctyp< $anti:mk_anti n s$ >>
| `QUOTATION x -> Quotation.expand _loc x Quotation.DynAst.ctyp_tag
| "+"; "_" -> Ast.TyAnP _loc
| "+"; "'"; i = a_ident -> <:ctyp< +'$lid:i$ >>
| "-"; "_" -> Ast.TyAnM _loc
| "-"; "'"; i = a_ident -> <:ctyp< -'$lid:i$ >>
| "_" -> Ast.TyAny _loc
| "'"; i = a_ident -> <:ctyp< '$lid:i$ >>
] ]
;
type_ident_and_parameters:
[ [ "("; tpl = LIST1 optional_type_parameter SEP ","; ")"; i = type_longident -> (i, tpl)
| t = optional_type_parameter; i = type_longident -> (i, [t])
| i = type_longident -> (i, [])
] ]
;
type_kind:
[ [ "private"; tk = type_kind -> <:ctyp< private $tk$ >>
| (x, t) = TRY [x = OPT "|"; t = constructor_declarations;
test_not_dot_nor_lparen -> (x, t)] ->
(* If there is no "|" and [t] is an antiquotation,
then it is not a sum type. *)
match (x, t) with
[ (None, Ast.TyAnt _) -> t
| _ -> <:ctyp< [ $t$ ] >> ]
| t = TRY ctyp -> <:ctyp< $t$ >>
| t = TRY ctyp; "="; "private"; tk = type_kind ->
<:ctyp< $t$ == private $tk$ >>
| t1 = TRY ctyp; "="; "{"; t2 = label_declaration_list; "}" ->
<:ctyp< $t1$ == { $t2$ } >>
| t1 = TRY ctyp; "="; OPT "|"; t2 = constructor_declarations ->
<:ctyp< $t1$ == [ $t2$ ] >>
| "{"; t = label_declaration_list; "}" ->
<:ctyp< { $t$ } >> ] ]
;
ctyp_quot:
[ [ "private"; t = ctyp_quot -> <:ctyp< private $t$ >>
| "|"; t = constructor_declarations -> <:ctyp< [ $t$ ] >>
| x = more_ctyp; "="; y = ctyp_quot -> <:ctyp< $x$ == $y$ >>
| "{"; t = label_declaration_list; "}" -> <:ctyp< { $t$ } >>
] ]
;
module_expr: LEVEL "apply"
[ [ i = SELF; "("; j = SELF; ")" -> <:module_expr< $i$ $j$ >> ] ]
;
ident_quot: LEVEL "apply"
[ [ i = SELF; "("; j = SELF; ")" -> <:ident< $i$ $j$ >> ] ]
;
module_longident_with_app: LEVEL "apply"
[ [ i = SELF; "("; j = SELF; ")" -> <:ident< $i$ $j$ >> ] ]
;
type_longident: LEVEL "apply"
[ [ i = SELF; "("; j = SELF; ")" -> <:ident< $i$ $j$ >> ] ]
;
constructor_arg_list:
[ [ t1 = SELF; "*"; t2 = SELF -> <:ctyp< $t1$ and $t2$ >>
| t = ctyp LEVEL "ctyp1" -> t
] ]
;
value_let:
[ [ "let" -> () ] ]
;
value_val:
[ [ "val" -> () ] ]
;
label_declaration:
[ [ `ANTIQUOT (""|"typ" as n) s ->
<:ctyp< $anti:mk_anti ~c:"ctyp" n s$ >>
| `QUOTATION x -> Quotation.expand _loc x Quotation.DynAst.ctyp_tag
| s = a_LIDENT; ":"; t = poly_type -> <:ctyp< $lid:s$ : $t$ >>
| "mutable"; s = a_LIDENT; ":"; t = poly_type ->
<:ctyp< $lid:s$ : mutable $t$ >>
] ]
;
poly_type:
[ [ t1 = TRY [t = typevars; "." -> t]; t2 = ctyp ->
<:ctyp< ! $t1$ . $t2$ >>
| t = TRY ctyp -> t ] ]
;
labeled_ipatt:
[ [ i = a_LABEL; p = patt LEVEL "simple" ->
<:patt< ~ $i$ : $p$ >>
| "~"; i = a_LIDENT -> <:patt< ~ $i$ >>
| "~"; "("; i = a_LIDENT; ")" ->
<:patt< ~ $i$ >>
| "~"; "("; i = a_LIDENT; ":"; t = ctyp; ")" ->
<:patt< ~ $i$ : ($lid:i$ : $t$) >>
| i = a_OPTLABEL; j = a_LIDENT -> (* ?a:b <> ?a : b *)
<:patt< ? $i$ : ($lid:j$) >>
| i = a_OPTLABEL; "_" ->
<:patt< ? $i$ : (_) >>
| i = a_OPTLABEL; "("; p = patt; ")" ->
<:patt< ? $i$ : ($p$) >>
| i = a_OPTLABEL; "("; p = patt; "="; e = expr; ")" ->
<:patt< ? $i$ : ( $p$ = $e$ ) >>
| i = a_OPTLABEL; "("; p = patt; ":"; t = ctyp; ")" ->
<:patt< ? $i$ : ( $p$ : $t$ ) >>
| i = a_OPTLABEL; "("; p = patt; ":"; t = ctyp; "=";
e = expr; ")" ->
<:patt< ? $i$ : ( $p$ : $t$ = $e$ ) >>
| "?"; i = a_LIDENT -> <:patt< ? $i$ >>
| "?"; "("; i = a_LIDENT; "="; e = expr; ")" ->
<:patt< ? ( $lid:i$ = $e$ ) >>
| "?"; "("; i = a_LIDENT; ":"; t = ctyp; "="; e = expr; ")" ->
<:patt< ? ( $lid:i$ : $t$ = $e$ ) >>
| "?"; "("; i = a_LIDENT; ")" ->
<:patt< ? $i$ >>
| "?"; "("; i = a_LIDENT; ":"; t = ctyp; ")" ->
<:patt< ? ( $lid:i$ : $t$ ) >>
| p = patt LEVEL "simple" -> p
] ]
;
label_expr:
[ [ i = label_longident; "="; e = expr LEVEL "top" ->
<:rec_binding< $i$ = $e$ >> ] ]
;
a_UIDENT:
[ [ `ANTIQUOT (""|"uid" as n) s -> mk_anti n s
| `UIDENT "True" -> " True"
| `UIDENT "False" -> " False"
| `UIDENT s -> s
] ]
;
top_phrase:
[ [ "#"; n = a_LIDENT; ";;" ->
Some (Ast.StDir _loc n <:expr< >>)
| "#"; n = a_LIDENT; arg = expr LEVEL "simple"; ";;" ->
Some (Ast.StDir _loc n arg)
| l = LIST1 str_item; ";;" -> Some (Ast.stSem_of_list l)
| `EOI -> None
] ]
;
END in apply ();
(* Some other DELETE_RULE are before the grammar *)
DELETE_RULE Gram module_longident_with_app: "("; SELF; ")" END;
DELETE_RULE Gram type_longident: "("; SELF; ")" END;
DELETE_RULE Gram ident_quot: "("; SELF; ")" END;
DELETE_RULE Gram module_longident_with_app: SELF; SELF END;
DELETE_RULE Gram type_longident: SELF; SELF END;
DELETE_RULE Gram ident_quot: SELF; SELF END;
DELETE_RULE Gram module_expr: SELF; SELF END;
end;
let module M = Register.OCamlSyntaxExtension Id Make in ();