Added atd_parser.mly in bench/good.

bench/good/atd_parser.mly

+/*
+   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

+%{
+  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) )}
+
+%%
+
+
+