Skip to content

GitLab

Commit e574965f authored by POTTIER Francois's avatar POTTIER Francois
Browse files
Options

Added atd_parser.mly in bench/good.

parent 118da140
Hide whitespace changes
Inline Side-by-side
Showing with 492 additions and 0 deletions
bench/good/atd_parser.mly 0 → 100644
View file @ e574965f
/*
ATD Parser
requires menhir.
*/
%{
open Printf
open Atd_ast
let syntax_error s pos1 pos2 =
let msg = sprintf "%s:\n%s" (string_of_loc (pos1, pos2)) s in
error msg
%}
%token TYPE EQ OP_PAREN CL_PAREN OP_BRACK CL_BRACK OP_CURL CL_CURL
SEMICOLON COMMA COLON STAR OF EOF BAR LT GT INHERIT
QUESTION TILDE
%token < string > STRING LIDENT UIDENT TIDENT
%start full_module
%type < Atd_ast.full_module > full_module
%%
full_module:
| x = annot y = module_body { ((($startpos(x), $endpos(x)), x), y) }
;
module_body:
| module_item module_body { $1 :: $2 }
| EOF { [] }
| _e=error { syntax_error "Syntax error" $startpos(_e) $endpos(_e) }
;
annot:
| x = asection l = annot { x :: l }
| { ([] : annot) }
;
asection:
| LT x = LIDENT l = afield_list GT { (x, (($startpos, $endpos), l)) }
| LT LIDENT afield_list _e=error { syntax_error
"Expecting '>'"
$startpos(_e) $endpos(_e) }
| LT _e=error { syntax_error
"Expecting lowercase identifier"
$startpos(_e) $endpos(_e) }
;
afield_list:
| x = afield l = afield_list { x :: l }
| { [] }
;
afield:
| LIDENT EQ STRING { ($1, (($startpos, $endpos), Some $3)) }
| LIDENT { ($1, (($startpos, $endpos), None)) }
;
module_item:
| TYPE p = type_param s = LIDENT a = annot EQ t = type_expr
{ `Type (($startpos, $endpos), (s, p, a), t) }
| TYPE type_param LIDENT annot EQ _e=error
{ syntax_error "Expecting type expression" $startpos(_e) $endpos(_e) }
| TYPE type_param LIDENT annot _e=error
{ syntax_error "Expecting '='" $startpos(_e) $endpos(_e) }
| TYPE _e=error
{ syntax_error "Expecting type name" $startpos(_e) $endpos(_e) }
;
type_param:
| TIDENT { [ $1 ] }
| OP_PAREN type_var_list CL_PAREN { $2 }
| { [] }
| OP_PAREN type_var_list _e=error
{ syntax_error "Expecting ')'" $startpos(_e) $endpos(_e) }
;
type_var_list:
| TIDENT COMMA type_var_list { $1 :: $3 }
| TIDENT { [ $1 ] }
;
type_expr:
| OP_BRACK l = variant_list CL_BRACK a = annot
{ `Sum (($startpos, $endpos), l, a) }
| OP_BRACK CL_BRACK a = annot
{ `Sum (($startpos, $endpos), [], a) }
| OP_CURL l = field_list CL_CURL a = annot
{ `Record (($startpos, $endpos), l, a) }
| OP_CURL CL_CURL a = annot
{ `Record (($startpos, $endpos), [], a) }
| OP_PAREN x = annot_expr CL_PAREN a = annot
{ `Tuple (($startpos, $endpos), [x], a) }
| OP_PAREN l = cartesian_product CL_PAREN a = annot
{ `Tuple (($startpos, $endpos), l, a) }
| x = type_inst a = annot
{ let pos1 = $startpos in
let pos2 = $endpos in
let loc = (pos1, pos2) in
let loc2, name, args = x in
match name, args with
"list", [x] -> `List (loc, x, a)
| "option", [x] -> `Option (loc, x, a)
| "nullable", [x] -> `Nullable (loc, x, a)
| "shared", [x] ->
let a =
if Atd_annot.has_field ["share"] "id" a then
(* may cause ID clashes if not used properly *)
a
else
Atd_annot.set_field loc
"share" "id" (Some (Atd_annot.create_id ())) a
in
`Shared (loc, x, a)
| "wrap", [x] -> `Wrap (loc, x, a)
| ("list"|"option"|"nullable"|"shared"|"wrap"), _ ->
syntax_error (sprintf "%s expects one argument" name) pos1 pos2
| _ -> (`Name (loc, x, a) : type_expr) }
| x = TIDENT
{ `Tvar (($startpos, $endpos), x) }
| OP_BRACK variant_list _e=error
{ syntax_error "Expecting ']'" $startpos(_e) $endpos(_e) }
| OP_CURL field_list _e=error
{ syntax_error "Expecting '}'" $startpos(_e) $endpos(_e) }
| OP_PAREN cartesian_product _e=error
{ syntax_error "Expecting ')'" $startpos(_e) $endpos(_e) }
;
cartesian_product:
| x = annot_expr STAR l = cartesian_product { x :: l }
| x = annot_expr STAR y = annot_expr { [ x; y ] }
| { [] }
;
annot_expr:
| a = annot COLON x = type_expr { (($startpos, $endpos), x, a) }
| x = type_expr { (($startpos, $endpos), x, []) }
;
type_inst:
| l = type_args s = LIDENT { (($startpos, $endpos), s, l) }
;
type_args:
| type_expr { [ $1 ] }
| OP_PAREN type_arg_list CL_PAREN { $2 }
| { [] }
| OP_PAREN type_arg_list _e=error
{ syntax_error "Expecting ')'" $startpos(_e) $endpos(_e) }
;
type_arg_list:
| type_expr COMMA type_arg_list { $1 :: $3 }
| type_expr COMMA type_expr { [ $1; $3 ] }
;
variant_list:
| BAR variant_list0 { $2 }
| variant_list0 { $1 }
;
variant_list0:
| variant BAR variant_list0 { $1 :: $3 }
| variant { ([ $1 ] : variant list) }
;
variant:
| x = UIDENT a = annot OF t = type_expr
{ `Variant (($startpos, $endpos), (x, a), Some t) }
| x = UIDENT a = annot
{ `Variant (($startpos, $endpos), (x, a), None) }
| INHERIT t = type_expr
{ `Inherit (($startpos, $endpos), t) }
| UIDENT annot OF _e=error
{ syntax_error "Expecting type expression after 'of'"
$startpos(_e) $endpos(_e) }
;
field_list:
| x = field SEMICOLON l = field_list { x :: l }
| x = field SEMICOLON { [ x ] }
| x = field { [ x ] }
;
field:
| fn = field_name a = annot COLON t = type_expr
{ let k, fk = fn in
`Field (($startpos, $endpos), (k, fk, a), t) }
| INHERIT t = type_expr
{ `Inherit (($startpos, $endpos), t) }
| field_name annot COLON _e=error
{ syntax_error "Expecting type expression after ':'"
$startpos(_e) $endpos(_e) }
| field_name annot _e=error
{ syntax_error "Expecting ':'" $startpos(_e) $endpos(_e) }
;
field_name:
| k = LIDENT { (k, `Required) }
| QUESTION k = LIDENT { (k, `Optional) }
| TILDE k = LIDENT { (k, `With_default) }
;
bench/good/atd_parser.opp.exp 0 → 100644
View file @ e574965f
%{
open Printf
open Atd_ast
let syntax_error s pos1 pos2 =
let msg = sprintf "%s:\n%s" (string_of_loc (pos1, pos2)) s in
error msg
%}
%start full_module
%token < string > UIDENT
%token TYPE
%token TILDE
%token < string > TIDENT
%token < string > STRING
%token STAR
%token SEMICOLON
%token QUESTION
%token OP_PAREN
%token OP_CURL
%token OP_BRACK
%token OF
%token LT
%token < string > LIDENT
%token INHERIT
%token GT
%token EQ
%token EOF
%token COMMA
%token COLON
%token CL_PAREN
%token CL_CURL
%token CL_BRACK
%token BAR
%type < Atd_ast.full_module > full_module
%%
full_module:
| x = annot y = module_body
{ ( (((_startpos_x_, _endpos_x_), x), y) )}
module_body:
| _1 = module_item _2 = module_body
{ ( _1 :: _2 )}
| _1 = EOF
{ ( [] )}
| _e = error
{ ( syntax_error "Syntax error" _startpos__e_ _endpos__e_ )}
annot:
| x = asection l = annot
{ ( x :: l )}
|
{ ( ([] : annot) )}
asection:
| _1 = LT x = LIDENT l = afield_list _4 = GT
{let _endpos = _endpos__4_ in
let _startpos = _startpos__1_ in
( (x, ((_startpos, _endpos), l)) )}
| _1 = LT _2 = LIDENT _3 = afield_list _e = error
{ ( syntax_error
"Expecting '>'"
_startpos__e_ _endpos__e_ )}
| _1 = LT _e = error
{ ( syntax_error
"Expecting lowercase identifier"
_startpos__e_ _endpos__e_ )}
afield_list:
| x = afield l = afield_list
{ ( x :: l )}
|
{ ( [] )}
afield:
| _1 = LIDENT _2 = EQ _3 = STRING
{let _endpos = _endpos__3_ in
let _startpos = _startpos__1_ in
( (_1, ((_startpos, _endpos), Some _3)) )}
| _1 = LIDENT
{let _endpos = _endpos__1_ in
let _startpos = _startpos__1_ in
( (_1, ((_startpos, _endpos), None)) )}
module_item:
| _1 = TYPE p = type_param s = LIDENT a = annot _5 = EQ t = type_expr
{let _endpos = _endpos_t_ in
let _startpos = _startpos__1_ in
( `Type ((_startpos, _endpos), (s, p, a), t) )}
| _1 = TYPE _2 = type_param _3 = LIDENT _4 = annot _5 = EQ _e = error
{ ( syntax_error "Expecting type expression" _startpos__e_ _endpos__e_ )}
| _1 = TYPE _2 = type_param _3 = LIDENT _4 = annot _e = error
{ ( syntax_error "Expecting '='" _startpos__e_ _endpos__e_ )}
| _1 = TYPE _e = error
{ ( syntax_error "Expecting type name" _startpos__e_ _endpos__e_ )}
type_param:
| _1 = TIDENT
{ ( [ _1 ] )}
| _1 = OP_PAREN _2 = type_var_list _3 = CL_PAREN
{ ( _2 )}
|
{ ( [] )}
| _1 = OP_PAREN _2 = type_var_list _e = error
{ ( syntax_error "Expecting ')'" _startpos__e_ _endpos__e_ )}
type_var_list:
| _1 = TIDENT _2 = COMMA _3 = type_var_list
{ ( _1 :: _3 )}
| _1 = TIDENT
{ ( [ _1 ] )}
type_expr:
| _1 = OP_BRACK l = variant_list _3 = CL_BRACK a = annot
{let _endpos = _endpos_a_ in
let _startpos = _startpos__1_ in
( `Sum ((_startpos, _endpos), l, a) )}
| _1 = OP_BRACK _2 = CL_BRACK a = annot
{let _endpos = _endpos_a_ in
let _startpos = _startpos__1_ in
( `Sum ((_startpos, _endpos), [], a) )}
| _1 = OP_CURL l = field_list _3 = CL_CURL a = annot
{let _endpos = _endpos_a_ in
let _startpos = _startpos__1_ in
( `Record ((_startpos, _endpos), l, a) )}
| _1 = OP_CURL _2 = CL_CURL a = annot
{let _endpos = _endpos_a_ in
let _startpos = _startpos__1_ in
( `Record ((_startpos, _endpos), [], a) )}
| _1 = OP_PAREN x = annot_expr _3 = CL_PAREN a = annot
{let _endpos = _endpos_a_ in
let _startpos = _startpos__1_ in
( `Tuple ((_startpos, _endpos), [x], a) )}
| _1 = OP_PAREN l = cartesian_product _3 = CL_PAREN a = annot
{let _endpos = _endpos_a_ in
let _startpos = _startpos__1_ in
( `Tuple ((_startpos, _endpos), l, a) )}
| x = type_inst a = annot
{let _endpos = _endpos_a_ in
let _startpos = _startpos_x_ in
( let pos1 = _startpos in
let pos2 = _endpos in
let loc = (pos1, pos2) in
let loc2, name, args = x in
match name, args with
"list", [x] -> `List (loc, x, a)
| "option", [x] -> `Option (loc, x, a)
| "nullable", [x] -> `Nullable (loc, x, a)
| "shared", [x] ->
let a =
if Atd_annot.has_field ["share"] "id" a then
(* may cause ID clashes if not used properly *)
a
else
Atd_annot.set_field loc
"share" "id" (Some (Atd_annot.create_id ())) a
in
`Shared (loc, x, a)
| "wrap", [x] -> `Wrap (loc, x, a)
| ("list"|"option"|"nullable"|"shared"|"wrap"), _ ->
syntax_error (sprintf "%s expects one argument" name) pos1 pos2
| _ -> (`Name (loc, x, a) : type_expr) )}
| x = TIDENT
{let _endpos = _endpos_x_ in
let _startpos = _startpos_x_ in
( `Tvar ((_startpos, _endpos), x) )}
| _1 = OP_BRACK _2 = variant_list _e = error
{ ( syntax_error "Expecting ']'" _startpos__e_ _endpos__e_ )}
| _1 = OP_CURL _2 = field_list _e = error
{ ( syntax_error "Expecting '}'" _startpos__e_ _endpos__e_ )}
| _1 = OP_PAREN _2 = cartesian_product _e = error
{ ( syntax_error "Expecting ')'" _startpos__e_ _endpos__e_ )}
cartesian_product:
| x = annot_expr _2 = STAR l = cartesian_product
{ ( x :: l )}
| x = annot_expr _2 = STAR y = annot_expr
{ ( [ x; y ] )}
|
{ ( [] )}
annot_expr:
| a = annot _2 = COLON x = type_expr
{let _endpos = _endpos_x_ in
let _startpos = _startpos_a_ in
( ((_startpos, _endpos), x, a) )}
| x = type_expr
{let _endpos = _endpos_x_ in
let _startpos = _startpos_x_ in
( ((_startpos, _endpos), x, []) )}
type_inst:
| l = type_args s = LIDENT
{let _endpos = _endpos_s_ in
let _startpos = _startpos_l_ in
( ((_startpos, _endpos), s, l) )}
type_args:
| _1 = type_expr
{ ( [ _1 ] )}
| _1 = OP_PAREN _2 = type_arg_list _3 = CL_PAREN
{ ( _2 )}
|
{ ( [] )}
| _1 = OP_PAREN _2 = type_arg_list _e = error
{ ( syntax_error "Expecting ')'" _startpos__e_ _endpos__e_ )}
type_arg_list:
| _1 = type_expr _2 = COMMA _3 = type_arg_list
{ ( _1 :: _3 )}
| _1 = type_expr _2 = COMMA _3 = type_expr
{ ( [ _1; _3 ] )}
variant_list:
| _1 = BAR _2 = variant_list0
{ ( _2 )}
| _1 = variant_list0
{ ( _1 )}
variant_list0:
| _1 = variant _2 = BAR _3 = variant_list0
{ ( _1 :: _3 )}
| _1 = variant
{ ( ([ _1 ] : variant list) )}
variant:
| x = UIDENT a = annot _3 = OF t = type_expr
{let _endpos = _endpos_t_ in
let _startpos = _startpos_x_ in
( `Variant ((_startpos, _endpos), (x, a), Some t) )}
| x = UIDENT a = annot
{let _endpos = _endpos_a_ in
let _startpos = _startpos_x_ in
( `Variant ((_startpos, _endpos), (x, a), None) )}
| _1 = INHERIT t = type_expr
{let _endpos = _endpos_t_ in
let _startpos = _startpos__1_ in
( `Inherit ((_startpos, _endpos), t) )}
| _1 = UIDENT _2 = annot _3 = OF _e = error
{ ( syntax_error "Expecting type expression after 'of'"
_startpos__e_ _endpos__e_ )}
field_list:
| x = field _2 = SEMICOLON l = field_list
{ ( x :: l )}
| x = field _2 = SEMICOLON
{ ( [ x ] )}
| x = field
{ ( [ x ] )}
field:
| fn = field_name a = annot _3 = COLON t = type_expr
{let _endpos = _endpos_t_ in
let _startpos = _startpos_fn_ in
( let k, fk = fn in
`Field ((_startpos, _endpos), (k, fk, a), t) )}
| _1 = INHERIT t = type_expr
{let _endpos = _endpos_t_ in
let _startpos = _startpos__1_ in
( `Inherit ((_startpos, _endpos), t) )}
| _1 = field_name _2 = annot _3 = COLON _e = error
{ ( syntax_error "Expecting type expression after ':'"
_startpos__e_ _endpos__e_ )}
| _1 = field_name _2 = annot _e = error
{ ( syntax_error "Expecting ':'" _startpos__e_ _endpos__e_ )}
field_name:
| k = LIDENT
{ ( (k, `Required) )}
| _1 = QUESTION k = LIDENT
{ ( (k, `Optional) )}
| _1 = TILDE k = LIDENT
{ ( (k, `With_default) )}
%%
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment