path: root/camlp4/unmaintained/sml/pa_sml.ml

(* pa_r.cmo pa_rp.cmo pa_extend.cmo q_MLast.cmo pr_dump.cmo *)
(***********************************************************************)
(*                                                                     *)
(*                               Camlp4                                *)
(*                                                                     *)
(*    Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt         *)
(*                                                                     *)
(*  Copyright 2002 Institut National de Recherche en Informatique et   *)
(*  en Automatique.  All rights reserved.  This file is distributed    *)
(*  under the terms of the GNU Library General Public License, with    *)
(*  the special exception on linking described in file                 *)
(*   ../../../LICENSE.                                                 *)
(*                                                                     *)
(***********************************************************************)



open Stdpp;
open Pcaml;

value ocaml_records = ref False;

Pcaml.no_constructors_arity.val := True;

value lexer = Plexer.gmake ();

do {
  Grammar.Unsafe.gram_reinit gram lexer;
  Grammar.Unsafe.clear_entry interf;
  Grammar.Unsafe.clear_entry implem;
  Grammar.Unsafe.clear_entry top_phrase;
  Grammar.Unsafe.clear_entry use_file;
  Grammar.Unsafe.clear_entry module_type;
  Grammar.Unsafe.clear_entry module_expr;
  Grammar.Unsafe.clear_entry sig_item;
  Grammar.Unsafe.clear_entry str_item;
  Grammar.Unsafe.clear_entry expr;
  Grammar.Unsafe.clear_entry patt;
  Grammar.Unsafe.clear_entry ctyp;
  Grammar.Unsafe.clear_entry let_binding;
};

Pcaml.parse_interf.val := Grammar.Entry.parse interf;
Pcaml.parse_implem.val := Grammar.Entry.parse implem;

value not_impl loc s =
  raise_with_loc loc (Stream.Error ("not implemented feature [" ^ s ^ "]"))
;

type altern 'a 'b = [ Left of 'a | Right of 'b ];

value get_seq =
  fun
  [ <:expr< do { $list:el$ } >> -> el
  | e -> [e] ]
;

value choose_tvar tpl =
  let rec find_alpha v =
    let s = String.make 1 v in
    if List.mem_assoc s tpl then
      if v = 'z' then None else find_alpha (Char.chr (Char.code v + 1))
    else Some (String.make 1 v)
  in
  let rec make_n n =
    let v = "a" ^ string_of_int n in
    if List.mem_assoc v tpl then make_n (succ n) else v
  in
  match find_alpha 'a' with
  [ Some x -> x
  | None -> make_n 1 ]
;

value mklistexp loc last =
  loop True where rec loop top =
    fun
    [ [] ->
        match last with
        [ Some e -> e
        | None -> <:expr< [] >> ]
    | [e1 :: el] ->
        let loc = if top then loc else (fst (MLast.loc_of_expr e1), snd loc) in
        <:expr< [$e1$ :: $loop False el$] >> ]
;

value mklistpat loc last =
  loop True where rec loop top =
    fun
    [ [] ->
        match last with
        [ Some p -> p
        | None -> <:patt< [] >> ]
    | [p1 :: pl] ->
        let loc = if top then loc else (fst (MLast.loc_of_patt p1), snd loc) in
        <:patt< [$p1$ :: $loop False pl$] >> ]
;

value expr_of_patt p =
  let loc = MLast.loc_of_patt p in
  match p with
  [ <:patt< $lid:x$ >> -> <:expr< $lid:x$ >>
  | _ -> Stdpp.raise_with_loc loc (Stream.Error "identifier expected") ]
;

value apply_bind loc e bl =
  let rec loop e =
    fun
    [ [] -> e
    | [<:str_item< value $p1$ = $e1$ >> :: list] ->
        loop_let e [(p1, e1)] list
    | [<:str_item< value rec $p1$ = $e1$ >> :: list] ->
        loop_letrec e [(p1, e1)] list
    | [<:str_item< module $s$ = $me$ >> :: list] ->
        let e = <:expr< let module $s$ = $me$ in $e$ >> in
        loop e list
    | [si :: list] ->
        raise Exit ]
  and loop_let e pel =
    fun
    [ [<:str_item< value $p1$ = $e1$ >> :: list] ->
        loop_let e [(p1, e1) :: pel] list
    | list ->
        let e = <:expr< let $list:pel$ in $e$ >> in
        loop e list ]
  and loop_letrec e pel =
    fun
    [ [<:str_item< value rec $p1$ = $e1$ >> :: list] ->
        loop_letrec e [(p1, e1) :: pel] list
    | list ->
        let e = <:expr< let rec $list:pel$ in $e$ >> in
        loop e list ]
  in
  loop e (List.rev bl)
;

value make_local loc sl1 sl2 =
  try
    let pl =
      List.map
        (fun
         [ <:str_item< value $opt:_$ $p$ = $_$ >> -> p
         | _ -> raise Exit ])
        sl2
      in
    let e1 =
      match List.map expr_of_patt pl with
      [ [e] -> e
      | el -> <:expr< ($list:el$) >> ]
    in
    let p1 =
      match pl with
      [ [p] -> p
      | pl -> <:patt< ($list:pl$) >> ]
    in
    let e = apply_bind loc e1 sl2 in
    let e = apply_bind loc e sl1 in
    <:str_item< value $p1$ = $e$ >>
  with
  [ Exit ->
      do {
        Printf.eprintf "\
*** Warning: a 'local' statement will be defined global because of bindings
which cannot be defined as first class values (modules, exceptions, ...)\n";
        flush stderr;
        <:str_item< declare $list:sl1 @ sl2$ end >>
      } ]
