(* camlp4r pa_extend.cmo pa_extend_m.cmo q_MLast.cmo *)
(***********************************************************************)
(*                                                                     *)
(*                             Camlp4                                  *)
(*                                                                     *)
(*        Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt     *)
(*                                                                     *)
(*  Copyright 2002 Institut National de Recherche en Informatique et   *)
(*  Automatique.  Distributed only by permission.                      *)
(*                                                                     *)
(***********************************************************************)

(* $Id$ *)

value gram = Grammar.gcreate (Plexer.gmake ());

module Qast =
  struct
    type t =
      [ Node of string and list t
      | List of list t
      | Tuple of list t
      | Option of option t
      | Int of string
      | Str of string
      | Bool of bool
      | Cons of t and t
      | Apply of string and list t
      | Record of list (string * t)
      | Loc
      | Antiquot of MLast.loc and string ]
    ;
    value loc = (0, 0);
    value rec to_expr =
      fun
      [ Node n al ->
          List.fold_left (fun e a -> <:expr< $e$ $to_expr a$ >>)
            <:expr< MLast.$uid:n$ >> al
      | List al ->
          List.fold_right (fun a e -> <:expr< [$to_expr a$ :: $e$] >>) al
            <:expr< [] >>
      | Tuple al -> <:expr< ($list:List.map to_expr al$) >>
      | Option None -> <:expr< None >>
      | Option (Some a) -> <:expr< Some $to_expr a$ >>
      | Int s -> <:expr< $int:s$ >>
      | Str s -> <:expr< $str:s$ >>
      | Bool True -> <:expr< True >>
      | Bool False -> <:expr< False >>
      | Cons a1 a2 -> <:expr< [$to_expr a1$ :: $to_expr a2$] >>
      | Apply f al ->
          List.fold_left (fun e a -> <:expr< $e$ $to_expr a$ >>)
            <:expr< $lid:f$ >> al
      | Record lal -> <:expr< {$list:List.map to_expr_label lal$} >>
      | Loc -> <:expr< $lid:Stdpp.loc_name.val$ >>
      | Antiquot loc s ->
          let e =
            try Grammar.Entry.parse Pcaml.expr_eoi (Stream.of_string s) with
            [ Stdpp.Exc_located (bp, ep) exc ->
                raise (Stdpp.Exc_located (fst loc + bp, fst loc + ep) exc) ]
          in
          <:expr< $anti:e$ >> ]
    and to_expr_label (l, a) = (<:patt< MLast.$lid:l$ >>, to_expr a);
    value rec to_patt =
      fun
      [ Node n al ->
          List.fold_left (fun e a -> <:patt< $e$ $to_patt a$ >>)
            <:patt< MLast.$uid:n$ >> al
      | List al ->
          List.fold_right (fun a p -> <:patt< [$to_patt a$ :: $p$] >>) al
            <:patt< [] >>
      | Tuple al -> <:patt< ($list:List.map to_patt al$) >>
      | Option None -> <:patt< None >>
      | Option (Some a) -> <:patt< Some $to_patt a$ >>
      | Int s -> <:patt< $int:s$ >>
      | Str s -> <:patt< $str:s$ >>
      | Bool True -> <:patt< True >>
      | Bool False -> <:patt< False >>
      | Cons a1 a2 -> <:patt< [$to_patt a1$ :: $to_patt a2$] >>
      | Apply _ _ -> failwith "bad pattern"
      | Record lal -> <:patt< {$list:List.map to_patt_label lal$} >>
      | Loc -> <:patt< _ >>
      | Antiquot loc s ->
          let p =
            try Grammar.Entry.parse Pcaml.patt_eoi (Stream.of_string s) with
            [ Stdpp.Exc_located (bp, ep) exc ->
                raise (Stdpp.Exc_located (fst loc + bp, fst loc + ep) exc) ]
          in
          <:patt< $anti:p$ >> ]
    and to_patt_label (l, a) = (<:patt< MLast.$lid:l$ >>, to_patt a);
  end
;

value antiquot k (bp, ep) x =
  let shift =
    if k = "" then String.length "$"
    else String.length "$" + String.length k + String.length ":"
  in
  Qast.Antiquot (shift + bp, shift + ep) x
;

value sig_item = Grammar.Entry.create gram "signature item";
value str_item = Grammar.Entry.create gram "structure item";
value ctyp = Grammar.Entry.create gram "type";
value patt = Grammar.Entry.create gram "pattern";
value expr = Grammar.Entry.create gram "expression";

value module_type = Grammar.Entry.create gram "module type";
value module_expr = Grammar.Entry.create gram "module expression";

value class_type = Grammar.Entry.create gram "class type";
value class_expr = Grammar.Entry.create gram "class expr";
value class_sig_item = Grammar.Entry.create gram "class signature item";
value class_str_item = Grammar.Entry.create gram "class structure item";

value ipatt = Grammar.Entry.create gram "ipatt";
value let_binding = Grammar.Entry.create gram "let_binding";

value a_list = Grammar.Entry.create gram "a_list";
value a_opt = Grammar.Entry.create gram "a_opt";
value a_UIDENT = Grammar.Entry.create gram "a_UIDENT";
value a_LIDENT = Grammar.Entry.create gram "a_LIDENT";
value a_INT = Grammar.Entry.create gram "a_INT";
value a_FLOAT = Grammar.Entry.create gram "a_FLOAT";
value a_STRING = Grammar.Entry.create gram "a_STRING";
value a_CHAR = Grammar.Entry.create gram "a_CHAR";
value a_TILDEIDENT = Grammar.Entry.create gram "a_TILDEIDENT";
value a_QUESTIONIDENT = Grammar.Entry.create gram "a_QUESTIONIDENT";

value o2b =
  fun
  [ Qast.Option (Some _) -> Qast.Bool True
  | Qast.Option None -> Qast.Bool False
  | x -> x ]
;

value mksequence _ =
  fun
  [ Qast.List [e] -> e
  | el -> Qast.Node "ExSeq" [Qast.Loc; el] ]
;

value mkmatchcase _ p aso w e =
  let p =
    match aso with
    [ Qast.Option (Some p2) -> Qast.Node "PaAli" [Qast.Loc; p; p2]
    | Qast.Option None -> p
    | _ -> Qast.Node "PaAli" [Qast.Loc; p; aso] ]
  in
  Qast.Tuple [p; w; e]
;

value mkumin _ f arg =
  match arg with
  [ Qast.Node "ExInt" [Qast.Loc; Qast.Str n] when int_of_string n > 0 ->
      let n = "-" ^ n in
      Qast.Node "ExInt" [Qast.Loc; Qast.Str n]
  | Qast.Node "ExFlo" [Qast.Loc; Qast.Str n] when float_of_string n > 0.0 ->
      let n = "-" ^ n in
      Qast.Node "ExFlo" [Qast.Loc; Qast.Str n]
  | _ ->
      match f with
      [ Qast.Str f ->
          let f = "~" ^ f in
          Qast.Node "ExApp"
            [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str f]; arg]
      | _ -> assert False ] ]
;

value mkuminpat _ f is_int s =
  match is_int with
  [ Qast.Bool True -> Qast.Node "PaInt" [Qast.Loc; s]
  | Qast.Bool False -> Qast.Node "PaFlo" [Qast.Loc; s]
  | _ -> assert False ]
;

value mklistexp _ last =
  loop True where rec loop top =
    fun
    [ Qast.List [] ->
        match last with
        [ Qast.Option (Some e) -> e
        | Qast.Option None -> Qast.Node "ExUid" [Qast.Loc; Qast.Str "[]"]
        | a -> a ]
    | Qast.List [e1 :: el] ->
        Qast.Node "ExApp"
          [Qast.Loc;
           Qast.Node "ExApp"
             [Qast.Loc; Qast.Node "ExUid" [Qast.Loc; Qast.Str "::"]; e1];
           loop False (Qast.List el)]
    | a -> a ]
;

value mklistpat _ last =
  loop True where rec loop top =
    fun
    [ Qast.List [] ->
        match last with
        [ Qast.Option (Some p) -> p
        | Qast.Option None -> Qast.Node "PaUid" [Qast.Loc; Qast.Str "[]"]
        | a -> a ]
    | Qast.List [p1 :: pl] ->
        Qast.Node "PaApp"
          [Qast.Loc;
           Qast.Node "PaApp"
             [Qast.Loc; Qast.Node "PaUid" [Qast.Loc; Qast.Str "::"]; p1];
           loop False (Qast.List pl)]
    | a -> a ]
;

value mkexprident loc i j =
  loop (Qast.Node "ExUid" [Qast.Loc; i]) j where rec loop m =
    fun
    [ Qast.Node "ExAcc" [_; x; y] ->
        loop (Qast.Node "ExAcc" [Qast.Loc; m; x]) y
    | e -> Qast.Node "ExAcc" [Qast.Loc; m; e] ]
