(* camlp4r *)
(****************************************************************************)
(*                                                                          *)
(*                              Objective Caml                              *)
(*                                                                          *)
(*                            INRIA Rocquencourt                            *)
(*                                                                          *)
(*  Copyright 2002-2006 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 LICENSE at the top of the Objective   *)
(*  Caml source tree.                                                       *)
(*                                                                          *)
(****************************************************************************)

(* Authors:
 * - Daniel de Rauglaudre: initial version
 * - Nicolas Pouillard: refactoring
 *)

(* $Id$ *)

module Make (Ast : Sig.Camlp4Ast.S) = struct
  open Format;
  open Parsetree;
  open Longident;
  open Asttypes;
  open Ast;

  value constructors_arity () =
    debug ast2pt "constructors_arity: %b@." Config.constructors_arity.val in
    Config.constructors_arity.val;

  value error loc str = Loc.raise loc (Failure str);

  value char_of_char_token loc s =
    try Token.Eval.char s with [ Failure _ as exn -> Loc.raise loc exn ]
  ;

  value string_of_string_token loc s =
    try Token.Eval.string s
    with [ Failure _ as exn -> Loc.raise loc exn ]
  ;

  value mkloc = Loc.to_ocaml_location;
  value mkghloc loc = Loc.to_ocaml_location (Loc.ghostify loc);

  value mktyp loc d = {ptyp_desc = d; ptyp_loc = mkloc loc};
  value mkpat loc d = {ppat_desc = d; ppat_loc = mkloc loc};
  value mkghpat loc d = {ppat_desc = d; ppat_loc = mkghloc loc};
  value mkexp loc d = {pexp_desc = d; pexp_loc = mkloc loc};
  value mkmty loc d = {pmty_desc = d; pmty_loc = mkloc loc};
  value mksig loc d = {psig_desc = d; psig_loc = mkloc loc};
  value mkmod loc d = {pmod_desc = d; pmod_loc = mkloc loc};
  value mkstr loc d = {pstr_desc = d; pstr_loc = mkloc loc};
  value mkfield loc d = {pfield_desc = d; pfield_loc = mkloc loc};
  value mkcty loc d = {pcty_desc = d; pcty_loc = mkloc loc};
  value mkpcl loc d = {pcl_desc = d; pcl_loc = mkloc loc};
  value mkpolytype t =
    match t.ptyp_desc with
    [ Ptyp_poly _ _ -> t
    | _ -> { (t) with ptyp_desc = Ptyp_poly [] t } ]
  ;

  value mb2b =
    fun
    [ Ast.BTrue -> True
    | Ast.BFalse -> False
    | Ast.BAnt _ -> assert False ];

  value mkvirtual m = if mb2b m then Virtual else Concrete;

  value lident s = Lident s;
  value ldot l s = Ldot l s;
  value lapply l s = Lapply l s;

  value conv_con =
    let t = Hashtbl.create 73 in
    do {
      List.iter (fun (s, s') -> Hashtbl.add t s s')
        [("True", "true"); ("False", "false"); (" True", "True");
        (" False", "False")];
      fun s -> try Hashtbl.find t s with [ Not_found -> s ]
    }
  ;

  value conv_lab =
    let t = Hashtbl.create 73 in
    do {
      List.iter (fun (s, s') -> Hashtbl.add t s s') [("val", "contents")];
      fun s -> try Hashtbl.find t s with [ Not_found -> s ]
    }
  ;

  value array_function str name =
    ldot (lident str) (if Config.unsafe.val then "unsafe_" ^ name else name)
  ;

  value mkrf =
    fun
    [ Ast.BTrue -> Recursive
    | Ast.BFalse -> Nonrecursive
    | Ast.BAnt _ -> assert False ];

  value mkli s =
    loop (fun s -> lident s) where rec loop f =
      fun
      [ [i :: il] -> loop (fun s -> ldot (f i) s) il
      | [] -> f s ]
  ;

  value rec ctyp_fa al =
    fun
    [ TyApp _ f a -> ctyp_fa [a :: al] f
    | f -> (f, al) ]
  ;

  value ident_tag ?(conv_lid = fun x -> x) i =

    let rec self i acc =
      match i with
      [ <:ident< $i1$.$i2$ >> ->
          self i2 (Some (self i1 acc))
      | <:ident< $i1$ $i2$ >> ->
          let i' = Lapply (fst (self i1 None)) (fst (self i2 None)) in
          let x =
            match acc with
            [ None -> i'
            | _ -> error (loc_of_ident i) "invalid long identifier" ]
          in (x, `app)
      | <:ident< $uid:s$ >> ->
          let x =
            match acc with
            [ None -> lident s
            | Some (acc, `uident | `app) -> ldot acc s
            | _ -> error (loc_of_ident i) "invalid long identifier" ]
          in (x, `uident)
      | <:ident< $lid:s$ >> ->
          let x =
            match acc with
            [ None -> lident (conv_lid s)
            | Some (acc, `uident | `app) -> ldot acc (conv_lid s)
            | _ -> error (loc_of_ident i) "invalid long identifier" ]
          in (x, `lident)
      | _ -> error (loc_of_ident i) "invalid long identifier" ]
    in self i None;

  value ident ?conv_lid i = fst (ident_tag ?conv_lid i);

  value long_lident msg i =
    match ident_tag i with
    [ (i, `lident) -> i
    | _ -> error (loc_of_ident i) msg ]
  ;

  value long_type_ident = long_lident "invalid long identifier type";
  value long_class_ident = long_lident "invalid class name";

  value long_uident ?(conv_con = fun x -> x) i =
    match ident_tag i with
    [ (Ldot i s, `uident) -> ldot i (conv_con s)
    | (Lident s, `uident) -> lident (conv_con s)
    | (i, `app) -> i
    | _ -> error (loc_of_ident i) "uppercase identifier expected" ]
  ;

  value rec ctyp_long_id_prefix t =
    match t with
    [ <:ctyp< $id:i$ >> -> ident i
    | <:ctyp< $m1$ $m2$ >> ->
        let li1 = ctyp_long_id_prefix m1 in
        let li2 = ctyp_long_id_prefix m2 in
        Lapply li1 li2
    | t -> error (loc_of_ctyp t) "invalid module expression" ]
  ;

  value ctyp_long_id t =
    match t with
    [ <:ctyp< $id:i$ >> ->
        (False, long_type_ident i)
    | TyApp loc _ _ ->
        error loc "invalid type name"
    | TyCls _ i -> (True, ident i)
    | t -> error (loc_of_ctyp t) "invalid type" ]
  ;

  value rec ty_var_list_of_ctyp =
    fun
    [ <:ctyp< $t1$ $t2$ >> -> ty_var_list_of_ctyp t1 @ ty_var_list_of_ctyp t2
    | <:ctyp< '$s$ >> -> [s] 
    | _ -> assert False ];

  value rec ctyp =
    fun
    [ TyId loc i ->
        let li = long_type_ident i in
        mktyp loc (Ptyp_constr li [])
    | TyAli loc t1 t2 ->
        let (t, i) =
          match (t1, t2) with
          [ (t, TyQuo _ s) -> (t, s)
          | (TyQuo _ s, t) -> (t, s)
          | _ -> error loc "invalid alias type" ]
        in
        mktyp loc (Ptyp_alias (ctyp t) i)
    | TyAny loc -> mktyp loc Ptyp_any
    | TyApp loc _ _ as f ->
        let (f, al) = ctyp_fa [] f in
        let (is_cls, li) = ctyp_long_id f in
        if is_cls then mktyp loc (Ptyp_class li (List.map ctyp al) [])
        else mktyp loc (Ptyp_constr li (List.map ctyp al))
    | TyArr loc (TyLab _ lab t1) t2 ->
        mktyp loc (Ptyp_arrow lab (ctyp t1) (ctyp t2))
    | TyArr loc (TyOlb loc1 lab t1) t2 ->
        let t1 = TyApp loc1 <:ctyp@loc1< option >> t1 in
        mktyp loc (Ptyp_arrow ("?" ^ lab) (ctyp t1) (ctyp t2))
    | TyArr loc t1 t2 -> mktyp loc (Ptyp_arrow "" (ctyp t1) (ctyp t2))
    | <:ctyp@loc< <  > >> -> mktyp loc (Ptyp_object [])
    | <:ctyp@loc< < .. > >> -> mktyp loc (Ptyp_object [mkfield loc Pfield_var])
    | <:ctyp@loc< < $fl$ > >> -> mktyp loc (Ptyp_object (meth_list fl []))
    | <:ctyp@loc< < $fl$ .. > >> ->
        mktyp loc (Ptyp_object (meth_list fl [mkfield loc Pfield_var]))
    | TyCls loc id ->
        mktyp loc (Ptyp_class (ident id) [] [])
    | TyLab loc _ _ -> error loc "labelled type not allowed here"
    | TyMan loc _ _ -> error loc "manifest type not allowed here"
    | TyOlb loc _ _ -> error loc "labelled type not allowed here"
    | TyPol loc t1 t2 -> mktyp loc (Ptyp_poly (ty_var_list_of_ctyp t1) (ctyp t2))
    | TyQuo loc s -> mktyp loc (Ptyp_var s)
    | TyRec loc _ -> error loc "record type not allowed here"
    | TySum loc _ -> error loc "sum type not allowed here"
    | TyPrv loc _ -> error loc "private type not allowed here"
    | TyMut loc _ -> error loc "mutable type not allowed here"
    | TyOr loc _ _ -> error loc "type1 | type2 not allowed here"
    | TyAnd loc _ _ -> error loc "type1 and type2 not allowed here"
    | TyOf loc _ _ -> error loc "type1 of type2 not allowed here"
    | TyCol loc _ _ -> error loc "type1 : type2 not allowed here"
    | TySem loc _ _ -> error loc "type1 ; type2 not allowed here"
    | <:ctyp@loc< ($t1$ * $t2$) >> ->
         mktyp loc (Ptyp_tuple (List.map ctyp (list_of_ctyp t1 (list_of_ctyp t2 []))))
    | <:ctyp@loc< [ = $t$ ] >> -> mktyp loc (Ptyp_variant (row_field t) True None)
    | <:ctyp@loc< [ > $t$ ] >> -> mktyp loc (Ptyp_variant (row_field t) False None)
    | <:ctyp@loc< [ < $t$ ] >> -> mktyp loc (Ptyp_variant (row_field t) True (Some []))
    | <:ctyp@loc< [ < $t$ > $t'$ ] >> ->
        mktyp loc (Ptyp_variant (row_field t) True (Some (name_tags t')))
    | TyAnt loc _ -> error loc "antiquotation not allowed here"
    | TyOfAmp _ _ _ |TyAmp _ _ _ |TySta _ _ _ |
      TyCom _ _ _ |TyVrn _ _ |TyQuM _ _ |TyQuP _ _ |TyDcl _ _ _ _ _ |
      TyObj _ _ (BAnt _) | TyNil _ | TyTup _ _ ->
        assert False ]
  and row_field = fun
    [ <:ctyp< `$i$ >> -> [Rtag i True []]
    | <:ctyp< `$i$ of & $t$ >> -> [Rtag i True (List.map ctyp (list_of_ctyp t []))]
    | <:ctyp< `$i$ of $t$ >> -> [Rtag i False (List.map ctyp (list_of_ctyp t []))]
    | <:ctyp< $t1$ | $t2$ >> -> row_field t1 @ row_field t2
    | t -> [Rinherit (ctyp t)] ]
  and name_tags = fun
    [ <:ctyp< $t1$ $t2$ >> -> name_tags t1 @ name_tags t2
    | <:ctyp< `$s$ >> -> [s]
    | _ -> assert False ]
  and meth_list fl acc =
    match fl with
    [ <:ctyp< $t1$; $t2$ >> -> meth_list t1 (meth_list t2 acc)
    | <:ctyp@loc< $lid:lab$ : $t$ >> ->
        [mkfield loc (Pfield lab (mkpolytype (ctyp t))) :: acc]
    | _ -> assert False ]
  ;

  value mktype loc tl cl tk tm =
    let (params, variance) = List.split tl in
    {ptype_params = params; ptype_cstrs = cl; ptype_kind = tk;
    ptype_manifest = tm; ptype_loc = mkloc loc; ptype_variance = variance}
  ;
  value mkprivate' m = if m then Private else Public;
  value mkprivate m = mkprivate' (mb2b m);
  value mktrecord =
    fun
    [ <:ctyp@loc< $lid:s$ : mutable $t$ >> ->
        (s, Mutable, mkpolytype (ctyp t), mkloc loc)
    | <:ctyp@loc< $lid:s$ : $t$ >> ->
        (s, Immutable, mkpolytype (ctyp t), mkloc loc)
    | _ -> assert False (*FIXME*) ];
  value mkvariant =
    fun
    [ <:ctyp@loc< $uid:s$ >> -> (s, [], mkloc loc)
    | <:ctyp@loc< $uid:s$ of $t$ >> ->
        (s, List.map ctyp (list_of_ctyp t []), mkloc loc)
    | _ -> assert False (*FIXME*) ];
  value rec type_decl tl cl loc m pflag =
    fun
    [ TyMan _ t1 t2 ->
        type_decl tl cl loc (Some (ctyp t1)) pflag t2
    | TyPrv _ t ->
        type_decl tl cl loc m True t
    | TyRec _ t ->
        mktype loc tl cl
          (Ptype_record (List.map mktrecord (list_of_ctyp t [])) (mkprivate' pflag)) m
    | TySum _ t ->
        mktype loc tl cl
          (Ptype_variant (List.map mkvariant (list_of_ctyp t [])) (mkprivate' pflag)) m
    | t ->
        if m <> None then
          error loc "only one manifest type allowed by definition" else
        let m =
          match t with
          [ TyQuo _ s -> if List.mem_assoc s tl then Some (ctyp t) else None
          | _ -> Some (ctyp t) ]
        in
        let k = if pflag then Ptype_private else Ptype_abstract in
        mktype loc tl cl k m ]
  ;

  value type_decl tl cl t = type_decl tl cl (loc_of_ctyp t) None False t;

  value mkvalue_desc t p = {pval_type = ctyp t; pval_prim = p};

  value mkmutable m = if mb2b m then Mutable else Immutable;

  value paolab lab p =
    match (lab, p) with
    [ ("", <:patt< $lid:i$ >> | <:patt< ($lid:i$ : $_$) >>) -> i
    | ("", p) -> error (loc_of_patt p) "bad ast in label"
    | _ -> lab ]
  ;

  value rec type_parameters t acc =
    match t with
    [ <:ctyp< $t1$ $t2$ >> -> type_parameters t1 (type_parameters t2 acc)
    | <:ctyp< +'$s$ >> -> [(s, (True, False)) :: acc]
    | <:ctyp< -'$s$ >> -> [(s, (False, True)) :: acc]
    | <:ctyp< '$s$ >> -> [(s, (False, False)) :: acc]
    | _ -> assert False ];

  value rec type_parameters_and_type_name t acc =
    match t with
    [ <:ctyp< $t1$ $t2$ >> ->
        type_parameters_and_type_name t1
          (type_parameters t2 acc)
    | <:ctyp< $id:i$ >> -> (ident i, acc)
    | _ -> assert False ];

  value rec mkwithc wc acc =
    match wc with
    [ WcNil _ -> acc
    | WcTyp loc id_tpl ct ->
        let (id, tpl) = type_parameters_and_type_name id_tpl [] in
        let (params, variance) = List.split tpl in
        [(id,
        Pwith_type
          {ptype_params = params; ptype_cstrs = [];
            ptype_kind = Ptype_abstract; ptype_manifest = Some (ctyp ct);
            ptype_loc = mkloc loc; ptype_variance = variance}) :: acc]
    | WcMod _ i1 i2 ->
        [(long_uident i1, Pwith_module (long_uident i2)) :: acc]
    | <:with_constr< $wc1$ and $wc2$ >> -> mkwithc wc1 (mkwithc wc2 acc)
    | <:with_constr@loc< $anti:_$ >> ->
         error loc "bad with constraint (antiquotation)" ];

  value rec patt_fa al =
    fun
    [ PaApp _ f a -> patt_fa [a :: al] f
    | f -> (f, al) ]
  ;

  value rec deep_mkrangepat loc c1 c2 =
    if c1 = c2 then mkghpat loc (Ppat_constant (Const_char c1))
    else
      mkghpat loc
        (Ppat_or (mkghpat loc (Ppat_constant (Const_char c1)))
          (deep_mkrangepat loc (Char.chr (Char.code c1 + 1)) c2))
  ;

  value rec mkrangepat loc c1 c2 =
    if c1 > c2 then mkrangepat loc c2 c1
    else if c1 = c2 then mkpat loc (Ppat_constant (Const_char c1))
    else
      mkpat loc
        (Ppat_or (mkghpat loc (Ppat_constant (Const_char c1)))
          (deep_mkrangepat loc (Char.chr (Char.code c1 + 1)) c2))
  ;

  value rec patt =
    fun
    [ <:patt@loc< $lid:s$ >> -> mkpat loc (Ppat_var s)
    | <:patt@loc< $id:i$ >> ->
        let p = Ppat_construct (long_uident ~conv_con i)
                  None (constructors_arity ())
        in mkpat loc p
    | PaAli loc p1 p2 ->
        let (p, i) =
          match (p1, p2) with
          [ (p, <:patt< $lid:s$ >>) -> (p, s)
          | (<:patt< $lid:s$ >>, p) -> (p, s)
          | _ -> error loc "invalid alias pattern" ]
        in
        mkpat loc (Ppat_alias (patt p) i)
    | PaAnt loc _ -> error loc "antiquotation not allowed here"
    | PaAny loc -> mkpat loc Ppat_any
    | <:patt@loc< $uid:s$ ($tup:<:patt@loc_any< _ >>$) >> ->
        mkpat loc (Ppat_construct (lident (conv_con s))
              (Some (mkpat loc_any Ppat_any)) False)
    | PaApp loc _ _ as f ->
        let (f, al) = patt_fa [] f in
        let al = List.map patt al in
        match (patt f).ppat_desc with
        [ Ppat_construct li None _ ->
            if constructors_arity () then
              mkpat loc (Ppat_construct li (Some (mkpat loc (Ppat_tuple al))) True)
            else
              let a =
                match al with
                [ [a] -> a
                | _ -> mkpat loc (Ppat_tuple al) ]
              in
              mkpat loc (Ppat_construct li (Some a) False)
        | Ppat_variant s None ->
            let a =
              if constructors_arity () then
                mkpat loc (Ppat_tuple al)
              else
                match al with
                [ [a] -> a
                | _ -> mkpat loc (Ppat_tuple al) ]
            in mkpat loc (Ppat_variant s (Some a))
        | _ ->
            error (loc_of_patt f)
              "this is not a constructor, it cannot be applied in a pattern" ]
    | PaArr loc p -> mkpat loc (Ppat_array (List.map patt (list_of_patt p [])))
    | PaChr loc s ->
        mkpat loc (Ppat_constant (Const_char (char_of_char_token loc s)))
    | PaInt loc s ->
        let i = try int_of_string s with [
          Failure _ -> error loc "Integer literal exceeds the range of representable integers of type int"
        ] in mkpat loc (Ppat_constant (Const_int i))
    | PaInt32 loc s ->
        let i32 = try Int32.of_string s with [
          Failure _ -> error loc "Integer literal exceeds the range of representable integers of type int32"
        ] in mkpat loc (Ppat_constant (Const_int32 i32))
    | PaInt64 loc s ->
        let i64 = try Int64.of_string s with [
          Failure _ -> error loc "Integer literal exceeds the range of representable integers of type int64"
        ] in mkpat loc (Ppat_constant (Const_int64 i64))
    | PaNativeInt loc s ->
        let nati = try Nativeint.of_string s with [
          Failure _ -> error loc "Integer literal exceeds the range of representable integers of type nativeint"
        ] in mkpat loc (Ppat_constant (Const_nativeint nati))
    | PaFlo loc s -> mkpat loc (Ppat_constant (Const_float s))
    | PaLab loc _ _ -> error loc "labeled pattern not allowed here"
    | PaOlb loc _ _ | PaOlbi loc _ _ _ -> error loc "labeled pattern not allowed here"
    | PaOrp loc p1 p2 -> mkpat loc (Ppat_or (patt p1) (patt p2))
    | PaRng loc p1 p2 ->
        match (p1, p2) with
        [ (PaChr loc1 c1, PaChr loc2 c2) ->
            let c1 = char_of_char_token loc1 c1 in
            let c2 = char_of_char_token loc2 c2 in
            mkrangepat loc c1 c2
        | _ -> error loc "range pattern allowed only for characters" ]
    | PaRec loc p ->
        mkpat loc (Ppat_record (List.map mklabpat (list_of_patt p [])))
    | PaStr loc s ->
        mkpat loc (Ppat_constant (Const_string (string_of_string_token loc s)))
    | <:patt@loc< ($p1$, $p2$) >> ->
         mkpat loc (Ppat_tuple
           (List.map patt (list_of_patt p1 (list_of_patt p2 [])))) 
    | <:patt@loc< ($tup:_$) >> -> error loc "singleton tuple pattern"
    | PaTyc loc p t -> mkpat loc (Ppat_constraint (patt p) (ctyp t))
    | PaTyp loc i -> mkpat loc (Ppat_type (long_type_ident i))
    | PaVrn loc s -> mkpat loc (Ppat_variant s None)
    | PaEq _ _ _ | PaSem _ _ _ | PaCom _ _ _ | PaNil _ as p ->
        error (loc_of_patt p) "invalid pattern" ]
  and mklabpat =
    fun
    [ <:patt< $id:i$ = $p$ >> -> (ident ~conv_lid:conv_lab i, patt p)
    | p -> error (loc_of_patt p) "invalid pattern" ];

  value rec expr_fa al =
    fun
    [ ExApp _ f a -> expr_fa [a :: al] f
    | f -> (f, al) ]
  ;

  value rec class_expr_fa al =
    fun
    [ CeApp _ ce a -> class_expr_fa [a :: al] ce
    | ce -> (ce, al) ]
  ;


  value rec sep_expr_acc l =
    fun
    [ ExAcc _ e1 e2 -> sep_expr_acc (sep_expr_acc l e2) e1
    | <:expr@loc< $uid:s$ >> as e ->
        match l with
        [ [] -> [(loc, [], e)]
        | [(loc', sl, e) :: l] -> [(Loc.merge loc loc', [s :: sl], e) :: l] ]
    | <:expr< $id:(<:ident< $_$.$_$ >> as i)$ >> ->
        let rec normalize_acc =
          fun
          [ <:ident@_loc< $i1$.$i2$ >> ->
            <:expr< $normalize_acc i1$.$normalize_acc i2$ >>
          | <:ident@_loc< $i1$ $i2$ >> ->
            <:expr< $normalize_acc i1$ $normalize_acc i2$ >>
          | <:ident@_loc< $anti:_$ >> | <:ident@_loc< $uid:_$ >> |
            <:ident@_loc< $lid:_$ >> as i -> <:expr< $id:i$ >> ]
        in sep_expr_acc l (normalize_acc i)
    | e -> [(loc_of_expr e, [], e) :: l] ]
  ;

  value list_of_opt_ctyp ot acc =
    match ot with
    [ <:ctyp<>> -> acc
    | t -> list_of_ctyp t acc ];

  value rec expr =
    fun
    [ <:expr@loc< $x$.val >> ->
        mkexp loc
          (Pexp_apply (mkexp loc (Pexp_ident (Lident "!"))) [("", expr x)])
    | ExAcc loc _ _ | <:expr@loc< $id:<:ident< $_$ . $_$ >>$ >> as e ->
        let (e, l) =
          match sep_expr_acc [] e with
          [ [(loc, ml, <:expr< $uid:s$ >>) :: l] ->
              let ca = constructors_arity () in
              (mkexp loc (Pexp_construct (mkli s ml) None ca), l)
          | [(loc, ml, <:expr< $lid:s$ >>) :: l] ->
              (mkexp loc (Pexp_ident (mkli s ml)), l)
          | [(_, [], e) :: l] -> (expr e, l)
          | _ -> error loc "bad ast in expression" ]
        in
        let (_, e) =
          List.fold_left
            (fun (loc_bp, e1) (loc_ep, ml, e2) ->
              match e2 with
              [ <:expr< $lid:s$ >> ->
                  let loc = Loc.merge loc_bp loc_ep
                  in  (loc, mkexp loc (Pexp_field e1 (mkli (conv_lab s) ml)))
              | _ -> error (loc_of_expr e2) "lowercase identifier expected" ])
            (loc, e) l
        in
        e
    | ExAnt loc _ -> error loc "antiquotation not allowed here"
    | ExApp loc _ _ as f ->
        let (f, al) = expr_fa [] f in
        let al = List.map label_expr al in
        match (expr f).pexp_desc with
        [ Pexp_construct li None _ ->
            let al = List.map snd al in
            if constructors_arity () then
              mkexp loc (Pexp_construct li (Some (mkexp loc (Pexp_tuple al))) True)
            else
              let a =
                match al with
                [ [a] -> a
                | _ -> mkexp loc (Pexp_tuple al) ]
              in
              mkexp loc (Pexp_construct li (Some a) False)
        | Pexp_variant s None ->
            let al = List.map snd al in
            let a =
              if constructors_arity () then
                mkexp loc (Pexp_tuple al)
              else
                match al with
                [ [a] -> a
                | _ -> mkexp loc (Pexp_tuple al) ]
            in mkexp loc (Pexp_variant s (Some a))
        | _ -> mkexp loc (Pexp_apply (expr f) al) ]
    | ExAre loc e1 e2 ->
        mkexp loc
          (Pexp_apply (mkexp loc (Pexp_ident (array_function "Array" "get")))
            [("", expr e1); ("", expr e2)])
    | ExArr loc e -> mkexp loc (Pexp_array (List.map expr (list_of_expr e [])))
    | ExAsf loc -> mkexp loc Pexp_assertfalse
    | ExAss loc e v ->
        let e =
          match e with
          [ <:expr@loc< $x$.val >> ->
              Pexp_apply (mkexp loc (Pexp_ident (Lident ":=")))
                [("", expr x); ("", expr v)]
          | ExAcc loc _ _ ->
              match (expr e).pexp_desc with
              [ Pexp_field e lab -> Pexp_setfield e lab (expr v)
              | _ -> error loc "bad record access" ]
          | ExAre _ e1 e2 ->
              Pexp_apply (mkexp loc (Pexp_ident (array_function "Array" "set")))
                [("", expr e1); ("", expr e2); ("", expr v)]
          | <:expr< $lid:lab$ >> -> Pexp_setinstvar lab (expr v)
          | ExSte _ e1 e2 ->
              Pexp_apply
                (mkexp loc (Pexp_ident (array_function "String" "set")))
                [("", expr e1); ("", expr e2); ("", expr v)]
          | _ -> error loc "bad left part of assignment" ]
        in
        mkexp loc e
    | ExAsr loc e -> mkexp loc (Pexp_assert (expr e))
    | ExChr loc s ->
        mkexp loc (Pexp_constant (Const_char (char_of_char_token loc s)))
    | ExCoe loc e t1 t2 ->
        let t1 =
          match t1 with
          [ <:ctyp<>> -> None
          | t -> Some (ctyp t) ] in
        mkexp loc (Pexp_constraint (expr e) t1 (Some (ctyp t2)))
    | ExFlo loc s -> mkexp loc (Pexp_constant (Const_float s))
    | ExFor loc i e1 e2 df el ->
        let e3 = ExSeq loc el in
        let df = if mb2b df then Upto else Downto in
        mkexp loc (Pexp_for i (expr e1) (expr e2) df (expr e3))
    | <:expr@loc< fun [ $PaLab _ lab po$ when $w$ -> $e$ ] >> ->
        mkexp loc
          (Pexp_function lab None
            [(patt_of_lab loc lab po, when_expr e w)])
    | <:expr@loc< fun [ $PaOlbi _ lab p e1$ when $w$ -> $e2$ ] >> ->
        let lab = paolab lab p in
        mkexp loc
          (Pexp_function ("?" ^ lab) (Some (expr e1)) [(patt p, when_expr e2 w)])
    | <:expr@loc< fun [ $PaOlb _ lab p$ when $w$ -> $e$ ] >> ->
        let lab = paolab lab p in
        mkexp loc
          (Pexp_function ("?" ^ lab) None [(patt_of_lab loc lab p, when_expr e w)])
    | ExFun loc a -> mkexp loc (Pexp_function "" None (match_case a []))
    | ExIfe loc e1 e2 e3 ->
        mkexp loc (Pexp_ifthenelse (expr e1) (expr e2) (Some (expr e3)))
    | ExInt loc s ->
        let i = try int_of_string s with [
          Failure _ -> error loc "Integer literal exceeds the range of representable integers of type int"
        ] in mkexp loc (Pexp_constant (Const_int i))
    | ExInt32 loc s ->
        let i32 = try Int32.of_string s with [
          Failure _ -> error loc "Integer literal exceeds the range of representable integers of type int32"
        ] in mkexp loc (Pexp_constant (Const_int32 i32))
    | ExInt64 loc s ->
        let i64 = try Int64.of_string s with [
          Failure _ -> error loc "Integer literal exceeds the range of representable integers of type int64"
        ] in mkexp loc (Pexp_constant (Const_int64 i64))
    | ExNativeInt loc s ->
        let nati = try Nativeint.of_string s with [
          Failure _ -> error loc "Integer literal exceeds the range of representable integers of type nativeint"
        ] in mkexp loc (Pexp_constant (Const_nativeint nati))
    | ExLab loc _ _ -> error loc "labeled expression not allowed here"
    | ExLaz loc e -> mkexp loc (Pexp_lazy (expr e))
    | ExLet loc rf bi e ->
        mkexp loc (Pexp_let (mkrf rf) (binding bi []) (expr e))
    | ExLmd loc i me e -> mkexp loc (Pexp_letmodule i (module_expr me) (expr e))
    | ExMat loc e a -> mkexp loc (Pexp_match (expr e) (match_case a []))
    | ExNew loc id -> mkexp loc (Pexp_new (long_type_ident id))
    | ExObj loc po cfl -> 
        let p =
          match po with
          [ <:patt<>> -> <:patt@loc< _ >>
          | p -> p ]
        in
        let cil = class_str_item cfl [] in
        mkexp loc (Pexp_object (patt p, cil))
    | ExOlb loc _ _ -> error loc "labeled expression not allowed here"
    | ExOvr loc iel -> mkexp loc (Pexp_override (mkideexp iel []))
    | ExRec loc lel eo ->
        match lel with
        [ <:binding<>> -> error loc "empty record"
        | _ ->
          let eo =
            match eo with
            [ <:expr<>> -> None
            | e -> Some (expr e) ] in
          mkexp loc (Pexp_record (mklabexp lel []) eo) ]
    | ExSeq _loc e ->
        let rec loop =
          fun
          [ [] -> expr <:expr< () >>
          | [e] -> expr e
          | [e :: el] ->
              let _loc = Loc.merge (loc_of_expr e) _loc in
              mkexp _loc (Pexp_sequence (expr e) (loop el)) ]
        in
        loop (list_of_expr e [])
    | ExSnd loc e s -> mkexp loc (Pexp_send (expr e) s)
    | ExSte loc e1 e2 ->
        mkexp loc
          (Pexp_apply (mkexp loc (Pexp_ident (array_function "String" "get")))
            [("", expr e1); ("", expr e2)])
    | ExStr loc s ->
        mkexp loc (Pexp_constant (Const_string (string_of_string_token loc s)))
    | ExTry loc e a -> mkexp loc (Pexp_try (expr e) (match_case a []))
    | <:expr@loc< ($e1$, $e2$) >> ->
         mkexp loc (Pexp_tuple (List.map expr (list_of_expr e1 (list_of_expr e2 [])))) 
    | <:expr@loc< ($tup:_$) >> -> error loc "singleton tuple"
    | ExTyc loc e t -> mkexp loc (Pexp_constraint (expr e) (Some (ctyp t)) None)
    | <:expr@loc< () >> ->
        mkexp loc (Pexp_construct (lident "()") None True)
    | <:expr@loc< $lid:s$ >> ->
        mkexp loc (Pexp_ident (lident s))
    | <:expr@loc< $uid:s$ >> ->
        (* let ca = constructors_arity () in *)
        mkexp loc (Pexp_construct (lident (conv_con s)) None True)
    | ExVrn loc s -> mkexp loc (Pexp_variant s None)
    | ExWhi loc e1 el ->
        let e2 = ExSeq loc el in
        mkexp loc (Pexp_while (expr e1) (expr e2))
    | <:expr@loc< $_$,$_$ >> -> error loc "expr, expr: not allowed here"
    | <:expr@loc< $_$;$_$ >> ->
        error loc "expr; expr: not allowed here, use do {...} or [|...|] to surround them"
    | ExId _ _ | ExNil _ as e -> error (loc_of_expr e) "invalid expr" ]
  and patt_of_lab _loc lab =
    fun
    [ <:patt<>> -> patt <:patt< $lid:lab$ >>
    | p -> patt p ]
  and expr_of_lab _loc lab =
    fun
    [ <:expr<>> -> expr <:expr< $lid:lab$ >>
    | e -> expr e ]
  and label_expr =
    fun
    [ ExLab loc lab eo -> (lab, expr_of_lab loc lab eo)
    | ExOlb loc lab eo -> ("?" ^ lab, expr_of_lab loc lab eo)
    | e -> ("", expr e) ]
  and binding x acc =
    match x with
    [ <:binding< $x$ and $y$ >> | <:binding< $x$; $y$ >> ->
         binding x (binding y acc)
    | <:binding< $p$ = $e$ >> -> [(patt p, expr e) :: acc]
    | <:binding<>> -> acc
    | _ -> assert False ]
  and match_case x acc =
    match x with
    [ <:match_case< $x$ | $y$ >> -> match_case x (match_case y acc)
    | <:match_case< $pat:p$ when $w$ -> $e$ >> ->
        [(patt p, when_expr e w) :: acc]
    | <:match_case<>> -> acc
    | _ -> assert False ]
  and when_expr e w =
    match w with
    [ <:expr<>> -> expr e
    | w -> mkexp (loc_of_expr w) (Pexp_when (expr w) (expr e)) ]
  and mklabexp x acc =
    match x with
    [ <:binding< $x$ and $y$ >> | <:binding< $x$; $y$ >> ->
         mklabexp x (mklabexp y acc)
    | <:binding< $id:i$ = $e$ >> -> [(ident ~conv_lid:conv_lab i, expr e) :: acc]
    | _ -> assert False ]
  and mkideexp x acc =
    match x with
    [ <:binding< $x$ and $y$ >> | <:binding< $x$; $y$ >> ->
         mkideexp x (mkideexp y acc)
    | <:binding< $lid:s$ = $e$ >> -> [(s, expr e) :: acc]
    | _ -> assert False ]
  and mktype_decl x acc =
    match x with
    [ <:ctyp< $x$ and $y$ >> ->
         mktype_decl x (mktype_decl y acc)
    | Ast.TyDcl _ c tl td cl ->
        let cl =
          List.map
            (fun (t1, t2) ->
              let loc = Loc.merge (loc_of_ctyp t1) (loc_of_ctyp t2) in
              (ctyp t1, ctyp t2, mkloc loc))
            cl
        in
        [(c, type_decl (List.fold_right type_parameters tl []) cl td) :: acc]
    | _ -> assert False ]
  and module_type =
    fun
    [ MtId loc i -> mkmty loc (Pmty_ident (long_uident i))
    | MtFun loc n nt mt ->
        mkmty loc (Pmty_functor n (module_type nt) (module_type mt))
    | MtQuo loc _ -> error loc "abstract module type not allowed here"
    | MtSig loc sl ->
        mkmty loc (Pmty_signature (sig_item sl []))
    | MtWit loc mt wc ->
        mkmty loc (Pmty_with (module_type mt) (mkwithc wc []))
    | <:module_type< $anti:_$ >> -> assert False ]
  and sig_item s l =
    match s with
    [ <:sig_item<>> -> l
    | SgCls loc cd ->
        [mksig loc (Psig_class
           (List.map class_info_class_type (list_of_class_type cd []))) :: l]
    | SgClt loc ctd ->
        [mksig loc (Psig_class_type
           (List.map class_info_class_type (list_of_class_type ctd []))) :: l]
    | <:sig_item< $sg1$; $sg2$ >> -> sig_item sg1 (sig_item sg2 l)
    | SgDir _ _ _ -> l
    | <:sig_item@loc< exception $uid:s$ >> -> [mksig loc (Psig_exception s []) :: l]
    | <:sig_item@loc< exception $uid:s$ of $t$ >> ->
        [mksig loc (Psig_exception s (List.map ctyp (list_of_ctyp t []))) :: l]
    | SgExc _ _ -> assert False (*FIXME*)
    | SgExt loc n t p -> [mksig loc (Psig_value n (mkvalue_desc t [p])) :: l]
    | SgInc loc mt -> [mksig loc (Psig_include (module_type mt)) :: l]
    | SgMod loc n mt -> [mksig loc (Psig_module n (module_type mt)) :: l]
    | SgRecMod loc mb ->
        [mksig loc (Psig_recmodule (module_sig_binding mb [])) :: l]
    | SgMty loc n mt ->
        let si =
          match mt with
          [ MtQuo _ _ -> Pmodtype_abstract
          | _ -> Pmodtype_manifest (module_type mt) ]
        in
        [mksig loc (Psig_modtype n si) :: l]
    | SgOpn loc id ->
        [mksig loc (Psig_open (long_uident id)) :: l]
    | SgTyp loc tdl -> [mksig loc (Psig_type (mktype_decl tdl [])) :: l]
    | SgVal loc n t -> [mksig loc (Psig_value n (mkvalue_desc t [])) :: l]
    | <:sig_item@loc< $anti:_$ >> -> error loc "antiquotation in sig_item" ]
  and module_sig_binding x acc =
    match x with
    [ <:module_binding< $x$ and $y$ >> ->
        module_sig_binding x (module_sig_binding y acc)
    | <:module_binding< $s$ : $mt$ >> ->
        [(s, module_type mt) :: acc]
    | _ -> assert False ]
  and module_str_binding x acc =
    match x with
    [ <:module_binding< $x$ and $y$ >> ->
        module_str_binding x (module_str_binding y acc)
    | <:module_binding< $s$ : $mt$ = $me$ >> ->
        [(s, module_type mt, module_expr me) :: acc]
    | _ -> assert False ]
  and module_expr =
    fun
    [ MeId loc i -> mkmod loc (Pmod_ident (long_uident i))
    | MeApp loc me1 me2 ->
        mkmod loc (Pmod_apply (module_expr me1) (module_expr me2))
    | MeFun loc n mt me ->
        mkmod loc (Pmod_functor n (module_type mt) (module_expr me))
    | MeStr loc sl ->
        mkmod loc (Pmod_structure (str_item sl []))
    | MeTyc loc me mt ->
        mkmod loc (Pmod_constraint (module_expr me) (module_type mt))
    | <:module_expr@loc< $anti:_$ >> -> error loc "antiquotation in module_expr" ]
  and str_item s l =
    match s with
    [ <:str_item<>> -> l
    | StCls loc cd ->
        [mkstr loc (Pstr_class
           (List.map class_info_class_expr (list_of_class_expr cd []))) :: l]
    | StClt loc ctd ->
        [mkstr loc (Pstr_class_type
           (List.map class_info_class_type (list_of_class_type ctd []))) :: l]
    | <:str_item< $st1$; $st2$ >> -> str_item st1 (str_item st2 l)
    | StDir _ _ _ -> l
    | <:str_item@loc< exception $uid:s$ >> ->
        [mkstr loc (Pstr_exception s []) :: l ]
    | <:str_item@loc< exception $uid:s$ of $t$ >> ->
        [mkstr loc (Pstr_exception s (List.map ctyp (list_of_ctyp t []))) :: l ]
    | <:str_item@loc< exception $uid:s$ = $i$ >> ->
        [mkstr loc (Pstr_exn_rebind s (ident i)) :: l ]
    | StExc _ _ _ -> assert False (*FIXME*)
    | StExp loc e -> [mkstr loc (Pstr_eval (expr e)) :: l]
    | StExt loc n t p -> [mkstr loc (Pstr_primitive n (mkvalue_desc t [p])) :: l]
    | StInc loc me -> [mkstr loc (Pstr_include (module_expr me)) :: l]
    | StMod loc n me -> [mkstr loc (Pstr_module n (module_expr me)) :: l]
    | StRecMod loc mb ->
        [mkstr loc (Pstr_recmodule (module_str_binding mb [])) :: l]
    | StMty loc n mt -> [mkstr loc (Pstr_modtype n (module_type mt)) :: l]
    | StOpn loc id ->
        [mkstr loc (Pstr_open (long_uident id)) :: l]
    | StTyp loc tdl -> [mkstr loc (Pstr_type (mktype_decl tdl [])) :: l]
    | StVal loc rf bi ->
        [mkstr loc (Pstr_value (mkrf rf) (binding bi [])) :: l]
    | <:str_item@loc< $anti:_$ >> -> error loc "antiquotation in str_item" ]
  and class_type =
    fun
    [ CtCon loc Ast.BFalse id tl ->
        mkcty loc
          (Pcty_constr (long_class_ident id) (List.map ctyp (list_of_opt_ctyp tl [])))
    | CtFun loc (TyLab _ lab t) ct ->
        mkcty loc (Pcty_fun lab (ctyp t) (class_type ct))
    | CtFun loc (TyOlb loc1 lab t) ct ->
        let t = TyApp loc1 <:ctyp@loc1< option >> t in
        mkcty loc (Pcty_fun ("?" ^ lab) (ctyp t) (class_type ct))
    | CtFun loc t ct -> mkcty loc (Pcty_fun "" (ctyp t) (class_type ct))
    | CtSig loc t_o ctfl ->
        let t =
          match t_o with
          [ <:ctyp<>> -> <:ctyp@loc< _ >>
          | t -> t ]
        in
        let cil = class_sig_item ctfl [] in
        mkcty loc (Pcty_signature (ctyp t, cil))
    | CtCon loc _ _ _ ->
        error loc "invalid virtual class inside a class type"
    | CtAnt _ _ | CtEq _ _ _ | CtCol _ _ _ | CtAnd _ _ _ | CtNil _ ->
        assert False ]
        
  and class_info_class_expr ci =
    match ci with
    [ CeEq _ (CeCon loc vir (IdLid _ name) params) ce ->
      let (loc_params, (params, variance)) =
        match params with
        [ <:ctyp<>> -> (loc, ([], []))
        | t -> (loc_of_ctyp t, List.split (type_parameters t [])) ]
      in
      {pci_virt = if mb2b vir then Virtual else Concrete;
       pci_params = (params, mkloc loc_params);
       pci_name = name;
       pci_expr = class_expr ce;
       pci_loc = mkloc loc;
       pci_variance = variance}
    | ce -> error (loc_of_class_expr ce) "bad class definition" ]
  and class_info_class_type ci =
    match ci with
    [ CtEq _ (CtCon loc vir (IdLid _ name) params) ct |
      CtCol _ (CtCon loc vir (IdLid _ name) params) ct ->
      let (loc_params, (params, variance)) =
        match params with
        [ <:ctyp<>> -> (loc, ([], []))
        | t -> (loc_of_ctyp t, List.split (type_parameters t [])) ]
      in
      {pci_virt = if mb2b vir then Virtual else Concrete;
       pci_params = (params, mkloc loc_params);
       pci_name = name;
       pci_expr = class_type ct;
       pci_loc = mkloc loc;
       pci_variance = variance}
    | ct -> error (loc_of_class_type ct)
              "bad class/class type declaration/definition" ]
  and class_sig_item c l =
    match c with
    [ <:class_sig_item<>> -> l
    | CgCtr loc t1 t2 -> [Pctf_cstr (ctyp t1, ctyp t2, mkloc loc) :: l]
    | <:class_sig_item< $csg1$; $csg2$ >> ->
        class_sig_item csg1 (class_sig_item csg2 l)
    | CgInh _ ct -> [Pctf_inher (class_type ct) :: l]
    | CgMth loc s pf t ->
        [Pctf_meth (s, mkprivate pf, mkpolytype (ctyp t), mkloc loc) :: l]
    | CgVal loc s b v t ->
        [Pctf_val (s, mkmutable b, mkvirtual v, ctyp t, mkloc loc) :: l]
    | CgVir loc s b t ->
        [Pctf_virt (s, mkprivate b, mkpolytype (ctyp t), mkloc loc) :: l]
    | CgAnt _ _ -> assert False ]
  and class_expr =
    fun
    [ CeApp loc _ _ as c ->
        let (ce, el) = class_expr_fa [] c in
        let el = List.map label_expr el in
        mkpcl loc (Pcl_apply (class_expr ce) el)
    | CeCon loc Ast.BFalse id tl ->
        mkpcl loc
          (Pcl_constr (long_class_ident id) (List.map ctyp (list_of_opt_ctyp tl [])))
    | CeFun loc (PaLab _ lab po) ce ->
        mkpcl loc
          (Pcl_fun lab None (patt_of_lab loc lab po) (class_expr ce))
    | CeFun loc (PaOlbi _ lab p e) ce ->
        let lab = paolab lab p in
        mkpcl loc (Pcl_fun ("?" ^ lab) (Some (expr e)) (patt p) (class_expr ce))
    | CeFun loc (PaOlb _ lab p) ce ->
        let lab = paolab lab p in
        mkpcl loc
          (Pcl_fun ("?" ^ lab) None (patt_of_lab loc lab p) (class_expr ce))
    | CeFun loc p ce -> mkpcl loc (Pcl_fun "" None (patt p) (class_expr ce))
    | CeLet loc rf bi ce ->
        mkpcl loc (Pcl_let (mkrf rf) (binding bi []) (class_expr ce))
    | CeStr loc po cfl ->
        let p =
          match po with
          [ <:patt<>> -> <:patt@loc< _ >>
          | p -> p ]
        in
        let cil = class_str_item cfl [] in
        mkpcl loc (Pcl_structure (patt p, cil))
    | CeTyc loc ce ct ->
        mkpcl loc (Pcl_constraint (class_expr ce) (class_type ct))
    | CeCon loc _ _ _ ->
        error loc "invalid virtual class inside a class expression"
    | CeAnt _ _ | CeEq _ _ _ | CeAnd _ _ _ | CeNil _ -> assert False ]
  and class_str_item c l =
    match c with
    [ CrNil _ -> l
    | CrCtr loc t1 t2 -> [Pcf_cstr (ctyp t1, ctyp t2, mkloc loc) :: l]
    | <:class_str_item< $cst1$; $cst2$ >> ->
        class_str_item cst1 (class_str_item cst2 l)
    | CrInh _ ce "" -> [Pcf_inher (class_expr ce) None :: l]
    | CrInh _ ce pb -> [Pcf_inher (class_expr ce) (Some pb) :: l]
    | CrIni _ e -> [Pcf_init (expr e) :: l]
    | CrMth loc s b e t ->
        let t =
          match t with
          [ <:ctyp<>> -> None
          | t -> Some (mkpolytype (ctyp t)) ] in
        let e = mkexp loc (Pexp_poly (expr e) t) in
        [Pcf_meth (s, mkprivate b, e, mkloc loc) :: l]
    | CrVal loc s b e -> [Pcf_val (s, mkmutable b, expr e, mkloc loc) :: l]
    | CrVir loc s b t ->
        [Pcf_virt (s, mkprivate b, mkpolytype (ctyp t), mkloc loc) :: l]
    | CrVvr loc s b t ->
        [Pcf_valvirt (s, mkmutable b, ctyp t, mkloc loc) :: l]
    | CrAnt _ _ -> assert False ];

  value sig_item ast = sig_item ast [];
  value str_item ast = str_item ast [];

  value directive =
    fun
    [ <:expr<>> -> Pdir_none
    | ExStr _ s -> Pdir_string s
    | ExInt _ i -> Pdir_int (int_of_string i)
    | <:expr< True >> -> Pdir_bool True
    | <:expr< False >> -> Pdir_bool False
    | e -> Pdir_ident (ident (ident_of_expr e)) ]
  ;

  value phrase =
    fun
    [ StDir _ d dp -> Ptop_dir d (directive dp)
    | si -> Ptop_def (str_item si) ]
  ;
end;