Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
What's new
10
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Open sidebar
POTTIER Francois
menhir
Commits
e574965f
Commit
e574965f
authored
Nov 12, 2015
by
POTTIER Francois
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Added atd_parser.mly in bench/good.
parent
118da140
Changes
3
Hide whitespace changes
Inline
Side-by-side
Showing
3 changed files
with
492 additions
and
0 deletions
+492
-0
bench/good/atd_parser.exp
bench/good/atd_parser.exp
+0
-0
bench/good/atd_parser.mly
bench/good/atd_parser.mly
+211
-0
bench/good/atd_parser.opp.exp
bench/good/atd_parser.opp.exp
+281
-0
No files found.
bench/good/atd_parser.exp
0 → 100644
View file @
e574965f
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) )}
%%
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment