atd_parser.opp.exp 8.91 KB
Newer Older
1 2 3 4 5 6 7 8 9 10
%{
  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 BAR
11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33
%token CL_BRACK
%token CL_CURL
%token CL_PAREN
%token COLON
%token COMMA
%token EOF
%token EQ
%token GT
%token INHERIT
%token < string > LIDENT
%token LT
%token OF
%token OP_BRACK
%token OP_CURL
%token OP_PAREN
%token QUESTION
%token SEMICOLON
%token STAR
%token < string > STRING
%token < string > TIDENT
%token TILDE
%token TYPE
%token < string > UIDENT
34 35 36 37
%type < Atd_ast.full_module > full_module
%%

full_module:
38
  x = annot y = module_body
39 40 41
    {                             ( (((_startpos_x_, _endpos_x_), x), y) )}

module_body:
42
  _1 = module_item _2 = module_body
43 44 45 46 47 48 49
    {                            ( _1 :: _2 )}
| _1 = EOF
    {                            ( [] )}
| _e = error
    {               ( syntax_error "Syntax error" _startpos__e_ _endpos__e_ )}

annot:
50
  x = asection l = annot
51 52 53 54 55
    {                         ( x :: l )}
| 
    {                         ( ([] : annot) )}

asection:
56
  _1 = LT x = LIDENT l = afield_list _4 = GT
57 58 59 60 61 62 63 64 65 66 67 68 69
    {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:
70
  x = afield l = afield_list
71 72 73 74 75
    {                              ( x :: l )}
| 
    {                              ( [] )}

afield:
76
  _1 = LIDENT _2 = EQ _3 = STRING
77 78 79 80 81 82 83 84 85
    {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:
86
  _1 = TYPE p = type_param s = LIDENT a = annot _5 = EQ t = type_expr
87 88 89 90 91 92 93 94 95 96 97
    {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:
98
  _1 = TIDENT
99 100 101 102 103 104 105 106 107
    {                                    ( [ _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:
108
  _1 = TIDENT _2 = COMMA _3 = type_var_list
109 110 111 112 113
    {                               ( _1 :: _3 )}
| _1 = TIDENT
    {                               ( [ _1 ] )}

type_expr:
114
  _1 = OP_BRACK l = variant_list _3 = CL_BRACK a = annot
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
    {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:
177
  x = annot_expr _2 = STAR l = cartesian_product
178 179 180 181 182 183 184
    {                                              ( x :: l )}
| x = annot_expr _2 = STAR y = annot_expr
    {                                              ( [ x; y ] )}
| 
    {                                              ( [] )}

annot_expr:
185
  a = annot _2 = COLON x = type_expr
186 187 188 189 190 191 192 193 194
    {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:
195
  l = type_args s = LIDENT
196 197 198 199 200
    {let _endpos = _endpos_s_ in
let _startpos = _startpos_l_ in
                            ( ((_startpos, _endpos), s, l) )}

type_args:
201
  _1 = type_expr
202 203 204 205 206 207 208 209 210
    {                                    ( [ _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:
211
  _1 = type_expr _2 = COMMA _3 = type_arg_list
212 213 214 215 216
    {                                 ( _1 :: _3 )}
| _1 = type_expr _2 = COMMA _3 = type_expr
    {                                 ( [ _1; _3 ] )}

variant_list:
217
  _1 = BAR _2 = variant_list0
218 219 220 221 222
    {                    ( _2 )}
| _1 = variant_list0
    {                    ( _1 )}

variant_list0:
223
  _1 = variant _2 = BAR _3 = variant_list0
224 225 226 227 228
    {                             ( _1 :: _3 )}
| _1 = variant
    {                             ( ([ _1 ] : variant list) )}

variant:
229
  x = UIDENT a = annot _3 = OF t = type_expr
230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245
    {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:
246
  x = field _2 = SEMICOLON l = field_list
247 248 249 250 251 252 253
    {                                       ( x :: l )}
| x = field _2 = SEMICOLON
    {                                       ( [ x ] )}
| x = field
    {                                       ( [ x ] )}

field:
254
  fn = field_name a = annot _3 = COLON t = type_expr
255 256 257 258 259 260 261 262 263 264 265 266 267 268 269
    {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:
270
  k = LIDENT
271 272 273 274 275 276 277 278 279
    {                         ( (k, `Required) )}
| _1 = QUESTION k = LIDENT
    {                         ( (k, `Optional) )}
| _1 = TILDE k = LIDENT
    {                         ( (k, `With_default) )}

%%