;

value mkassert _ e =
  let f = Qast.Node "ExStr" [Qast.Loc; Qast.Str ""] in
  let bp = Qast.Node "ExInt" [Qast.Loc; Qast.Str "0"] in
  let ep = Qast.Node "ExInt" [Qast.Loc; Qast.Str "0"] in
  let raiser =
    Qast.Node "ExApp"
      [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "raise"];
       Qast.Node "ExApp"
         [Qast.Loc; Qast.Node "ExUid" [Qast.Loc; Qast.Str "Assert_failure"];
          Qast.Node "ExTup" [Qast.Loc; Qast.List [f; bp; ep]]]]
  in
  match e with
  [ Qast.Node "ExUid" [_; Qast.Str "False"] -> raiser
  | _ ->
      if Pcaml.no_assert.val then Qast.Node "ExUid" [Qast.Loc; Qast.Str "()"]
      else
        Qast.Node "ExIfe"
          [Qast.Loc; e; Qast.Node "ExUid" [Qast.Loc; Qast.Str "()"]; raiser] ]
;

value append_elem el e = Qast.Apply "@" [el; Qast.List [e]];

value not_yet_warned = ref True;
value warning_seq () =
  if not_yet_warned.val then do {
    not_yet_warned.val := False;
    Printf.eprintf
      "\
*** warning: use of old syntax for sequences in expr quotation\n";
    flush stderr
  }
  else ()
;