;

value str_declare loc =
  fun
  [ [d] -> d
  | dl -> <:str_item< declare $list:dl$ end >> ]
;

value sig_declare loc =
  fun
  [ [d] -> d
  | dl -> <:sig_item< declare $list:dl$ end >> ]
;

value extract_label_types loc tn tal cdol =
  let (cdl, aux) =
    List.fold_right
      (fun (loc, c, tl, aux_opt) (cdl, aux) ->
         match aux_opt with
         [ Some anon_record_type ->
             let new_tn = tn ^ "_" ^ c in
             let loc = MLast.loc_of_ctyp anon_record_type in
             let aux_def = ((loc, new_tn), [], anon_record_type, []) in
             let tl = [<:ctyp< $lid:new_tn$ >>] in
             ([(loc, c, tl) :: cdl], [aux_def :: aux])
         | None -> ([(loc, c, tl) :: cdl], aux) ])
      cdol ([], [])
  in
  [((loc, tn), tal, <:ctyp< [ $list:cdl$ ] >>, []) :: aux]
;

value function_of_clause_list loc xl =
  let (fname, fname_loc, nbpat, l) =
    List.fold_left
      (fun (fname, fname_loc, nbpat, l) ((x1, loc), x2, x3, x4) ->
         let (fname, fname_loc, nbpat) =
           if fname = "" then (x1, loc, List.length x2)
           else if x1 <> fname then
             raise_with_loc loc
               (Stream.Error ("'" ^ fname ^ "' expected"))
           else if List.length x2 <> nbpat then
             raise_with_loc loc
               (Stream.Error "bad number of patterns in that clause")
           else (fname, fname_loc, nbpat)
         in
         let x4 =
           match x3 with
           [ Some t -> <:expr< ($x4$ : $t$) >>
           | _ -> x4 ]
         in
         let l = [(x2, x4) :: l] in
         (fname, fname_loc, nbpat, l))
      ("", loc, 0, []) xl
  in
  let l = List.rev l in
  let e =
    match l with
    [ [(pl, e)] ->
        List.fold_right (fun p e -> <:expr< fun $p$ -> $e$ >>) pl e
    | _ ->
        if nbpat = 1 then
          let pwel =
            List.map
              (fun (pl, e) -> (<:patt< $List.hd pl$ >>, None, e)) l
          in
          <:expr< fun [ $list:pwel$ ] >>
        else
          let sl =
            loop 0 where rec loop n =
              if n = nbpat then []
              else ["a" ^ string_of_int (n + 1) :: loop (n + 1)]
          in
          let e =
            let el = List.map (fun s -> <:expr< $lid:s$ >>) sl in
            let pwel =
              List.map
                (fun (pl, e) -> (<:patt< ($list:pl$) >>, None, e)) l
            in
            <:expr< match ($list:el$) with [ $list:pwel$ ] >>
          in
          List.fold_right (fun s e -> <:expr< fun $lid:s$ -> $e$ >>) sl e ]
  in
  (let loc = fname_loc in <:patt< $lid:fname$ >>, e)
;

value record_expr loc x1 =
  if ocaml_records.val then <:expr< { $list:x1$ } >>
  else
    let list1 =
      List.map
        (fun (l, v) ->
           let id =
             match l with
             [ <:patt< $lid:l$ >> -> l
             | _ -> "" ]
           in
           let loc = MLast.loc_of_expr v in
           <:class_str_item< value $id$ = $v$ >>)
        x1
    in
    let list2 =
      List.map
        (fun (l, v) ->
           let id =
             match l with
             [ <:patt< $lid:l$ >> -> l
             | _ -> "" ]
           in
           let loc = MLast.loc_of_patt l in
           <:class_str_item< method $id$ = $lid:id$ >>)
        x1
    in
    <:expr<
      let module M =
        struct
          class a = object $list:list1 @ list2$ end;
        end
      in
      new M.a
    >>
;