EXTEND
  GLOBAL: sig_item str_item ctyp patt expr module_type module_expr class_type
    class_expr class_sig_item class_str_item let_binding ipatt;
  module_expr:
    [ [ "functor"; "("; i = a_UIDENT; ":"; t = module_type; ")"; "->";
        me = SELF ->
          Qast.Node "MeFun" [Qast.Loc; i; t; me]
      | "struct"; st = SLIST0 [ s = str_item; ";" -> s ]; "end" ->
          Qast.Node "MeStr" [Qast.Loc; st] ]
    | [ me1 = SELF; me2 = SELF -> Qast.Node "MeApp" [Qast.Loc; me1; me2] ]
    | [ me1 = SELF; "."; me2 = SELF ->
          Qast.Node "MeAcc" [Qast.Loc; me1; me2] ]
    | "simple"
      [ i = a_UIDENT -> Qast.Node "MeUid" [Qast.Loc; i]
      | "("; me = SELF; ":"; mt = module_type; ")" ->
          Qast.Node "MeTyc" [Qast.Loc; me; mt]
      | "("; me = SELF; ")" -> me ] ]
  ;
  str_item:
    [ "top"
      [ "declare"; st = SLIST0 [ s = str_item; ";" -> s ]; "end" ->
          Qast.Node "StDcl" [Qast.Loc; st]
      | "exception"; ctl = constructor_declaration; b = rebind_exn ->
          let (_, c, tl) =
            match ctl with
            [ Qast.Tuple [xx1; xx2; xx3] -> (xx1, xx2, xx3)
            | _ -> match () with [] ]
          in
          Qast.Node "StExc" [Qast.Loc; c; tl; b]
      | "external"; i = a_LIDENT; ":"; t = ctyp; "="; pd = SLIST1 a_STRING ->
          Qast.Node "StExt" [Qast.Loc; i; t; pd]
      | "include"; me = module_expr -> Qast.Node "StInc" [Qast.Loc; me]
      | "module"; i = a_UIDENT; mb = module_binding ->
          Qast.Node "StMod" [Qast.Loc; i; mb]
      | "module"; "type"; i = a_UIDENT; "="; mt = module_type ->
          Qast.Node "StMty" [Qast.Loc; i; mt]
      | "open"; i = mod_ident -> Qast.Node "StOpn" [Qast.Loc; i]
      | "type"; tdl = SLIST1 type_declaration SEP "and" ->
          Qast.Node "StTyp" [Qast.Loc; tdl]
      | "value"; r = rec_flag; l = SLIST1 let_binding SEP "and" ->
          Qast.Node "StVal" [Qast.Loc; r; l]
      | e = expr -> Qast.Node "StExp" [Qast.Loc; e] ] ]
  ;
  rebind_exn:
    [ [ "="; sl = mod_ident -> sl
      | -> Qast.List [] ] ]
  ;
  module_binding:
    [ RIGHTA
      [ "("; m = a_UIDENT; ":"; mt = module_type; ")"; mb = SELF ->
          Qast.Node "MeFun" [Qast.Loc; m; mt; mb]
      | ":"; mt = module_type; "="; me = module_expr ->
          Qast.Node "MeTyc" [Qast.Loc; me; mt]
      | "="; me = module_expr -> me ] ]
  ;
  module_type:
    [ [ "functor"; "("; i = a_UIDENT; ":"; t = SELF; ")"; "->"; mt = SELF ->
          Qast.Node "MtFun" [Qast.Loc; i; t; mt] ]
    | [ mt = SELF; "with"; wcl = SLIST1 with_constr SEP "and" ->
          Qast.Node "MtWit" [Qast.Loc; mt; wcl] ]
    | [ "sig"; sg = SLIST0 [ s = sig_item; ";" -> s ]; "end" ->
          Qast.Node "MtSig" [Qast.Loc; sg] ]
    | [ m1 = SELF; m2 = SELF -> Qast.Node "MtApp" [Qast.Loc; m1; m2] ]
    | [ m1 = SELF; "."; m2 = SELF -> Qast.Node "MtAcc" [Qast.Loc; m1; m2] ]
    | "simple"
      [ i = a_UIDENT -> Qast.Node "MtUid" [Qast.Loc; i]
      | i = a_LIDENT -> Qast.Node "MtLid" [Qast.Loc; i]
      | "("; mt = SELF; ")" -> mt ] ]
  ;
  sig_item:
    [ "top"
      [ "declare"; st = SLIST0 [ s = sig_item; ";" -> s ]; "end" ->
          Qast.Node "SgDcl" [Qast.Loc; st]
      | "exception"; ctl = constructor_declaration ->
          let (_, c, tl) =
            match ctl with
            [ Qast.Tuple [xx1; xx2; xx3] -> (xx1, xx2, xx3)
            | _ -> match () with [] ]
          in
          Qast.Node "SgExc" [Qast.Loc; c; tl]
      | "external"; i = a_LIDENT; ":"; t = ctyp; "="; pd = SLIST1 a_STRING ->
          Qast.Node "SgExt" [Qast.Loc; i; t; pd]
      | "include"; mt = module_type -> Qast.Node "SgInc" [Qast.Loc; mt]
      | "module"; i = a_UIDENT; mt = module_declaration ->
          Qast.Node "SgMod" [Qast.Loc; i; mt]
      | "module"; "type"; i = a_UIDENT; "="; mt = module_type ->
          Qast.Node "SgMty" [Qast.Loc; i; mt]
      | "open"; i = mod_ident -> Qast.Node "SgOpn" [Qast.Loc; i]
      | "type"; tdl = SLIST1 type_declaration SEP "and" ->
          Qast.Node "SgTyp" [Qast.Loc; tdl]
      | "value"; i = a_LIDENT; ":"; t = ctyp ->
          Qast.Node "SgVal" [Qast.Loc; i; t] ] ]
  ;
  module_declaration:
    [ RIGHTA
      [ ":"; mt = module_type -> mt
      | "("; i = a_UIDENT; ":"; t = module_type; ")"; mt = SELF ->
          Qast.Node "MtFun" [Qast.Loc; i; t; mt] ] ]
  ;
  with_constr:
    [ [ "type"; i = mod_ident; tpl = SLIST0 type_parameter; "="; t = ctyp ->
          Qast.Node "WcTyp" [Qast.Loc; i; tpl; t]
      | "module"; i = mod_ident; "="; mt = module_type ->
          Qast.Node "WcMod" [Qast.Loc; i; mt] ] ]
  ;
  expr:
    [ "top" RIGHTA
      [ "let"; r = rec_flag; l = SLIST1 let_binding SEP "and"; "in";
        x = SELF ->
          Qast.Node "ExLet" [Qast.Loc; r; l; x]
      | "let"; "module"; m = a_UIDENT; mb = module_binding; "in"; e = SELF ->
          Qast.Node "ExLmd" [Qast.Loc; m; mb; e]
      | "fun"; "["; l = SLIST0 match_case SEP "|"; "]" ->
          Qast.Node "ExFun" [Qast.Loc; l]
      | "fun"; p = ipatt; e = fun_def ->
          Qast.Node "ExFun"
            [Qast.Loc; Qast.List [Qast.Tuple [p; Qast.Option None; e]]]
      | "match"; e = SELF; "with"; "["; l = SLIST0 match_case SEP "|"; "]" ->
          Qast.Node "ExMat" [Qast.Loc; e; l]
      | "match"; e = SELF; "with"; p1 = ipatt; "->"; e1 = SELF ->
          Qast.Node "ExMat"
            [Qast.Loc; e; Qast.List [Qast.Tuple [p1; Qast.Option None; e1]]]
      | "try"; e = SELF; "with"; "["; l = SLIST0 match_case SEP "|"; "]" ->
          Qast.Node "ExTry" [Qast.Loc; e; l]
      | "try"; e = SELF; "with"; p1 = ipatt; "->"; e1 = SELF ->
          Qast.Node "ExTry"
            [Qast.Loc; e; Qast.List [Qast.Tuple [p1; Qast.Option None; e1]]]
      | "if"; e1 = SELF; "then"; e2 = SELF; "else"; e3 = SELF ->
          Qast.Node "ExIfe" [Qast.Loc; e1; e2; e3]
      | "do"; "{"; seq = sequence; "}" -> mksequence Qast.Loc seq
      | "for"; i = a_LIDENT; "="; e1 = SELF; df = direction_flag; e2 = SELF;
        "do"; "{"; seq = sequence; "}" ->
          Qast.Node "ExFor" [Qast.Loc; i; e1; e2; df; seq]
      | "while"; e = SELF; "do"; "{"; seq = sequence; "}" ->
          Qast.Node "ExWhi" [Qast.Loc; e; seq] ]
    | "where"
      [ e = SELF; "where"; rf = rec_flag; lb = let_binding ->
          Qast.Node "ExLet" [Qast.Loc; rf; Qast.List [lb]; e] ]
    | ":=" NONA
      [ e1 = SELF; ":="; e2 = SELF; dummy ->
          Qast.Node "ExAss" [Qast.Loc; e1; e2] ]
    | "||" RIGHTA
      [ e1 = SELF; "||"; e2 = SELF ->
          Qast.Node "ExApp"
            [Qast.Loc;
             Qast.Node "ExApp"
               [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "||"]; e1];
             e2] ]
    | "&&" RIGHTA
      [ e1 = SELF; "&&"; e2 = SELF ->
          Qast.Node "ExApp"
            [Qast.Loc;
             Qast.Node "ExApp"
               [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "&&"]; e1];
             e2] ]
    | "<" LEFTA
      [ e1 = SELF; "<"; e2 = SELF ->
          Qast.Node "ExApp"
            [Qast.Loc;
             Qast.Node "ExApp"
               [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "<"]; e1];
             e2]
      | e1 = SELF; ">"; e2 = SELF ->
          Qast.Node "ExApp"
            [Qast.Loc;
             Qast.Node "ExApp"
               [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str ">"]; e1];
             e2]
      | e1 = SELF; "<="; e2 = SELF ->
          Qast.Node "ExApp"
            [Qast.Loc;
             Qast.Node "ExApp"
               [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "<="]; e1];
             e2]
      | e1 = SELF; ">="; e2 = SELF ->
          Qast.Node "ExApp"
            [Qast.Loc;
             Qast.Node "ExApp"
               [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str ">="]; e1];
             e2]
      | e1 = SELF; "="; e2 = SELF ->
          Qast.Node "ExApp"
            [Qast.Loc;
             Qast.Node "ExApp"
               [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "="]; e1];
             e2]
      | e1 = SELF; "<>"; e2 = SELF ->
          Qast.Node "ExApp"
            [Qast.Loc;
             Qast.Node "ExApp"
               [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "<>"]; e1];
             e2]
      | e1 = SELF; "=="; e2 = SELF ->
          Qast.Node "ExApp"
            [Qast.Loc;
             Qast.Node "ExApp"
               [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "=="]; e1];
             e2]
      | e1 = SELF; "!="; e2 = SELF ->
          Qast.Node "ExApp"
            [Qast.Loc;
             Qast.Node "ExApp"
               [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "!="]; e1];
             e2] ]
    | "^" RIGHTA
      [ e1 = SELF; "^"; e2 = SELF ->
          Qast.Node "ExApp"
            [Qast.Loc;
             Qast.Node "ExApp"
               [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "^"]; e1];
             e2]
      | e1 = SELF; "@"; e2 = SELF ->
          Qast.Node "ExApp"
            [Qast.Loc;
             Qast.Node "ExApp"
               [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "@"]; e1];
             e2] ]
    | "+" LEFTA
      [ e1 = SELF; "+"; e2 = SELF ->
          Qast.Node "ExApp"
            [Qast.Loc;
             Qast.Node "ExApp"
               [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "+"]; e1];
             e2]
      | e1 = SELF; "-"; e2 = SELF ->
          Qast.Node "ExApp"
            [Qast.Loc;
             Qast.Node "ExApp"
               [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "-"]; e1];
             e2]
      | e1 = SELF; "+."; e2 = SELF ->
          Qast.Node "ExApp"
            [Qast.Loc;
             Qast.Node "ExApp"
               [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "+."]; e1];
             e2]
      | e1 = SELF; "-."; e2 = SELF ->
          Qast.Node "ExApp"
            [Qast.Loc;
             Qast.Node "ExApp"
               [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "-."]; e1];
             e2] ]
    | "*" LEFTA
      [ e1 = SELF; "*"; e2 = SELF ->
          Qast.Node "ExApp"
            [Qast.Loc;
             Qast.Node "ExApp"
               [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "*"]; e1];
             e2]
      | e1 = SELF; "/"; e2 = SELF ->
          Qast.Node "ExApp"
            [Qast.Loc;
             Qast.Node "ExApp"
               [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "/"]; e1];
             e2]
      | e1 = SELF; "*."; e2 = SELF ->
          Qast.Node "ExApp"
            [Qast.Loc;
             Qast.Node "ExApp"
               [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "*."]; e1];
             e2]
      | e1 = SELF; "/."; e2 = SELF ->
          Qast.Node "ExApp"
            [Qast.Loc;
             Qast.Node "ExApp"
               [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "/."]; e1];
             e2]
      | e1 = SELF; "land"; e2 = SELF ->
          Qast.Node "ExApp"
            [Qast.Loc;
             Qast.Node "ExApp"
               [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "land"]; e1];
             e2]
      | e1 = SELF; "lor"; e2 = SELF ->
          Qast.Node "ExApp"
            [Qast.Loc;
             Qast.Node "ExApp"
               [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "lor"]; e1];
             e2]
      | e1 = SELF; "lxor"; e2 = SELF ->
          Qast.Node "ExApp"
            [Qast.Loc;
             Qast.Node "ExApp"
               [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "lxor"]; e1];
             e2]
      | e1 = SELF; "mod"; e2 = SELF ->
          Qast.Node "ExApp"
            [Qast.Loc;
             Qast.Node "ExApp"
               [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "mod"]; e1];
             e2] ]
    | "**" RIGHTA
      [ e1 = SELF; "**"; e2 = SELF ->
          Qast.Node "ExApp"
            [Qast.Loc;
             Qast.Node "ExApp"
               [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "**"]; e1];
             e2]
      | e1 = SELF; "asr"; e2 = SELF ->
          Qast.Node "ExApp"
            [Qast.Loc;
             Qast.Node "ExApp"
               [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "asr"]; e1];
             e2]
      | e1 = SELF; "lsl"; e2 = SELF ->
          Qast.Node "ExApp"
            [Qast.Loc;
             Qast.Node "ExApp"
               [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "lsl"]; e1];
             e2]
      | e1 = SELF; "lsr"; e2 = SELF ->
          Qast.Node "ExApp"
            [Qast.Loc;
             Qast.Node "ExApp"
               [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "lsr"]; e1];
             e2] ]
    | "unary minus" NONA
      [ "-"; e = SELF -> mkumin Qast.Loc (Qast.Str "-") e
      | "-."; e = SELF -> mkumin Qast.Loc (Qast.Str "-.") e ]
    | "apply" LEFTA
      [ e1 = SELF; e2 = SELF -> Qast.Node "ExApp" [Qast.Loc; e1; e2]
      | "assert"; e = SELF -> mkassert Qast.Loc e
      | "lazy"; e = SELF -> Qast.Node "ExLaz" [Qast.Loc; e] ]
    | "." LEFTA
      [ e1 = SELF; "."; "("; e2 = SELF; ")" ->
          Qast.Node "ExAre" [Qast.Loc; e1; e2]
      | e1 = SELF; "."; "["; e2 = SELF; "]" ->
          Qast.Node "ExSte" [Qast.Loc; e1; e2]
      | e1 = SELF; "."; e2 = SELF -> Qast.Node "ExAcc" [Qast.Loc; e1; e2] ]
    | "~-" NONA
      [ "~-"; e = SELF ->
          Qast.Node "ExApp"
            [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "~-"]; e]
      | "~-."; e = SELF ->
          Qast.Node "ExApp"
            [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "~-."]; e] ]
    | "simple"
      [ s = a_INT -> Qast.Node "ExInt" [Qast.Loc; s]
      | s = a_FLOAT -> Qast.Node "ExFlo" [Qast.Loc; s]
      | s = a_STRING -> Qast.Node "ExStr" [Qast.Loc; s]
      | s = a_CHAR -> Qast.Node "ExChr" [Qast.Loc; s]
      | i = expr_ident -> i
      | "["; "]" -> Qast.Node "ExUid" [Qast.Loc; Qast.Str "[]"]
      | "["; el = SLIST1 expr SEP ";"; last = cons_expr_opt; "]" ->
          mklistexp Qast.Loc last el
      | "[|"; el = SLIST0 expr SEP ";"; "|]" ->
          Qast.Node "ExArr" [Qast.Loc; el]
      | "{"; lel = SLIST1 label_expr SEP ";"; "}" ->
          Qast.Node "ExRec" [Qast.Loc; lel; Qast.Option None]
      | "{"; "("; e = SELF; ")"; "with"; lel = SLIST1 label_expr SEP ";";
        "}" ->
          Qast.Node "ExRec" [Qast.Loc; lel; Qast.Option (Some e)]
      | "("; ")" -> Qast.Node "ExUid" [Qast.Loc; Qast.Str "()"]
      | "("; e = SELF; ":"; t = ctyp; ")" ->
          Qast.Node "ExTyc" [Qast.Loc; e; t]
      | "("; e = SELF; ","; el = SLIST1 expr SEP ","; ")" ->
          Qast.Node "ExTup" [Qast.Loc; Qast.Cons e el]
      | "("; e = SELF; ")" -> e ] ]
  ;
  cons_expr_opt:
    [ [ "::"; e = expr -> Qast.Option (Some e)
      | -> Qast.Option None ] ]
  ;
  dummy:
    [ [ -> () ] ]
  ;
  sequence:
    [ [ "let"; rf = rec_flag; l = SLIST1 let_binding SEP "and";
        [ "in" | ";" ]; el = SELF ->
          Qast.List
            [Qast.Node "ExLet" [Qast.Loc; rf; l; mksequence Qast.Loc el]]
      | e = expr; ";"; el = SELF -> Qast.Cons e el
      | e = expr; ";" -> Qast.List [e]
      | e = expr -> Qast.List [e] ] ]
  ;
  let_binding:
    [ [ p = ipatt; e = fun_binding -> Qast.Tuple [p; e] ] ]
  ;
  fun_binding:
    [ RIGHTA
      [ p = ipatt; e = SELF ->
          Qast.Node "ExFun"
            [Qast.Loc; Qast.List [Qast.Tuple [p; Qast.Option None; e]]]
      | "="; e = expr -> e
      | ":"; t = ctyp; "="; e = expr -> Qast.Node "ExTyc" [Qast.Loc; e; t] ] ]
  ;
  match_case:
    [ [ p = patt; aso = as_patt_opt; w = when_expr_opt; "->"; e = expr ->
          mkmatchcase Qast.Loc p aso w e ] ]
  ;
  as_patt_opt:
    [ [ "as"; p = patt -> Qast.Option (Some p)
      | -> Qast.Option None ] ]
  ;
  when_expr_opt:
    [ [ "when"; e = expr -> Qast.Option (Some e)
      | -> Qast.Option None ] ]
  ;
  label_expr:
    [ [ i = patt_label_ident; e = fun_binding -> Qast.Tuple [i; e] ] ]
  ;
  expr_ident:
    [ RIGHTA
      [ i = a_LIDENT -> Qast.Node "ExLid" [Qast.Loc; i]
      | i = a_UIDENT -> Qast.Node "ExUid" [Qast.Loc; i]
      | i = a_UIDENT; "."; j = SELF -> mkexprident Qast.Loc i j ] ]
  ;
  fun_def:
    [ RIGHTA
      [ p = ipatt; e = SELF ->
          Qast.Node "ExFun"
            [Qast.Loc; Qast.List [Qast.Tuple [p; Qast.Option None; e]]]
      | "->"; e = expr -> e ] ]
  ;
  patt:
    [ LEFTA
      [ p1 = SELF; "|"; p2 = SELF -> Qast.Node "PaOrp" [Qast.Loc; p1; p2] ]
    | NONA
      [ p1 = SELF; ".."; p2 = SELF -> Qast.Node "PaRng" [Qast.Loc; p1; p2] ]
    | LEFTA
      [ p1 = SELF; p2 = SELF -> Qast.Node "PaApp" [Qast.Loc; p1; p2] ]
    | LEFTA
      [ p1 = SELF; "."; p2 = SELF -> Qast.Node "PaAcc" [Qast.Loc; p1; p2] ]
    | "simple"
      [ s = a_LIDENT -> Qast.Node "PaLid" [Qast.Loc; s]
      | s = a_UIDENT -> Qast.Node "PaUid" [Qast.Loc; s]
      | s = a_INT -> Qast.Node "PaInt" [Qast.Loc; s]
      | s = a_FLOAT -> Qast.Node "PaFlo" [Qast.Loc; s]
      | s = a_STRING -> Qast.Node "PaStr" [Qast.Loc; s]
      | s = a_CHAR -> Qast.Node "PaChr" [Qast.Loc; s]
      | "-"; s = a_INT -> mkuminpat Qast.Loc (Qast.Str "-") (Qast.Bool True) s
      | "-"; s = a_FLOAT ->
          mkuminpat Qast.Loc (Qast.Str "-") (Qast.Bool False) s
      | "["; "]" -> Qast.Node "PaUid" [Qast.Loc; Qast.Str "[]"]
      | "["; pl = SLIST1 patt SEP ";"; last = cons_patt_opt; "]" ->
          mklistpat Qast.Loc last pl
      | "[|"; pl = SLIST0 patt SEP ";"; "|]" ->
          Qast.Node "PaArr" [Qast.Loc; pl]
      | "{"; lpl = SLIST1 label_patt SEP ";"; "}" ->
          Qast.Node "PaRec" [Qast.Loc; lpl]
      | "("; ")" -> Qast.Node "PaUid" [Qast.Loc; Qast.Str "()"]
      | "("; p = SELF; ")" -> p
      | "("; p = SELF; ":"; t = ctyp; ")" ->
          Qast.Node "PaTyc" [Qast.Loc; p; t]
      | "("; p = SELF; "as"; p2 = SELF; ")" ->
          Qast.Node "PaAli" [Qast.Loc; p; p2]
      | "("; p = SELF; ","; pl = SLIST1 patt SEP ","; ")" ->
          Qast.Node "PaTup" [Qast.Loc; Qast.Cons p pl]
      | "_" -> Qast.Node "PaAny" [Qast.Loc] ] ]
  ;
  cons_patt_opt:
    [ [ "::"; p = patt -> Qast.Option (Some p)
      | -> Qast.Option None ] ]
  ;
  label_patt:
    [ [ i = patt_label_ident; "="; p = patt -> Qast.Tuple [i; p] ] ]
  ;
  patt_label_ident:
    [ LEFTA
      [ p1 = SELF; "."; p2 = SELF -> Qast.Node "PaAcc" [Qast.Loc; p1; p2] ]
    | "simple" RIGHTA
      [ i = a_UIDENT -> Qast.Node "PaUid" [Qast.Loc; i]
      | i = a_LIDENT -> Qast.Node "PaLid" [Qast.Loc; i] ] ]
  ;
  ipatt:
    [ [ "{"; lpl = SLIST1 label_ipatt SEP ";"; "}" ->
          Qast.Node "PaRec" [Qast.Loc; lpl]
      | "("; ")" -> Qast.Node "PaUid" [Qast.Loc; Qast.Str "()"]
      | "("; p = SELF; ")" -> p
      | "("; p = SELF; ":"; t = ctyp; ")" ->
          Qast.Node "PaTyc" [Qast.Loc; p; t]
      | "("; p = SELF; "as"; p2 = SELF; ")" ->
          Qast.Node "PaAli" [Qast.Loc; p; p2]
      | "("; p = SELF; ","; pl = SLIST1 ipatt SEP ","; ")" ->
          Qast.Node "PaTup" [Qast.Loc; Qast.Cons p pl]
      | s = a_LIDENT -> Qast.Node "PaLid" [Qast.Loc; s]
      | "_" -> Qast.Node "PaAny" [Qast.Loc] ] ]
  ;
  label_ipatt:
    [ [ i = patt_label_ident; "="; p = ipatt -> Qast.Tuple [i; p] ] ]
  ;
  type_declaration:
    [ [ n = type_patt; tpl = SLIST0 type_parameter; "="; tk = ctyp;
        cl = SLIST0 constrain ->
          Qast.Tuple [n; tpl; tk; cl] ] ]
  ;
  type_patt:
    [ [ n = a_LIDENT -> Qast.Tuple [Qast.Loc; n] ] ]
  ;
  constrain:
    [ [ "constraint"; t1 = ctyp; "="; t2 = ctyp -> Qast.Tuple [t1; t2] ] ]
  ;
  type_parameter:
    [ [ "'"; i = ident ->
          Qast.Tuple [i; Qast.Tuple [Qast.Bool False; Qast.Bool False]]
      | "+"; "'"; i = ident ->
          Qast.Tuple [i; Qast.Tuple [Qast.Bool True; Qast.Bool False]]
      | "-"; "'"; i = ident ->
          Qast.Tuple [i; Qast.Tuple [Qast.Bool False; Qast.Bool True]] ] ]
  ;
  ctyp:
    [ LEFTA
      [ t1 = SELF; "=="; t2 = SELF -> Qast.Node "TyMan" [Qast.Loc; t1; t2] ]
    | LEFTA
      [ t1 = SELF; "as"; t2 = SELF -> Qast.Node "TyAli" [Qast.Loc; t1; t2] ]
    | "arrow" RIGHTA
      [ t1 = SELF; "->"; t2 = SELF -> Qast.Node "TyArr" [Qast.Loc; t1; t2] ]
    | LEFTA
      [ t1 = SELF; t2 = SELF -> Qast.Node "TyApp" [Qast.Loc; t1; t2] ]
    | LEFTA
      [ t1 = SELF; "."; t2 = SELF -> Qast.Node "TyAcc" [Qast.Loc; t1; t2] ]
    | "simple"
      [ "'"; i = ident -> Qast.Node "TyQuo" [Qast.Loc; i]
      | "_" -> Qast.Node "TyAny" [Qast.Loc]
      | i = a_LIDENT -> Qast.Node "TyLid" [Qast.Loc; i]
      | i = a_UIDENT -> Qast.Node "TyUid" [Qast.Loc; i]
      | "("; t = SELF; "*"; tl = SLIST1 ctyp SEP "*"; ")" ->
          Qast.Node "TyTup" [Qast.Loc; Qast.Cons t tl]
      | "("; t = SELF; ")" -> t
      | "["; cdl = SLIST0 constructor_declaration SEP "|"; "]" ->
          Qast.Node "TySum" [Qast.Loc; cdl]
      | "{"; ldl = SLIST1 label_declaration SEP ";"; "}" ->
          Qast.Node "TyRec" [Qast.Loc; ldl] ] ]
  ;
  constructor_declaration:
    [ [ ci = a_UIDENT; "of"; cal = SLIST1 ctyp SEP "and" ->
          Qast.Tuple [Qast.Loc; ci; cal]
      | ci = a_UIDENT -> Qast.Tuple [Qast.Loc; ci; Qast.List []] ] ]
  ;
  label_declaration:
    [ [ i = a_LIDENT; ":"; mf = mutable_flag; t = ctyp ->
          Qast.Tuple [Qast.Loc; i; mf; t] ] ]
  ;
  ident:
    [ [ i = a_LIDENT -> i
      | i = a_UIDENT -> i ] ]
  ;
  mod_ident:
    [ RIGHTA
      [ i = a_UIDENT -> Qast.List [i]
      | i = a_LIDENT -> Qast.List [i]
      | i = a_UIDENT; "."; j = SELF -> Qast.Cons i j ] ]
  ;
  (* Objects and Classes *)
  str_item:
    [ [ "class"; cd = SLIST1 class_declaration SEP "and" ->
          Qast.Node "StCls" [Qast.Loc; cd]
      | "class"; "type"; ctd = SLIST1 class_type_declaration SEP "and" ->
          Qast.Node "StClt" [Qast.Loc; ctd] ] ]
  ;
  sig_item:
    [ [ "class"; cd = SLIST1 class_description SEP "and" ->
          Qast.Node "SgCls" [Qast.Loc; cd]
      | "class"; "type"; ctd = SLIST1 class_type_declaration SEP "and" ->
          Qast.Node "SgClt" [Qast.Loc; ctd] ] ]
  ;
  class_declaration:
    [ [ vf = virtual_flag; i = a_LIDENT; ctp = class_type_parameters;
        cfb = class_fun_binding ->
          Qast.Record
            [("ciLoc", Qast.Loc); ("ciVir", vf); ("ciPrm", ctp); ("ciNam", i);
             ("ciExp", cfb)] ] ]
  ;
  class_fun_binding:
    [ [ "="; ce = class_expr -> ce
      | ":"; ct = class_type; "="; ce = class_expr ->
          Qast.Node "CeTyc" [Qast.Loc; ce; ct]
      | p = ipatt; cfb = SELF -> Qast.Node "CeFun" [Qast.Loc; p; cfb] ] ]
  ;
  class_type_parameters:
    [ [ -> Qast.Tuple [Qast.Loc; Qast.List []]
      | "["; tpl = SLIST1 type_parameter SEP ","; "]" ->
          Qast.Tuple [Qast.Loc; tpl] ] ]
  ;
  class_fun_def:
    [ [ p = ipatt; ce = SELF -> Qast.Node "CeFun" [Qast.Loc; p; ce]
      | "->"; ce = class_expr -> ce ] ]
  ;
  class_expr:
    [ "top"
      [ "fun"; p = ipatt; ce = class_fun_def ->
          Qast.Node "CeFun" [Qast.Loc; p; ce]
      | "let"; rf = rec_flag; lb = SLIST1 let_binding SEP "and"; "in";
        ce = SELF ->
          Qast.Node "CeLet" [Qast.Loc; rf; lb; ce] ]
    | "apply" NONA
      [ ce = SELF; e = expr LEVEL "simple" ->
          Qast.Node "CeApp" [Qast.Loc; ce; e] ]
    | "simple"
      [ ci = class_longident; "["; ctcl = SLIST0 ctyp SEP ","; "]" ->
          Qast.Node "CeCon" [Qast.Loc; ci; ctcl]
      | ci = class_longident -> Qast.Node "CeCon" [Qast.Loc; ci; Qast.List []]
      | "object"; cspo = class_self_patt_opt; cf = class_structure; "end" ->
          Qast.Node "CeStr" [Qast.Loc; cspo; cf]
      | "("; ce = SELF; ":"; ct = class_type; ")" ->
          Qast.Node "CeTyc" [Qast.Loc; ce; ct]
      | "("; ce = SELF; ")" -> ce ] ]
  ;
  class_structure:
    [ [ cf = SLIST0 [ cf = class_str_item; ";" -> cf ] -> cf ] ]
  ;
  class_self_patt_opt:
    [ [ "("; p = patt; ")" -> Qast.Option (Some p)
      | "("; p = patt; ":"; t = ctyp; ")" ->
          Qast.Option (Some (Qast.Node "PaTyc" [Qast.Loc; p; t]))
      | -> Qast.Option None ] ]
  ;
  class_str_item:
    [ [ "declare"; st = SLIST0 [ s = class_str_item; ";" -> s ]; "end" ->
          Qast.Node "CrDcl" [Qast.Loc; st]
      | "inherit"; ce = class_expr; pb = as_lident_opt ->
          Qast.Node "CrInh" [Qast.Loc; ce; pb]
      | "value"; labmfe = cvalue ->
          let (lab, mf, e) =
            match labmfe with
            [ Qast.Tuple [xx1; xx2; xx3] -> (xx1, xx2, xx3)
            | _ -> match () with [] ]
          in
          Qast.Node "CrVal" [Qast.Loc; lab; mf; e]
      | "method"; "virtual"; "private"; l = label; ":"; t = ctyp ->
          Qast.Node "CrVir" [Qast.Loc; l; Qast.Bool True; t]
      | "method"; "virtual"; l = label; ":"; t = ctyp ->
          Qast.Node "CrVir" [Qast.Loc; l; Qast.Bool False; t]
      | "method"; "private"; l = label; fb = fun_binding ->
          Qast.Node "CrMth" [Qast.Loc; l; Qast.Bool True; fb]
      | "method"; l = label; fb = fun_binding ->
          Qast.Node "CrMth" [Qast.Loc; l; Qast.Bool False; fb]
      | "type"; t1 = ctyp; "="; t2 = ctyp ->
          Qast.Node "CrCtr" [Qast.Loc; t1; t2]
      | "initializer"; se = expr -> Qast.Node "CrIni" [Qast.Loc; se] ] ]
  ;
  as_lident_opt:
    [ [ "as"; i = a_LIDENT -> Qast.Option (Some i)
      | -> Qast.Option None ] ]
  ;
  cvalue:
    [ [ mf = mutable_flag; l = label; "="; e = expr -> Qast.Tuple [l; mf; e]
      | mf = mutable_flag; l = label; ":"; t = ctyp; "="; e = expr ->
          Qast.Tuple [l; mf; Qast.Node "ExTyc" [Qast.Loc; e; t]]
      | mf = mutable_flag; l = label; ":"; t = ctyp; ":>"; t2 = ctyp; "=";
        e = expr ->
          Qast.Tuple
            [l; mf; Qast.Node "ExCoe" [Qast.Loc; e; Qast.Option (Some t); t2]]
      | mf = mutable_flag; l = label; ":>"; t = ctyp; "="; e = expr ->
          Qast.Tuple
            [l; mf; Qast.Node "ExCoe" [Qast.Loc; e; Qast.Option None; t]] ] ]
  ;
  label:
    [ [ i = a_LIDENT -> i ] ]
  ;
  class_type:
    [ [ "["; t = ctyp; "]"; "->"; ct = SELF ->
          Qast.Node "CtFun" [Qast.Loc; t; ct]
      | id = clty_longident; "["; tl = SLIST1 ctyp SEP ","; "]" ->
          Qast.Node "CtCon" [Qast.Loc; id; tl]
      | id = clty_longident -> Qast.Node "CtCon" [Qast.Loc; id; Qast.List []]
      | "object"; cst = SOPT class_self_type;
        csf = SLIST0 [ csf = class_sig_item; ";" -> csf ]; "end" ->
          Qast.Node "CtSig" [Qast.Loc; cst; csf] ] ]
  ;
  class_self_type:
    [ [ "("; t = ctyp; ")" -> t ] ]
  ;
  class_sig_item:
    [ [ "declare"; st = SLIST0 [ s = class_sig_item; ";" -> s ]; "end" ->
          Qast.Node "CgDcl" [Qast.Loc; st]
      | "inherit"; cs = class_type -> Qast.Node "CgInh" [Qast.Loc; cs]
      | "value"; mf = mutable_flag; l = label; ":"; t = ctyp ->
          Qast.Node "CgVal" [Qast.Loc; l; mf; t]
      | "method"; "virtual"; "private"; l = label; ":"; t = ctyp ->
          Qast.Node "CgVir" [Qast.Loc; l; Qast.Bool True; t]
      | "method"; "virtual"; l = label; ":"; t = ctyp ->
          Qast.Node "CgVir" [Qast.Loc; l; Qast.Bool False; t]
      | "method"; "private"; l = label; ":"; t = ctyp ->
          Qast.Node "CgMth" [Qast.Loc; l; Qast.Bool True; t]
      | "method"; l = label; ":"; t = ctyp ->
          Qast.Node "CgMth" [Qast.Loc; l; Qast.Bool False; t]
      | "type"; t1 = ctyp; "="; t2 = ctyp ->
          Qast.Node "CgCtr" [Qast.Loc; t1; t2] ] ]
  ;
  class_description:
    [ [ vf = virtual_flag; n = a_LIDENT; ctp = class_type_parameters; ":";
        ct = class_type ->
          Qast.Record
            [("ciLoc", Qast.Loc); ("ciVir", vf); ("ciPrm", ctp); ("ciNam", n);
             ("ciExp", ct)] ] ]
  ;
  class_type_declaration:
    [ [ vf = virtual_flag; n = a_LIDENT; ctp = class_type_parameters; "=";
        cs = class_type ->
          Qast.Record
            [("ciLoc", Qast.Loc); ("ciVir", vf); ("ciPrm", ctp); ("ciNam", n);
             ("ciExp", cs)] ] ]
  ;
  expr: LEVEL "apply"
    [ LEFTA
      [ "new"; i = class_longident -> Qast.Node "ExNew" [Qast.Loc; i] ] ]
  ;
  expr: LEVEL "."
    [ [ e = SELF; "#"; lab = label -> Qast.Node "ExSnd" [Qast.Loc; e; lab] ] ]
  ;
  expr: LEVEL "simple"
    [ [ "("; e = SELF; ":"; t = ctyp; ":>"; t2 = ctyp; ")" ->
          Qast.Node "ExCoe" [Qast.Loc; e; Qast.Option (Some t); t2]
      | "("; e = SELF; ":>"; t = ctyp; ")" ->
          Qast.Node "ExCoe" [Qast.Loc; e; Qast.Option None; t]
      | "{<"; ">}" -> Qast.Node "ExOvr" [Qast.Loc; Qast.List []]
      | "{<"; fel = field_expr_list; ">}" ->
          Qast.Node "ExOvr" [Qast.Loc; fel] ] ]
  ;
  field_expr_list:
    [ [ l = label; "="; e = expr; ";"; fel = SELF ->
          Qast.Cons (Qast.Tuple [l; e]) fel
      | l = label; "="; e = expr; ";" -> Qast.List [Qast.Tuple [l; e]]
      | l = label; "="; e = expr -> Qast.List [Qast.Tuple [l; e]] ] ]
  ;
  ctyp: LEVEL "simple"
    [ [ "#"; id = class_longident -> Qast.Node "TyCls" [Qast.Loc; id]
      | "<"; mlv = meth_list; ">" ->
          let (ml, v) =
            match mlv with
            [ Qast.Tuple [xx1; xx2] -> (xx1, xx2)
            | _ -> match () with [] ]
          in
          Qast.Node "TyObj" [Qast.Loc; ml; v]
      | "<"; ">" ->
          Qast.Node "TyObj" [Qast.Loc; Qast.List []; Qast.Bool False] ] ]
  ;
  meth_list:
    [ [ f = field; ";"; mlv = SELF ->
          let (ml, v) =
            match mlv with
            [ Qast.Tuple [xx1; xx2] -> (xx1, xx2)
            | _ -> match () with [] ]
          in
          Qast.Tuple [Qast.Cons f ml; v]
      | f = field; ";" -> Qast.Tuple [Qast.List [f]; Qast.Bool False]
      | f = field -> Qast.Tuple [Qast.List [f]; Qast.Bool False]
      | ".." -> Qast.Tuple [Qast.List []; Qast.Bool True] ] ]
  ;
  field:
    [ [ lab = a_LIDENT; ":"; t = ctyp -> Qast.Tuple [lab; t] ] ]
  ;
  clty_longident:
    [ [ m = a_UIDENT; "."; l = SELF -> Qast.Cons m l
      | i = a_LIDENT -> Qast.List [i] ] ]
  ;
  class_longident:
    [ [ m = a_UIDENT; "."; l = SELF -> Qast.Cons m l
      | i = a_LIDENT -> Qast.List [i] ] ]
  ;
  (* Labels *)
  ctyp: AFTER "arrow"
    [ NONA
      [ i = a_TILDEIDENT; ":"; t = SELF -> Qast.Node "TyLab" [Qast.Loc; i; t]
      | i = a_QUESTIONIDENT; ":"; t = SELF ->
          Qast.Node "TyOlb" [Qast.Loc; i; t] ] ]
  ;
  ctyp: LEVEL "simple"
    [ [ "[|"; rfl = SLIST0 row_field SEP "|"; "|]" ->
          Qast.Node "TyVrn" [Qast.Loc; rfl; Qast.Option None]
      | "[|"; ">"; rfl = row_field_list; "|]" ->
          Qast.Node "TyVrn"
            [Qast.Loc; rfl; Qast.Option (Some (Qast.Option None))]
      | "[|"; "<"; rfl = row_field_list; "|]" ->
          Qast.Node "TyVrn"
            [Qast.Loc; rfl;
             Qast.Option (Some (Qast.Option (Some (Qast.List []))))]
      | "[|"; "<"; rfl = row_field_list; ">"; ntl = SLIST1 name_tag; "|]" ->
          Qast.Node "TyVrn"
            [Qast.Loc; rfl; Qast.Option (Some (Qast.Option (Some ntl)))] ] ]
  ;
  row_field_list:
    [ [ rfl = SLIST1 row_field SEP "|" -> rfl ] ]
  ;
  row_field:
    [ [ "`"; i = ident -> Qast.Node "RfTag" [i; Qast.Bool True; Qast.List []]
      | "`"; i = ident; "of"; ao = SOPT "&"; l = SLIST1 ctyp SEP "&" ->
          Qast.Node "RfTag" [i; o2b ao; l]
      | t = ctyp -> Qast.Node "RfInh" [t] ] ]
  ;
  name_tag:
    [ [ "`"; i = ident -> i ] ]
  ;
  patt: LEVEL "simple"
    [ [ "`"; s = ident -> Qast.Node "PaVrn" [Qast.Loc; s]
      | "#"; sl = mod_ident -> Qast.Node "PaTyp" [Qast.Loc; sl]
      | i = a_TILDEIDENT; ":"; p = SELF -> Qast.Node "PaLab" [Qast.Loc; i; p]
      | i = a_TILDEIDENT ->
          Qast.Node "PaLab" [Qast.Loc; i; Qast.Node "PaLid" [Qast.Loc; i]]
      | i = a_QUESTIONIDENT; ":"; "("; p = SELF; ")" ->
          Qast.Node "PaOlb" [Qast.Loc; i; p; Qast.Option None]
      | i = a_QUESTIONIDENT; ":"; "("; p = SELF; "="; e = expr; ")" ->
          Qast.Node "PaOlb" [Qast.Loc; i; p; Qast.Option (Some e)]
      | i = a_QUESTIONIDENT; ":"; "("; p = SELF; ":"; t = ctyp; ")" ->
          Qast.Node "PaOlb"
            [Qast.Loc; i; Qast.Node "PaTyc" [Qast.Loc; p; t];
             Qast.Option None]
      | i = a_QUESTIONIDENT; ":"; "("; p = SELF; ":"; t = ctyp; "="; e = expr;
        ")" ->
          Qast.Node "PaOlb"
            [Qast.Loc; i; Qast.Node "PaTyc" [Qast.Loc; p; t];
             Qast.Option (Some e)]
      | i = a_QUESTIONIDENT ->
          Qast.Node "PaOlb"
            [Qast.Loc; i; Qast.Node "PaLid" [Qast.Loc; i]; Qast.Option None]
      | "?"; "("; i = a_LIDENT; "="; e = expr; ")" ->
          Qast.Node "PaOlb"
            [Qast.Loc; i; Qast.Node "PaLid" [Qast.Loc; i];
             Qast.Option (Some e)]
      | "?"; "("; i = a_LIDENT; ":"; t = ctyp; "="; e = expr; ")" ->
          Qast.Node "PaOlb"
            [Qast.Loc; i;
             Qast.Node "PaTyc" [Qast.Loc; Qast.Node "PaLid" [Qast.Loc; i]; t];
             Qast.Option (Some e)] ] ]
  ;
  ipatt:
    [ [ i = a_TILDEIDENT; ":"; p = SELF -> Qast.Node "PaLab" [Qast.Loc; i; p]
      | i = a_TILDEIDENT ->
          Qast.Node "PaLab" [Qast.Loc; i; Qast.Node "PaLid" [Qast.Loc; i]]
      | i = a_QUESTIONIDENT; ":"; "("; p = SELF; ")" ->
          Qast.Node "PaOlb" [Qast.Loc; i; p; Qast.Option None]
      | i = a_QUESTIONIDENT; ":"; "("; p = SELF; "="; e = expr; ")" ->
          Qast.Node "PaOlb" [Qast.Loc; i; p; Qast.Option (Some e)]
      | i = a_QUESTIONIDENT; ":"; "("; p = SELF; ":"; t = ctyp; ")" ->
          Qast.Node "PaOlb"
            [Qast.Loc; i; Qast.Node "PaTyc" [Qast.Loc; p; t];
             Qast.Option None]
      | i = a_QUESTIONIDENT; ":"; "("; p = SELF; ":"; t = ctyp; "="; e = expr;
        ")" ->
          Qast.Node "PaOlb"
            [Qast.Loc; i; Qast.Node "PaTyc" [Qast.Loc; p; t];
             Qast.Option (Some e)]
      | i = a_QUESTIONIDENT ->
          Qast.Node "PaOlb"
            [Qast.Loc; i; Qast.Node "PaLid" [Qast.Loc; i]; Qast.Option None]
      | "?"; "("; i = a_LIDENT; "="; e = expr; ")" ->
          Qast.Node "PaOlb"
            [Qast.Loc; i; Qast.Node "PaLid" [Qast.Loc; i];
             Qast.Option (Some e)]
      | "?"; "("; i = a_LIDENT; ":"; t = ctyp; "="; e = expr; ")" ->
          Qast.Node "PaOlb"
            [Qast.Loc; i;
             Qast.Node "PaTyc" [Qast.Loc; Qast.Node "PaLid" [Qast.Loc; i]; t];
             Qast.Option (Some e)] ] ]
  ;
  expr: AFTER "apply"
    [ "label" NONA
      [ i = a_TILDEIDENT; ":"; e = SELF -> Qast.Node "ExLab" [Qast.Loc; i; e]
      | i = a_TILDEIDENT ->
          Qast.Node "ExLab" [Qast.Loc; i; Qast.Node "ExLid" [Qast.Loc; i]]
      | i = a_QUESTIONIDENT; ":"; e = SELF ->
          Qast.Node "ExOlb" [Qast.Loc; i; e]
      | i = a_QUESTIONIDENT ->
          Qast.Node "ExOlb" [Qast.Loc; i; Qast.Node "ExLid" [Qast.Loc; i]] ] ]
  ;
  expr: LEVEL "simple"
    [ [ "`"; s = ident -> Qast.Node "ExVrn" [Qast.Loc; s] ] ]
  ;
  rec_flag:
    [ [ "rec" -> Qast.Bool True
      | -> Qast.Bool False ] ]
  ;
  direction_flag:
    [ [ "to" -> Qast.Bool True
      | "downto" -> Qast.Bool False ] ]
  ;
  mutable_flag:
    [ [ "mutable" -> Qast.Bool True
      | -> Qast.Bool False ] ]
  ;
  virtual_flag:
    [ [ "virtual" -> Qast.Bool True
      | -> Qast.Bool False ] ]
  ;
  (* Compatibility old syntax of sequences *)
  expr: LEVEL "top"
    [ [ "do"; seq = SLIST0 [ e = expr; ";" -> e ]; "return"; warning_sequence;
        e = SELF ->
          Qast.Node "ExSeq" [Qast.Loc; append_elem seq e]
      | "for"; i = a_LIDENT; "="; e1 = SELF; df = direction_flag; e2 = SELF;
        "do"; seq = SLIST0 [ e = expr; ";" -> e ]; warning_sequence; "done" ->
          Qast.Node "ExFor" [Qast.Loc; i; e1; e2; df; seq]
      | "while"; e = SELF; "do"; seq = SLIST0 [ e = expr; ";" -> e ];
        warning_sequence; "done" ->
          Qast.Node "ExWhi" [Qast.Loc; e; seq] ] ]
  ;
  warning_sequence:
    [ [ -> warning_seq () ] ]
  ;
  (* Antiquotations for local entries *)
  sequence:
    [ [ a = ANTIQUOT "list" -> antiquot "list" loc a ] ]
  ;
  expr_ident:
    [ [ a = ANTIQUOT -> antiquot "" loc a ] ]
  ;
  patt_label_ident: LEVEL "simple"
    [ [ a = ANTIQUOT -> antiquot "" loc a ] ]
  ;
  when_expr_opt:
    [ [ a = ANTIQUOT "when" -> antiquot "when" loc a ] ]
  ;
  mod_ident:
    [ [ a = ANTIQUOT -> antiquot "" loc a ] ]
  ;
  class_self_patt_opt:
    [ [ a = ANTIQUOT "opt" -> antiquot "opt" loc a
      | a = ANTIQUOT -> antiquot "" loc a ] ]
  ;
  as_lident_opt:
    [ [ a = ANTIQUOT "as" -> antiquot "as" loc a ] ]
  ;
  meth_list:
    [ [ a = a_list -> Qast.Tuple [a; Qast.Bool False]
      | a = a_list; b = ANTIQUOT -> Qast.Tuple [a; antiquot "" loc b] ] ]
  ;
  clty_longident:
    [ [ a = a_list -> a ] ]
  ;
  class_longident:
    [ [ a = a_list -> a ] ]
  ;
  rec_flag:
    [ [ a = ANTIQUOT "rec" -> antiquot "rec" loc a ] ]
  ;
  direction_flag:
    [ [ a = ANTIQUOT "to" -> antiquot "to" loc a ] ]
  ;
  mutable_flag:
    [ [ a = ANTIQUOT "mut" -> antiquot "mut" loc a ] ]
  ;
  virtual_flag:
    [ [ a = ANTIQUOT "virt" -> antiquot "virt" loc a ] ]
  ;
  (* compatibility hack with version 3.04 *)
  class_expr: LEVEL "simple"
    [ [ "object"; cspo = ANTIQUOT; cf = class_structure; "end" ->
          Qast.Node "CeStr" [Qast.Loc; antiquot "" loc cspo; cf] ] ]
  ;
END;

EXTEND
  GLOBAL: str_item sig_item;
  str_item:
    [ [ "#"; n = a_LIDENT; dp = dir_param ->
          Qast.Node "StDir" [Qast.Loc; n; dp] ] ]
  ;
  sig_item:
    [ [ "#"; n = a_LIDENT; dp = dir_param ->
          Qast.Node "SgDir" [Qast.Loc; n; dp] ] ]
  ;
  dir_param:
    [ [ a = ANTIQUOT "opt" -> antiquot "opt" loc a
      | e = expr -> Qast.Option (Some e)
      | -> Qast.Option None ] ]
  ;
END;

(* Antiquotations *)

EXTEND
  module_expr: LEVEL "simple"
    [ [ a = ANTIQUOT "mexp" -> antiquot "mexp" loc a
      | a = ANTIQUOT -> antiquot "" loc a ] ]
  ;
  str_item: LEVEL "top"
    [ [ a = ANTIQUOT "stri" -> antiquot "stri" loc a
      | a = ANTIQUOT -> antiquot "" loc a ] ]
  ;
  module_type: LEVEL "simple"
    [ [ a = ANTIQUOT "mtyp" -> antiquot "mtyp" loc a
      | a = ANTIQUOT -> antiquot "" loc a ] ]
  ;
  sig_item: LEVEL "top"
    [ [ a = ANTIQUOT "sigi" -> antiquot "sigi" loc a
      | a = ANTIQUOT -> antiquot "" loc a ] ]
  ;
  expr: LEVEL "simple"
    [ [ a = ANTIQUOT "exp" -> antiquot "exp" loc a
      | a = ANTIQUOT -> antiquot "" loc a
      | a = ANTIQUOT "anti" ->
          Qast.Node "ExAnt" [Qast.Loc; antiquot "anti" loc a]
      | "("; el = a_list; ")" -> Qast.Node "ExTup" [Qast.Loc; el] ] ]
  ;
  patt: LEVEL "simple"
    [ [ a = ANTIQUOT "pat" -> antiquot "pat" loc a
      | a = ANTIQUOT -> antiquot "" loc a
      | a = ANTIQUOT "anti" ->
          Qast.Node "PaAnt" [Qast.Loc; antiquot "anti" loc a]
      | "("; pl = a_list; ")" -> Qast.Node "PaTup" [Qast.Loc; pl] ] ]
  ;
  ipatt:
    [ [ a = ANTIQUOT "pat" -> antiquot "pat" loc a
      | a = ANTIQUOT -> antiquot "" loc a
      | a = ANTIQUOT "anti" ->
          Qast.Node "PaAnt" [Qast.Loc; antiquot "anti" loc a]
      | "("; pl = a_list; ")" -> Qast.Node "PaTup" [Qast.Loc; pl] ] ]
  ;
  ctyp: LEVEL "simple"
    [ [ a = ANTIQUOT "typ" -> antiquot "typ" loc a
      | a = ANTIQUOT -> antiquot "" loc a
      | "("; tl = a_list; ")" -> Qast.Node "TyTup" [Qast.Loc; tl] ] ]
  ;
  class_expr: LEVEL "simple"
    [ [ a = ANTIQUOT -> antiquot "" loc a ] ]
  ;
  class_str_item:
    [ [ a = ANTIQUOT -> antiquot "" loc a ] ]
  ;
  class_sig_item:
    [ [ a = ANTIQUOT -> antiquot "" loc a ] ]
  ;
  class_type:
    [ [ a = ANTIQUOT -> antiquot "" loc a ] ]
  ;
  expr: LEVEL "simple"
    [ [ "{<"; fel = a_list; ">}" -> Qast.Node "ExOvr" [Qast.Loc; fel] ] ]
  ;
  patt: LEVEL "simple"
    [ [ "#"; a = a_list -> Qast.Node "PaTyp" [Qast.Loc; a] ] ]
  ;
  a_list:
    [ [ a = ANTIQUOT "list" -> antiquot "list" loc a ] ]
  ;
  a_opt:
    [ [ a = ANTIQUOT "opt" -> antiquot "opt" loc a ] ]
  ;
  a_UIDENT:
    [ [ a = ANTIQUOT "uid" -> antiquot "uid" loc a
      | a = ANTIQUOT -> antiquot "" loc a
      | i = UIDENT -> Qast.Str i ] ]
  ;
  a_LIDENT:
    [ [ a = ANTIQUOT "lid" -> antiquot "lid" loc a
      | a = ANTIQUOT -> antiquot "" loc a
      | i = LIDENT -> Qast.Str i ] ]
  ;
  a_INT:
    [ [ a = ANTIQUOT "int" -> antiquot "int" loc a
      | a = ANTIQUOT -> antiquot "" loc a
      | s = INT -> Qast.Str s ] ]
  ;
  a_FLOAT:
    [ [ a = ANTIQUOT "flo" -> antiquot "flo" loc a
      | a = ANTIQUOT -> antiquot "" loc a
      | s = FLOAT -> Qast.Str s ] ]
  ;
  a_STRING:
    [ [ a = ANTIQUOT "str" -> antiquot "str" loc a
      | a = ANTIQUOT -> antiquot "" loc a
      | s = STRING -> Qast.Str s ] ]
  ;
  a_CHAR:
    [ [ a = ANTIQUOT "chr" -> antiquot "chr" loc a
      | a = ANTIQUOT -> antiquot "" loc a
      | s = CHAR -> Qast.Str s ] ]
  ;
  a_TILDEIDENT:
    [ [ "~"; a = ANTIQUOT -> antiquot "" loc a
      | s = TILDEIDENT -> Qast.Str s ] ]
  ;
  a_QUESTIONIDENT:
    [ [ "?"; a = ANTIQUOT -> antiquot "" loc a
      | s = QUESTIONIDENT -> Qast.Str s ] ]
  ;