value record_match_assoc loc lpl e =
  if ocaml_records.val then (<:patt< { $list:lpl$ } >>, e)
  else
    let pl = List.map (fun (_, p) -> p) lpl in
    let e =
      let el =
        List.map
          (fun (l, _) ->
             let s =
               match l with
               [ <:patt< $lid:l$ >> -> l
               | _ -> "" ]
             in
             let loc = MLast.loc_of_patt l in
             <:expr< v # $lid:s$ >>)
          lpl
      in
      let loc = MLast.loc_of_expr e in
      <:expr< let v = $e$ in ($list:el$) >>
    in
    let p = <:patt< ($list:pl$) >> in
    (p, e)
;

value op =
  Grammar.Entry.of_parser gram "op"
    (parser [: `("", "op"); `(_, x) :] -> x)
;
lexer.Token.tok_using ("", "op");

value special x =
  if String.length x >= 2 then
    match x.[0] with
    [ '+' | '<' | '^' -> True
    | _ -> False ]
  else False
;

value idd =
  let p =
    parser
    [ [: `("LIDENT", x) :] -> x
    | [: `("UIDENT", x) :] -> x
    | [: `("", "op"); `(_, x) :] -> x
    | [: `("", x) when special x :] -> x ]
  in
  Grammar.Entry.of_parser Pcaml.gram "ID" p
;

value uncap s = String.uncapitalize s;

EXTEND
  GLOBAL: implem interf top_phrase use_file sig_item str_item ctyp patt expr
    module_type module_expr;

  implem:
    [ [ x = interdec; EOI -> x ] ]
  ;
  interf:
    [ [ x = LIST1 [ s = sig_item; OPT ";" -> (s, loc) ] -> (x, False) ] ]
  ;
  top_phrase:
    [ [ ph = phrase; ";" -> Some ph
      | EOI -> None ] ]
  ;
  use_file:
    [ [ l = LIST0 phrase; EOI -> (l, False) ] ]
  ;
  phrase:
    [ [ x = str_item -> x
      | x = expr -> <:str_item< $exp:x$ >>
      | "#"; n = LIDENT; dp = dir_param -> MLast.StDir loc n dp ] ]
  ;
  dir_param:
    [ [ -> None
      | e = expr -> Some e ] ]
  ;
  sdecs:
    [ [ x = sdec; l = sdecs -> [x :: l]
      | ";"; l = sdecs -> l
      | -> [] ] ]
  ;

  fsigb: [ [ -> not_impl loc "fsigb" ] ];
  fsigconstraint_op: [ [ -> not_impl loc "fsigconstraint_op" ] ];
  fct_exp: [ [ -> not_impl loc "fct_exp" ] ];
  exp_pa: [ [ -> not_impl loc "exp_pa" ] ];
  rvb: [ [ -> not_impl loc "rvb" ] ];
  tyvarseq: [ [ -> not_impl loc "tyvarseq" ] ];

  tyvar_pc:
    [ [ "'"; x1 = LIDENT -> [(x1, (False, False))]
      | "'"; x1 = LIDENT; ","; l = tyvar_pc -> [(x1, (False, False)) :: l] ] ]
  ;
  id:
    [ [ x1 = idd -> x1
      | "*" -> "*" ] ]
  ;
  ident:
    [ [ x1 = idd -> x1
      | "*" -> "*"
      | "=" -> "="
      | "<" -> "<"
      | ">" -> ">"
      | "<=" -> "<="
      | ">=" -> ">="
      | "^" -> "^" ] ]
  ;
  op_op:
    [ [ x1 = op -> not_impl loc "op_op 1"
      | -> () ] ]
  ;
  qid:
    [ [ x1 = idd; "."; x2 = qid -> <:module_expr< $uid:x1$ . $x2$ >>
      | x1 = idd -> <:module_expr< $uid:x1$ >>
      | x1 = "*" -> <:module_expr< $uid:x1$ >>
      | x1 = "=" -> <:module_expr< $uid:x1$ >> ] ]
  ;
  eqid:
    [ [ x1 = UIDENT; "."; x2 = eqid -> <:expr< $uid:x1$ . $x2$ >>
      | x1 = UIDENT -> <:expr< $uid:x1$ >>
      | x1 = idd -> <:expr< $lid:x1$ >>
      | x1 = "*" -> <:expr< $lid:x1$ >>
      | x1 = "=" -> <:expr< $lid:x1$ >> ] ]
  ;
  sqid:
    [ [ x1 = idd; "."; x2 = sqid -> [x1 :: x2]
      | x1 = idd -> [x1]
      | x1 = "*" -> [x1]
      | x1 = "=" -> [x1] ] ]
  ;
  tycon:
    [ [ LIDENT "real" -> <:ctyp< float >>
      | x1 = idd; "."; x2 = tycon ->
          let r = <:ctyp< $uid:x1$ . $x2$ >> in
          loop r where rec loop =
            fun
            [ <:ctyp< $a$ . ($b$ . $c$) >> -> <:ctyp< $a$ . $b$ . $loop c$ >>
            | x -> x ]
      | x1 = idd -> <:ctyp< $lid:uncap x1$ >> ] ]
  ;
  selector:
    [ [ x1 = id -> x1
      | x1 = INT -> not_impl loc "selector 1" ] ]
  ;
  tlabel:
    [ [ x1 = selector; ":"; x2 = ctyp -> (loc, x1, False, x2) ] ]
  ;
  tuple_ty:
    [ [ x1 = ctyp LEVEL "ty'"; "*"; x2 = tuple_ty -> [x1 :: x2]
      | x1 = ctyp LEVEL "ty'" -> [x1] ] ]
  ;
  ctyp:
    [ RIGHTA
      [ x1 = ctyp; "->"; x2 = ctyp -> <:ctyp< $x1$ -> $x2$ >> ]
    | [ x1 = ctyp; "*"; x2 = tuple_ty -> <:ctyp< ($list:[x1 :: x2]$) >> ]
    | "ty'"
      [ "'"; x1 = LIDENT -> <:ctyp< '$x1$ >>
      | "'"; "'"; x1 = LIDENT -> <:ctyp< '$x1$ >>
      | "{"; x1 = LIST1 tlabel SEP ","; "}" ->
          if ocaml_records.val then <:ctyp< { $list:x1$ } >>
          else
            let list = List.map (fun (_, l, _, t) -> (l, t)) x1 in
            <:ctyp< < $list:list$ > >>
      | "{"; "}" -> not_impl loc "ty' 3"
      | "("; x1 = ctyp; ","; x2 = LIST1 ctyp SEP ","; ")"; x3 = tycon ->
          List.fold_left (fun t1 t2 -> <:ctyp< $t1$ $t2$ >>) x3 [x1 :: x2]
      | "("; x1 = ctyp; ")" -> x1
      | x1 = ctyp; x2 = tycon -> <:ctyp< $x2$ $x1$ >>
      | x1 = tycon -> x1 ] ]
  ;
  rule:
    [ [ x1 = patt; "=>"; x2 = expr -> (x1, None, x2) ] ]
  ;
  elabel:
    [ [ x1 = selector; "="; x2 = expr -> (<:patt< $lid:x1$ >>, x2) ] ]
  ;
  exp_ps:
    [ [ x1 = expr -> x1
      | x1 = expr; ";"; x2 = exp_ps ->
          <:expr< do { $list:[x1 :: get_seq x2]$ } >> ] ]
  ;
  expr:
    [ [ "if"; x1 = expr; "then"; x2 = expr; "else"; x3 = expr ->
          <:expr< if $x1$ then $x2$ else $x3$ >>
      | "fn"; x1 = LIST1 rule SEP "|" -> <:expr< fun [$list:x1$] >>
      | "case"; x1 = expr; "of"; x2 = LIST1 rule SEP "|" ->
          <:expr< match $x1$ with [$list:x2$] >>
      | "while"; x1 = expr; "do"; x2 = expr ->
          <:expr< while $x1$ do { $x2$ } >>
      | x1 = expr; "handle"; x2 = LIST1 rule SEP "|" ->
          <:expr< try $x1$ with [$list:x2$] >> ]
    | RIGHTA
      [ "raise"; x1 = expr -> <:expr< raise $x1$ >> ]
    | [ e1 = expr; ":="; e2 = expr -> <:expr< $e1$.val := $e2$ >> ]
    | LEFTA
      [ x1 = expr; "orelse"; x2 = expr -> <:expr< $x1$ || $x2$ >> ]
    | LEFTA
      [ x1 = expr; "andalso"; x2 = expr -> <:expr< $x1$ && $x2$ >> ]
    | LEFTA
      [ x1 = expr; ":"; x2 = ctyp -> <:expr< ($x1$ : $x2$) >> ]
    | "4" NONA
      [ x1 = expr; "<"; x2 = expr -> <:expr< $x1$ < $x2$ >>
      | x1 = expr; ">"; x2 = expr -> <:expr< $x1$ > $x2$ >>
      | x1 = expr; "<>"; x2 = expr -> <:expr< $x1$ <> $x2$ >>
      | x1 = expr; "="; x2 = expr -> <:expr< $x1$ = $x2$ >>
      | x1 = expr; ">="; x2 = expr -> <:expr< $x1$ >= $x2$ >>
      | x1 = expr; "<="; x2 = expr -> <:expr< $x1$ <= $x2$ >> ]
    | RIGHTA
      [ x1 = expr; "^"; x2 = expr -> <:expr< $x1$ ^ $x2$ >>
      | x1 = expr; "@"; x2 = expr -> <:expr< $x1$ @ $x2$ >>
      | x1 = expr; "o"; x2 = expr -> <:expr< ooo $x1$ $x2$ >> ]
    | "5" RIGHTA
      [ x1 = expr; "::"; x2 = expr -> <:expr< [$x1$ :: $x2$] >> ]
    | "6" LEFTA
      [ x1 = expr; "+"; x2 = expr -> <:expr< $x1$ + $x2$ >>
      | x1 = expr; "-"; x2 = expr -> <:expr< $x1$ - $x2$ >> ]
    | "7" LEFTA
      [ x1 = expr; "*"; x2 = expr -> <:expr< $x1$ * $x2$ >>
      | x1 = expr; "/"; x2 = expr -> <:expr< $x1$ / $x2$ >>
      | x1 = expr; "div"; x2 = expr -> <:expr< $x1$ / $x2$ >>
      | x1 = expr; "mod"; x2 = expr -> <:expr< $x1$ mod $x2$ >> ]
    | LEFTA
      [ x1 = expr; x2 = expr -> <:expr< $x1$ $x2$ >> ]
    | [ "#"; x1 = STRING -> <:expr< $chr:x1$ >>
      | "#"; x1 = selector; x2 = expr ->
          if ocaml_records.val then <:expr< $x2$ . $lid:x1$ >>
          else <:expr< $x2$ # $lid:x1$ >>
      | x1 = expr; "ocaml_record_access"; x2 = expr -> <:expr< $x1$ . $x2$ >> ]
    | [ "!"; x1 = expr -> <:expr< $x1$ . val >>
      | "~"; x1 = expr -> <:expr< - $x1$ >> ]
    | [ x1 = LIDENT ->
          match x1 with
          [ "true" | "false" -> <:expr< $uid:String.capitalize x1$ >>
          | "nil" -> <:expr< [] >>
          | _ -> <:expr< $lid:x1$ >> ]
      | x1 = UIDENT -> <:expr< $uid:x1$ >>
      | x1 = UIDENT; "."; x2 = eqid -> <:expr< $uid:x1$ . $x2$ >>
      | x1 = INT -> <:expr< $int:x1$ >>
      | x1 = FLOAT -> <:expr< $flo:x1$ >>
      | x1 = STRING -> <:expr< $str:x1$ >>
      | "~"; x1 = INT -> <:expr< $int:"-"^x1$ >>
      | i = op ->
          if i = "::" then <:expr< fun (x, y) -> [x :: y] >>
          else <:expr< fun (x, y) -> $lid:i$ x y >>
      | "let"; x1 = ldecs; "in"; x2 = exp_ps; "end" ->
          List.fold_right
            (fun pel x2 ->
               let loc =
                 match pel with
                 [ [(p, _) :: _] ->
                     (fst (MLast.loc_of_patt p), snd (MLast.loc_of_expr x2))
                 | _ -> loc ]
               in
               match pel with
               [ [(_, <:expr< fun [$list:_$] >>) :: _] ->
                   <:expr< let rec $list:pel$ in $x2$ >>
               | _ ->
                   let pel =
                     List.map
                       (fun (p, e) ->
                          match p with
                          [ <:patt< { $list:lpl$ } >> ->
                              record_match_assoc (MLast.loc_of_patt p) lpl e
                          | _ -> (p, e) ])
                       pel
                   in
                   <:expr< let $list:pel$ in $x2$ >> ])
            x1 x2
      | "{"; x1 = LIST1 elabel SEP ","; "}" -> record_expr loc x1
      | "["; "]" -> <:expr< [] >>
      | "["; x1 = expr; "]" -> <:expr< [$x1$] >>
      | "["; x1 = expr; ","; x2 = LIST1 SELF SEP ","; "]" ->
          mklistexp loc None [x1 :: x2]
      | "("; ")" -> <:expr< () >>
      | "("; x1 = expr; ","; x2 = LIST1 SELF SEP ","; ")" ->
          <:expr< ($list:[x1::x2]$) >>
      | "("; x1 = expr; ";"; x2 = LIST1 SELF SEP ";"; ")" ->
          <:expr< do { $list:[x1::x2]$ } >>
      | "("; x1 = expr; ")" -> x1 ] ]
  ;
  fixity:
    [ [ "infix" -> ("infix", None)
      | "infix"; x1 = INT -> not_impl loc "fixity 2"
      | "infixr" -> not_impl loc "fixity 3"
      | "infixr"; x1 = INT -> ("infixr", Some x1)
      | "nonfix" -> not_impl loc "fixity 5" ] ]
  ;
  patt:
    [ [ x1 = patt; "as"; x2 = patt -> <:patt< ($x1$ as $x2$) >> ]
    | LEFTA
      [ x1 = patt; ":"; x2 = ctyp -> <:patt< ($x1$ : $x2$) >> ]
    | RIGHTA
      [ x1 = patt; "::"; x2 = patt -> <:patt< [$x1$ :: $x2$] >> ]
    | [ x1 = patt; x2 = patt ->
          match x1 with
          [ <:patt< ref >> -> <:patt< {contents = $x2$} >>
          | _ -> <:patt< $x1$ $x2$ >> ] ]
    | "apat"
      [ x1 = patt; "."; x2 = patt -> <:patt< $x1$ . $x2$ >>
      | x1 = INT -> <:patt< $int:x1$ >>
      | x1 = UIDENT -> <:patt< $uid:x1$ >>
      | x1 = STRING -> <:patt< $str:x1$ >>
      | "#"; x1 = STRING -> <:patt< $chr:x1$ >>
      | "~"; x1 = INT -> <:patt< $int:"-"^x1$ >>
      | LIDENT "nil" -> <:patt< [] >>
      | LIDENT "false" -> <:patt< False >>
      | LIDENT "true" -> <:patt< True >>
      | x1 = id -> <:patt< $lid:x1$ >>
      | x1 = op -> <:patt< $lid:x1$ >>
      | "_" -> <:patt< _ >>
      | "["; "]" -> <:patt< [] >>
      | "["; x1 = patt; "]" -> <:patt< [$x1$] >>
      | "["; x1 = patt; ","; x2 = LIST1 SELF SEP ","; "]" ->
          mklistpat loc None [x1 :: x2]
      | "{"; x1 = LIST1 plabel SEP ","; "}" -> <:patt< {$list:x1$} >>
      | "("; ")" -> <:patt< () >>
      | "("; x1 = patt; ","; x2 = LIST1 SELF SEP ","; ")" ->
          <:patt< ($list:[x1::x2]$) >>
      | "("; x1 = patt; ")" -> x1 ] ]
  ;
  plabel:
    [ [ x1 = selector; "="; x2 = patt -> (<:patt< $lid:x1$ >>, x2)
      | x1 = selector -> (<:patt< $lid:x1$ >>, <:patt< $lid:x1$ >>) ] ]
  ;
  vb:
    [ [ "lazy"; x1 = patt; "="; x2 = expr -> not_impl loc "vb 1"
      | x1 = patt; "="; x2 = expr -> (x1, x2) ] ]
  ;
  constrain:
    [ [ -> None
      | ":"; x1 = ctyp -> Some x1 ] ]
  ;
  fb:
    [ [ xl = LIST1 clause SEP "|" -> function_of_clause_list loc xl
      | "lazy"; x1 = LIST1 clause SEP "|" -> not_impl loc "fb 2" ] ]
  ;
  clause:
    [ [ x1 = patt LEVEL "apat"; x2 = LIST1 (patt LEVEL "apat");
        x3 = constrain; "="; x4 = expr ->
          let x1 =
            match x1 with
            [ <:patt< $lid:id$ >> -> (id, MLast.loc_of_patt x1)
            | _ -> not_impl loc "clause 1" ]
          in
          (x1, x2, x3, x4) ] ]
  ;
  tb:
    [ [ x1 = tyvars; x2 = idd; "="; x3 = ctyp ->
          ((loc, uncap x2), x1, x3, [])
      | x1 = tyvars; x2 = idd; "="; x3 = ctyp; "=="; x4 = dbrhs ->
          let x4 = List.map (fun (loc, c, tl, _) -> (loc, c, tl)) x4 in
          ((loc, uncap x2), x1, <:ctyp< $x3$ == [ $list:x4$ ] >>, []) ] ]
  ;
  tyvars:
    [ [ "'"; x1 = LIDENT -> [(x1, (False, False))]
      | "("; x1 = tyvar_pc; ")" -> x1
      | -> [] ] ]
  ;
  db1:
    [ [ x1 = tyvars; x2 = ident; "="; x3 = dbrhs ->
          let x2 = uncap x2 in
          extract_label_types loc x2 x1 x3
      | "lazy"; x1 = tyvars; x2 = ident; "="; x3 = dbrhs ->
          not_impl loc "db 2" ] ]
  ;
  db:
    [ [ x1 = LIST1 db1 SEP "and" ->
          List.fold_right (fun td tdl -> td @ tdl) x1 [] ] ]
  ;
  dbrhs:
    [ [ x1 = LIST1 constr SEP "|"  -> x1
      | "datatype"; x1 = tycon -> not_impl loc "dbrhs 2" ] ]
  ;
  constr:
    [ [ x1 = op_op; x2 = ident -> (loc, x2, [], None)
      | x1 = op_op; x2 = ident; "of"; x3 = ctyp ->
          match x3 with
          [ <:ctyp< {$list:_$} >> -> (loc, x2, [], Some x3)
          | _ -> (loc, x2, [x3], None) ] ] ]
  ;
  eb:
    [ [ x1 = op_op; x2 = ident -> (x2, [], [])
      | x1 = op_op; x2 = ident; "of"; x3 = ctyp -> (x2, [x3], [])
      | x1 = op_op; x2 = ident; "="; x3 = sqid -> (x2, [], x3) ] ]
  ;
  ldec1:
    [ [ "val"; x1 = LIST1 vb SEP "and" -> x1
      | "fun"; x1 = LIST1 fb SEP "and" -> x1 ] ]
  ;
  ldecs:
    [ [ -> []
      | x1 = ldec1; x2 = ldecs -> [x1 :: x2]
      | ";"; x1 = ldecs -> x1
      | "local"; x1 = ldecs; "in"; x2 = ldecs; "end"; x3 = ldecs ->
          not_impl loc "ldecs 4" ] ]
  ;
  spec_s:
    [ [ -> []
      | x1 = spec; x2 = spec_s -> [x1 :: x2]
      | ";"; x1 = spec_s -> x1 ] ]
  ;
  spec:
   [ [ "structure"; x1 = LIST1 strspec SEP "and" -> sig_declare loc x1
     | "functor"; x1 = LIST1 fctspec SEP "and" -> sig_declare loc x1
     | "datatype"; x1 = db -> <:sig_item< type $list:x1$ >>
     | "type"; x1 = LIST1 tyspec SEP "and" -> <:sig_item< type $list:x1$ >>
     | "eqtype"; x1 = LIST1 tyspec SEP "and" -> <:sig_item< type $list:x1$ >>
     | "val"; x1 = LIST1 valspec SEP "and" -> sig_declare loc x1
     | "exception"; x1 = LIST1 exnspec SEP "and" -> sig_declare loc x1
     | "sharing"; x1 = LIST1 sharespec SEP "and" -> <:sig_item< declare end >>
     | "include"; x1 = module_type -> <:sig_item< include $x1$ >> ] ]
  ;
  sig_item:
    [ [ x = spec -> x ] ]
  ;
  strspec:
    [ [ x1 = ident; ":"; x2 = module_type; x3 = LIST0 sharing_def ->
          let x2 =
            List.fold_left
              (fun mt sdl ->
                 List.fold_right
                   (fun spl mt ->
                      match spl with
                      [ Right ([m1], m2) ->
                          let (m1, m2) =
                            match m2 with
                            [ <:module_expr< $uid:x$ . $_$ >> ->
                                if x = x1 then (m2, m1) else (m1, m2)
                            | _ -> (m1, m2) ]
                          in
                          let m1 =
                            loop m1 where rec loop =
                              fun
                              [ <:module_expr< $uid:x$ >> -> x
                              | <:module_expr< $uid:x$ . $y$ >> -> loop y
                              | _ -> not_impl loc "strspec 2" ]
                          in
                          <:module_type< $mt$ with module $[m1]$ = $m2$ >>
                      | _ -> not_impl loc "strspec 1" ])
                   sdl mt)
              x2 x3
          in
          <:sig_item< module $x1$ : $x2$ >> ] ]
  ;
  sharing_def:
    [ [ "sharing"; x3 = LIST1 sharespec SEP "and" -> x3 ] ]
  ;
  fctspec:
    [ [ x1 = ident; x2 = fsig -> <:sig_item< module $x1$ : $x2$ >> ] ]
  ;
  tyspec:
    [ [ x1 = tyvars; x2 = idd ->
          ((loc, uncap x2), x1, <:ctyp< '$choose_tvar x1$ >>, [])
      | x1 = tyvars; x2 = idd; "="; x3 = ctyp ->
          ((loc, uncap x2), x1, x3, []) ] ]
  ;
  valspec:
    [ [ x1 = op_op; x2 = ident; ":"; x3 = ctyp ->
          <:sig_item< value $x2$ : $x3$ >> ] ]
  ;
  exnspec:
    [ [ x1 = ident -> <:sig_item< exception $x1$ >>
      | x1 = ident; "of"; x2 = ctyp ->
          <:sig_item< exception $x1$ of $x2$ >> ] ]
  ;
  sharespec:
    [ [ "type"; x1 = patheqn -> Left x1
      | x1 = patheqn -> Right x1 ] ]
  ;
  patheqn:
    [ [ l = patheqn1 -> l ] ]
  ;
  patheqn1:
    [ [ (l, y) = patheqn1; "="; x = qid -> ([y :: l], x)
      | x = qid -> ([], x) ] ]
  ;
  whspec:
    [ [ "type"; x1 = tyvars; x2 = sqid; "="; x3 = ctyp ->
          MLast.WcTyp loc x2 x1 x3
      | x1 = sqid; "="; x2 = qid -> MLast.WcMod loc x1 x2 ] ]
  ;
  module_type:
    [ [ x1 = ident -> <:module_type< $uid:x1$ >>
      | "sig"; x1 = spec_s; "end" -> <:module_type< sig $list:x1$ end >>
      | x1 = module_type; "where"; x2 = LIST1 whspec SEP "and" ->
          <:module_type< $x1$ with $list:x2$ >> ] ]
  ;
  sigconstraint_op:
    [ [ -> None
      | ":"; x1 = module_type -> Some x1
      | ":>"; x1 = module_type -> not_impl loc "sigconstraint_op 3" ] ]
  ;
  sigb:
    [ [ x1 = ident; "="; x2 = module_type ->
          <:str_item< module type $x1$ = $x2$ >> ] ]
  ;
  fsig:
    [ [ ":"; x1 = ident -> not_impl loc "fsig 1"
      | x1 = fparamList; ":"; x2 = module_type -> not_impl loc "fsig 2" ] ]
  ;
  module_expr:
    [ [ x1 = qid -> x1
      | "struct"; x1 = strdecs; "end" -> <:module_expr< struct $list:x1$ end >>
      | x1 = qid; x2 = arg_fct ->
          match x2 with
          [ Left [] -> x1
          | Left x2 -> <:module_expr< $x1$ (struct $list:x2$ end) >>
          | Right x2 -> <:module_expr< $x1$ $x2$ >> ]
      | "let"; x1 = strdecs; "in"; x2 = module_expr; "end" ->
          not_impl loc "str 4"
      | x1 = module_expr; ":"; x2 = module_type -> not_impl loc "str 5"
      | x1 = module_expr; x2 = ":>"; x3 = module_type ->
          not_impl loc "str 6" ] ]
  ;
  arg_fct:
    [ [ "("; x1 = strdecs; ")"; x2 = arg_fct -> not_impl loc "arg_fct 1"
      | "("; x1 = module_expr; ")"; x2 = arg_fct -> not_impl loc "arg_fct 2"
      | "("; x1 = module_expr; ")" -> Right x1
      | "("; x2 = strdecs; ")" -> Left x2 ] ]
  ;
  strdecs:
    [ [ x1 = str_item LEVEL "strdec"; x2 = strdecs -> [x1 :: x2]
      | ";"; x1 = strdecs -> x1
      | -> [] ] ]
  ;
  str_item:
    [ [ "signature"; x1 = LIST1 sigb SEP "and" -> str_declare loc x1
      | "funsig"; x1 = fsigb -> not_impl loc "sdec 3" ]
    | "strdec"
      [ "structure"; x1 = LIST1 strb SEP "and" -> str_declare loc x1
      | "functor"; x1 = LIST1 fctb SEP "and" -> str_declare loc x1
      | "local"; x1 = sdecs; "in"; x2 = sdecs; "end" ->
          make_local loc x1 x2 ]
    | [ "val"; x1 = LIST1 vb SEP "and" -> <:str_item< value $list:x1$ >>
      | "val"; x1 = tyvarseq; x3 = LIST1 vb SEP "and" ->
          not_impl loc "ldec 2"
      | "val"; "rec"; x1 = rvb -> not_impl loc "ldec 3"
      | "val"; "rec"; x1 = tyvarseq; x2 = rvb -> not_impl loc "ldec 4"
      | "fun"; x1 = LIST1 fb SEP "and" -> <:str_item< value rec $list:x1$ >>
      | "fun"; x1 = tyvarseq; x2 = fb -> not_impl loc "ldec 6"
      | "type"; x1 = LIST1 tb SEP "and" -> <:str_item< type $list:x1$ >>
      | "datatype"; x1 = db -> <:str_item< type $list:x1$ >>
      | "datatype"; x1 = db; "withtype"; x2 = tb ->
          <:str_item< type $list:x1 @ [x2]$ >>
      | "abstype"; x1 = db; "with"; x2 = ldecs; "end" -> not_impl loc "ldec 10"
      | "abstype"; x1 = db; "withtype"; x2 = tb; "with"; x3 = ldecs; "end" ->
          not_impl loc "ldec 11"
      | "exception"; x1 = LIST1 eb SEP "and" ->
          let dl =
            List.map
              (fun (s, tl, eqn) ->
                 <:str_item< exception $s$ of $list:tl$ = $eqn$ >>)
              x1
          in
          str_declare loc dl
      | "open"; x1 = LIST1 sqid ->
          let dl = List.map (fun sl -> <:str_item< open $sl$ >>) x1 in
          str_declare loc dl
      | LIDENT "use"; s = STRING ->
          <:str_item< #use $str:s$ >>
      | x1 = fixity; list = LIST1 idd ->
          match x1 with
          [ ("infixr", Some n) ->
              do {
                List.iter
                  (fun s ->
                     EXTEND
                       expr: LEVEL $n$
                         [ [ x1 = expr; $s$; x2 = expr ->
                               <:expr< $lid:s$ ($x1$, $x2$) >> ] ]
                       ;
                     END)
                  list;
                  str_declare loc []
              }
          | ("infix", None) ->
              do {
                List.iter
                  (fun s ->
                     EXTEND
                       expr: LEVEL "4"
                         [ [ x1 = expr; $s$; x2 = expr ->
                               <:expr< $lid:s$ ($x1$, $x2$) >> ] ]
                       ;
                       clause:
                         [ [ x1 = patt LEVEL "apat"; $s$;
                             x2 = patt LEVEL "apat"; "="; x4 = expr ->
                               ((s, loc), [<:patt< ($x1$, $x2$) >>],
                                None, x4) ] ]
                       ;
                     END)
                  list;
                  str_declare loc []
              }
          | _ -> not_impl loc "ldec 14" ]
      | "overload"; x1 = ident; ":"; x2 = ctyp; "as"; x3 = exp_pa ->
          not_impl loc "ldec 15"
      | x = expr -> <:str_item< $exp:x$ >> ] ]
  ;
  sdec:
    [ [ x = str_item -> x ] ]
  ;
  strb:
    [ [ x1 = ident; x2 = sigconstraint_op; "="; x3 = module_expr ->
          let x3 =
            match x2 with
            [ Some x2 -> <:module_expr< ($x3$ : $x2$) >>
            | None -> x3 ]
          in
          <:str_item< module $x1$ = $x3$ >> ] ]
  ;
  fparam:
    [ [ x1 = idd; ":"; x2 = module_type -> [<:sig_item< module $x1$ : $x2$ >>]
      | x1 = spec_s -> x1 ] ]
  ;
  fparamList:
    [ [ "("; x1 = fparam; ")" -> [x1]
      | "("; x1 = fparam; ")"; x2 = fparamList -> [x1 :: x2] ] ]
  ;
  fctb:
    [ [ x1 = ident; x2 = fparamList; x3 = sigconstraint_op; "=";
        x4 = module_expr ->
          let list = List.flatten x2 in
          let x4 =
            if list = [] then x4
            else
              match x4 with
              [ <:module_expr< struct $list:list$ end >> ->
                  let si =
                    let loc = (Token.nowhere, Token.nowhere) in
                    <:str_item< open AAA >> in
                  <:module_expr< struct $list:[si :: list]$ end >>
              | _ -> not_impl loc "fctb 1" ]
          in
          let x4 =
            match x3 with
            [ Some x3 -> <:module_expr< ($x4$ : $x3$) >>
            | None -> x4 ]
          in
          let x4 =
            if list = [] then x4
            else
              let mt =
                let loc =
                  (fst (MLast.loc_of_sig_item (List.hd list)),
                   snd (MLast.loc_of_sig_item (List.hd (List.rev list))))
                in
                <:module_type< sig $list:list$ end >>
              in
              <:module_expr< functor (AAA : $mt$) -> $x4$ >>
          in
          <:str_item< module $x1$ = $x4$ >>
      | x1 = ident; x2 = fsigconstraint_op; "="; x3 = fct_exp ->
          not_impl loc "fctb 2" ] ]
  ;
  interdec:
    [ [ x = LIST1 [ s = str_item; OPT ";" -> (s, loc) ] -> (x, False)
      | x = expr; OPT ";" -> not_impl loc "interdec 2" ] ]
  ;
END;

Pcaml.add_option "-records" (Arg.Set ocaml_records)
  "Convert record into OCaml records, instead of objects";