END;

value apply_entry e =
  let f s = Grammar.Entry.parse e (Stream.of_string s) in
  let expr s = Qast.to_expr (f s) in
  let patt s = Qast.to_patt (f s) in
  Quotation.ExAst (expr, patt)
;

let sig_item_eoi = Grammar.Entry.create gram "signature item" in
do {
  EXTEND
    sig_item_eoi:
      [ [ x = sig_item; EOI -> x ] ]
    ;
  END;
  Quotation.add "sig_item" (apply_entry sig_item_eoi)
};

let str_item_eoi = Grammar.Entry.create gram "structure item" in
do {
  EXTEND
    str_item_eoi:
      [ [ x = str_item; EOI -> x ] ]
    ;
  END;
  Quotation.add "str_item" (apply_entry str_item_eoi)
};

let ctyp_eoi = Grammar.Entry.create gram "type" in
do {
  EXTEND
    ctyp_eoi:
      [ [ x = ctyp; EOI -> x ] ]
    ;
  END;
  Quotation.add "ctyp" (apply_entry ctyp_eoi)
};

let patt_eoi = Grammar.Entry.create gram "pattern" in
do {
  EXTEND
    patt_eoi:
      [ [ x = patt; EOI -> x ] ]
    ;
  END;
  Quotation.add "patt" (apply_entry patt_eoi)
};

let expr_eoi = Grammar.Entry.create gram "expression" in
do {
  EXTEND
    expr_eoi:
      [ [ x = expr; EOI -> x ] ]
    ;
  END;
  Quotation.add "expr" (apply_entry expr_eoi)
};

let module_type_eoi = Grammar.Entry.create gram "module type" in
do {
  EXTEND
    module_type_eoi:
      [ [ x = module_type; EOI -> x ] ]
    ;
  END;
  Quotation.add "module_type" (apply_entry module_type_eoi)
};

let module_expr_eoi = Grammar.Entry.create gram "module expression" in
do {
  EXTEND
    module_expr_eoi:
      [ [ x = module_expr; EOI -> x ] ]
    ;
  END;
  Quotation.add "module_expr" (apply_entry module_expr_eoi)
};

let class_type_eoi = Grammar.Entry.create gram "class_type" in
do {
  EXTEND
    class_type_eoi:
      [ [ x = class_type; EOI -> x ] ]
    ;
  END;
  Quotation.add "class_type" (apply_entry class_type_eoi)
};

let class_expr_eoi = Grammar.Entry.create gram "class_expr" in
do {
  EXTEND
    class_expr_eoi:
      [ [ x = class_expr; EOI -> x ] ]
    ;
  END;
  Quotation.add "class_expr" (apply_entry class_expr_eoi)
};

let class_sig_item_eoi = Grammar.Entry.create gram "class_sig_item" in
do {
  EXTEND
    class_sig_item_eoi:
      [ [ x = class_sig_item; EOI -> x ] ]
    ;
  END;
  Quotation.add "class_sig_item" (apply_entry class_sig_item_eoi)
};

let class_str_item_eoi = Grammar.Entry.create gram "class_str_item" in
do {
  EXTEND
    class_str_item_eoi:
      [ [ x = class_str_item; EOI -> x ] ]
    ;
  END;
  Quotation.add "class_str_item" (apply_entry class_str_item_eoi)
};