path: root/camlp4/ocaml_src/camlp4/ast2pt.ml

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

(* Id *)

open Stdpp;;
open MLast;;
open Parsetree;;
open Longident;;
open Asttypes;;

let fast = ref false;;
let no_constructors_arity = ref false;;

let get_tag x =
  if Obj.is_block (Obj.repr x) then Obj.tag (Obj.repr x) else Obj.magic x
;;

let error loc str = raise_with_loc loc (Failure str);;

let char_of_char_token loc s =
  try Token.eval_char s with
    Failure _ as exn -> raise_with_loc loc exn
;;

let string_of_string_token loc s =
  try Token.eval_string s with
    Failure _ as exn -> raise_with_loc loc exn
;;

let mkloc (bp, ep) =
  {Location.loc_start = bp; Location.loc_end = ep; Location.loc_ghost = false}
;;

let mktyp loc d = {ptyp_desc = d; ptyp_loc = mkloc loc};;
let mkpat loc d = {ppat_desc = d; ppat_loc = mkloc loc};;
let mkexp loc d = {pexp_desc = d; pexp_loc = mkloc loc};;
let mkmty loc d = {pmty_desc = d; pmty_loc = mkloc loc};;
let mksig loc d = {psig_desc = d; psig_loc = mkloc loc};;
let mkmod loc d = {pmod_desc = d; pmod_loc = mkloc loc};;
let mkstr loc d = {pstr_desc = d; pstr_loc = mkloc loc};;
let mkfield loc d = {pfield_desc = d; pfield_loc = mkloc loc};;
let mkcty loc d = {pcty_desc = d; pcty_loc = mkloc loc};;
let mkpcl loc d = {pcl_desc = d; pcl_loc = mkloc loc};;

(* shared strings for bootstrap comparisons (and smaller object files)
value shd =
  let tab = Hashtbl.create 701 in
  fun s ->
    try Hashtbl.find tab s with
    [ Not_found -> do { Hashtbl.add tab s s; s } ]
;
... but no more implemented because semantic problems with Ocaml:
let x = "bar" and y = "bar"; x.[0] <- 'c'; print_string y;;
*)
let shd x = x;;
(**)
let lident s = Lident (shd s);;
let ldot l s = Ldot (l, shd s);;

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

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

let array_function str name =
  ldot (lident str) (if !fast then "unsafe_" ^ name else name)
;;

let mkrf =
  function
    true -> Recursive
  | false -> Nonrecursive
;;

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

let long_id_of_string_list loc sl =
  match List.rev sl with
    [] -> error loc "bad ast"
  | s :: sl -> mkli s (List.rev sl)
;;

let rec ctyp_fa al =
  function
    TyApp (_, f, a) -> ctyp_fa (a :: al) f
  | f -> f, al
;;

let rec ctyp_long_id =
  function
    TyAcc (_, m, TyLid (_, s)) ->
      let (is_cls, li) = ctyp_long_id m in is_cls, ldot li s
  | TyAcc (_, m, TyUid (_, s)) ->
      let (is_cls, li) = ctyp_long_id m in is_cls, ldot li s
  | TyApp (_, m1, m2) ->
      let (is_cls, li1) = ctyp_long_id m1 in
      let (_, li2) = ctyp_long_id m2 in is_cls, Lapply (li1, li2)
  | TyUid (_, s) -> false, lident s
  | TyLid (_, s) -> false, lident s
  | TyCls (loc, sl) -> true, long_id_of_string_list loc sl
  | t -> error (loc_of_ctyp t) "incorrect type"
;;

let rec ctyp =
  function
    TyAcc (loc, _, _) as f ->
      let (is_cls, li) = ctyp_long_id f in
      if is_cls then mktyp loc (Ptyp_class (li, [], []))
      else 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 "incorrect alias type"
      in
      mktyp loc (Ptyp_alias (ctyp t, shd 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 (loc1, lab, t1), t2) ->
      mktyp loc (Ptyp_arrow (lab, ctyp t1, ctyp t2))
  | TyArr (loc, TyOlb (loc1, lab, t1), t2) ->
      let t1 = TyApp (loc1, TyLid (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))
  | TyObj (loc, fl, v) -> mktyp loc (Ptyp_object (meth_list loc fl v))
  | TyCls (loc, id) ->
      mktyp loc (Ptyp_class (long_id_of_string_list loc id, [], []))
  | TyLab (loc, _, _) -> error loc "labeled type not allowed here"
  | TyLid (loc, s) -> mktyp loc (Ptyp_constr (lident s, []))
  | TyMan (loc, _, _) -> error loc "type manifest not allowed here"
  | TyOlb (loc, lab, _) -> error loc "labeled type not allowed here"
  | TyQuo (loc, s) -> mktyp loc (Ptyp_var (shd s))
  | TyRec (loc, _) -> error loc "record type not allowed here"
  | TySum (loc, _) -> error loc "sum type not allowed here"
  | TyTup (loc, tl) -> mktyp loc (Ptyp_tuple (List.map ctyp tl))
  | TyUid (loc, s) -> mktyp loc (Ptyp_constr (lident s, []))
  | TyVrn (loc, catl, ool) ->
      let catl =
        List.map (fun (c, a, t) -> Rtag(c, a, List.map ctyp t)) catl in
      let (clos, sl) =
        match ool with
          None -> true, None
        | Some None -> false, None
        | Some (Some (clos, sl)) -> clos, Some sl
      in
      mktyp loc (Ptyp_variant (catl, clos, sl))
  | TyXnd (loc, c, _) ->
      error loc ("type \"" ^ c ^ "\" (extension) not allowed here")
and meth_list loc fl v =
  match fl with
    [] -> if v then [mkfield loc Pfield_var] else []
  | (lab, t) :: fl -> mkfield loc (Pfield (lab, ctyp t)) :: meth_list loc fl v
;;

let 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}
;;
let mkmutable m = if m then Mutable else Immutable;;
let mkprivate m = if m then Private else Public;;
let mktrecord (n, m, t) = shd n, mkmutable m, ctyp t;;
let mkvariant (c, tl) = shd c, List.map ctyp tl;;
let type_decl tl cl =
  function
    TyMan (loc, t, TyRec (_, ltl)) ->
      mktype loc tl cl (Ptype_record (List.map mktrecord ltl)) (Some (ctyp t))
  | TyMan (loc, t, TySum (_, ctl)) ->
      mktype loc tl cl (Ptype_variant (List.map mkvariant ctl))
        (Some (ctyp t))
  | TyRec (loc, ltl) ->
      mktype loc tl cl (Ptype_record (List.map mktrecord ltl)) None
  | TySum (loc, ctl) ->
      mktype loc tl cl (Ptype_variant (List.map mkvariant ctl)) None
  | t ->
      let m =
        match t with
          TyQuo (_, s) -> if List.mem_assoc s tl then Some (ctyp t) else None
        | _ -> Some (ctyp t)
      in
      mktype (loc_of_ctyp t) tl cl Ptype_abstract m
;;

let mkvalue_desc t p = {pval_type = ctyp t; pval_prim = List.map shd p};;

let option f =
  function
    Some x -> Some (f x)
  | None -> None
;;

let rec same_type_expr ct ce =
  match ct, ce with
    TyLid (_, s1), ExLid (_, s2) -> s1 = s2
  | TyUid (_, s1), ExUid (_, s2) -> s1 = s2
  | TyAcc (_, t1, t2), ExAcc (_, e1, e2) ->
      same_type_expr t1 e1 && same_type_expr t2 e2
  | _ -> false
;;

let rec common_id loc t e =
  match t, e with
    TyLid (_, s1), ExLid (_, s2) when s1 = s2 -> lident s1
  | TyUid (_, s1), ExUid (_, s2) when s1 = s2 -> lident s1
  | TyAcc (_, t1, TyLid (_, s1)), ExAcc (_, e1, ExLid (_, s2)) when s1 = s2 ->
      ldot (common_id loc t1 e1) s1
  | TyAcc (_, t1, TyUid (_, s1)), ExAcc (_, e1, ExUid (_, s2)) when s1 = s2 ->
      ldot (common_id loc t1 e1) s1
  | _ -> error loc "this expression should repeat the class id inherited"
;;

let rec type_id loc t =
  match t with
    TyLid (_, s1) -> lident s1
  | TyUid (_, s1) -> lident s1
  | TyAcc (_, t1, TyLid (_, s1)) -> ldot (type_id loc t1) s1
  | TyAcc (_, t1, TyUid (_, s1)) -> ldot (type_id loc t1) s1
  | _ -> error loc "type identifier expected"
;;

let rec module_type_long_id =
  function
    MtAcc (_, m, MtUid (_, s)) -> ldot (module_type_long_id m) s
  | MtAcc (_, m, MtLid (_, s)) -> ldot (module_type_long_id m) s
  | MtApp (_, m1, m2) ->
      Lapply (module_type_long_id m1, module_type_long_id m2)
  | MtLid (_, s) -> lident s
  | MtUid (_, s) -> lident s
  | t -> error (loc_of_module_type t) "bad module type long ident"
;;

let rec module_expr_long_id =
  function
    MeAcc (_, m, MeUid (_, s)) -> ldot (module_expr_long_id m) s
  | MeUid (_, s) -> lident s
  | t -> error (loc_of_module_expr t) "bad module expr long ident"
;;

let mkwithc =
  function
    WcTyp (loc, id, tpl, ct) ->
      let (params, variance) = List.split tpl in
      long_id_of_string_list loc id,
      Pwith_type
        {ptype_params = params; ptype_cstrs = []; ptype_kind = Ptype_abstract;
         ptype_manifest = Some (ctyp ct); ptype_loc = mkloc loc;
         ptype_variance = variance}
  | WcMod (loc, id, m) ->
      long_id_of_string_list loc id, Pwith_module (module_type_long_id m)
;;

let rec patt_fa al =
  function
    PaApp (_, f, a) -> patt_fa (a :: al) f
  | f -> f, al
;;

let 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
         (mkpat loc (Ppat_constant (Const_char c1)),
          mkrangepat loc (Char.chr (Char.code c1 + 1)) c2))
;;

let rec patt_long_id il =
  function
    PaAcc (_, p, PaUid (_, i)) -> patt_long_id (i :: il) p
  | p -> p, il
;;

let rec patt_label_long_id =
  function
    PaAcc (_, m, PaLid (_, s)) -> ldot (patt_label_long_id m) (conv_lab s)
  | PaAcc (_, m, PaUid (_, s)) -> ldot (patt_label_long_id m) s
  | PaUid (_, s) -> lident s
  | PaLid (_, s) -> lident (conv_lab s)
  | p -> error (loc_of_patt p) "bad label"
;;

let rec patt =
  function
    PaAcc (loc, p1, p2) ->
      let p =
        match patt_long_id [] p1 with
          PaUid (_, i), il ->
            begin match p2 with
              PaUid (_, s) ->
                Ppat_construct
                  (mkli (conv_con s) (i :: il), None,
                   not !no_constructors_arity)
            | _ -> error (loc_of_patt p2) "uppercase identifier expected"
            end
        | _ -> error (loc_of_patt p2) "bad pattern"
      in
      mkpat loc p
  | PaAli (loc, p1, p2) ->
      let (p, i) =
        match p1, p2 with
          p, PaLid (_, s) -> p, s
        | PaLid (_, s), p -> p, s
        | _ -> error loc "incorrect alias pattern"
      in
      mkpat loc (Ppat_alias (patt p, shd i))
  | PaAnt (_, p) -> patt p
  | PaAny loc -> mkpat loc Ppat_any
  | PaApp (loc, _, _) as f ->
      let (f, al) = patt_fa [] f in
      let al = List.map patt al in
      begin match (patt f).ppat_desc with
        Ppat_construct (li, None, _) ->
          if !no_constructors_arity then
            let a =
              match al with
                [a] -> a
              | _ -> mkpat loc (Ppat_tuple al)
            in
            mkpat loc (Ppat_construct (li, Some a, false))
          else
            let a = mkpat loc (Ppat_tuple al) in
            mkpat loc (Ppat_construct (li, Some a, true))
      | Ppat_variant (s, None) ->
          let a =
            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"
      end
  | PaArr (loc, pl) -> mkpat loc (Ppat_array (List.map patt pl))
  | PaChr (loc, s) ->
      mkpat loc (Ppat_constant (Const_char (char_of_char_token loc s)))
  | PaInt (loc, s) -> mkpat loc (Ppat_constant (Const_int (int_of_string s)))
  | PaFlo (loc, s) -> mkpat loc (Ppat_constant (Const_float s))
  | PaLab (loc, _, _) -> error loc "labeled pattern not allowed here"
  | PaLid (loc, s) -> mkpat loc (Ppat_var (shd s))
  | PaOlb (loc, _, _, _) -> error loc "labeled pattern not allowed here"
  | PaOrp (loc, p1, p2) -> mkpat loc (Ppat_or (patt p1, patt p2))
  | PaRng (loc, p1, p2) ->
      begin 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"
      end
  | PaRec (loc, lpl) -> mkpat loc (Ppat_record (List.map mklabpat lpl))
  | PaStr (loc, s) ->
      mkpat loc (Ppat_constant (Const_string (string_of_string_token loc s)))
  | PaTup (loc, pl) -> mkpat loc (Ppat_tuple (List.map patt pl))
  | PaTyc (loc, p, t) -> mkpat loc (Ppat_constraint (patt p, ctyp t))
  | PaTyp (loc, sl) -> mkpat loc (Ppat_type (long_id_of_string_list loc sl))
  | PaUid (loc, s) ->
      let ca = not !no_constructors_arity in
      mkpat loc (Ppat_construct (lident (conv_con s), None, ca))
  | PaVrn (loc, s) -> mkpat loc (Ppat_variant (s, None))
  | PaXnd (loc, c, _) ->
      error loc ("pattern \"" ^ c ^ "\" (extension) not allowed here")
and mklabpat (lab, p) = patt_label_long_id lab, patt p;;

let rec expr_fa al =
  function
    ExApp (_, f, a) -> expr_fa (a :: al) f
  | f -> f, al
;;

let rec sep_expr_acc l =
  function
    ExAcc (_, e1, e2) -> sep_expr_acc (sep_expr_acc l e2) e1
  | ExUid ((bp, _ as loc), s) as e ->
      begin match l with
        [] -> [loc, [], e]
      | ((_, ep), sl, e) :: l -> ((bp, ep), s :: sl, e) :: l
      end
  | e -> (loc_of_expr e, [], e) :: l
;;

(*
value expr_label_long_id e =
  match sep_expr_acc [] e with
  [ [(_, ml, ExLid _ s)] -> mkli (conv_lab s) ml
  | _ -> error (loc_of_expr e) "invalid label" ]
;
*)

let class_info class_expr ci =
  let (params, variance) = List.split (snd ci.ciPrm) in
  {pci_virt = if ci.ciVir then Virtual else Concrete;
   pci_params = params, mkloc (fst ci.ciPrm); pci_name = ci.ciNam;
   pci_expr = class_expr ci.ciExp; pci_loc = mkloc ci.ciLoc;
   pci_variance = variance}
;;

let rec expr =
  function
    ExAcc (loc, _, _) as e ->
      let (e, l) =
        match sep_expr_acc [] e with
          (loc, ml, ExUid (_, s)) :: l ->
            let ca = not !no_constructors_arity in
            mkexp loc (Pexp_construct (mkli s ml, None, ca)), l
        | (loc, ml, ExLid (_, s)) :: l ->
            mkexp loc (Pexp_ident (mkli s ml)), l
        | (_, [], e) :: l -> expr e, l
        | _ -> error loc "bad ast"
      in
      let (_, e) =
        List.fold_left
          (fun ((bp, _), e1) ((_, ep), ml, e2) ->
             match e2 with
               ExLid (_, s) ->
                 let loc = bp, 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 (_, e) -> expr e
  | ExApp (loc, _, _) as f ->
      let (f, al) = expr_fa [] f in
      let al = List.map label_expr al in
      begin match (expr f).pexp_desc with
        Pexp_construct (li, None, _) ->
          let al = List.map snd al in
          if !no_constructors_arity then
            let a =
              match al with
                [a] -> a
              | _ -> mkexp loc (Pexp_tuple al)
            in
            mkexp loc (Pexp_construct (li, Some a, false))
          else
            let a = mkexp loc (Pexp_tuple al) in
            mkexp loc (Pexp_construct (li, Some a, true))
      | Pexp_variant (s, None) ->
          let al = List.map snd al in
          let a =
            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))
      end
  | ExAre (loc, e1, e2) ->
      mkexp loc
        (Pexp_apply
           (mkexp loc (Pexp_ident (array_function "Array" "get")),
            ["", expr e1; "", expr e2]))
  | ExArr (loc, el) -> mkexp loc (Pexp_array (List.map expr el))
  | ExAss (loc, e, v) ->
      let e =
        match e with
          ExAcc (loc, _, _) ->
            begin match (expr e).pexp_desc with
              Pexp_field (e, lab) -> Pexp_setfield (e, lab, expr v)
            | _ -> error loc "bad record access"
            end
        | ExAre (_, e1, e2) ->
            Pexp_apply
              (mkexp loc (Pexp_ident (array_function "Array" "set")),
               ["", expr e1; "", expr e2; "", expr v])
        | ExLid (_, lab) -> Pexp_setinstvar (shd 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
  | ExChr (loc, s) ->
      mkexp loc (Pexp_constant (Const_char (char_of_char_token loc s)))
  | ExCoe (loc, e, t1, t2) ->
      mkexp loc (Pexp_constraint (expr e, option ctyp 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 df then Upto else Downto in
      mkexp loc (Pexp_for (shd i, expr e1, expr e2, df, expr e3))
  | ExFun (loc, [PaLab (_, lab, p), w, e]) ->
      mkexp loc (Pexp_function (lab, None, [patt p, when_expr e w]))
  | ExFun (loc, [PaOlb (_, lab, p, eo), w, e]) ->
      mkexp loc
        (Pexp_function (("?" ^ lab), option expr eo, [patt p, when_expr e w]))
  | ExFun (loc, pel) ->
      mkexp loc (Pexp_function ("", None, List.map mkpwe pel))
  | ExIfe (loc, e1, e2, e3) ->
      mkexp loc (Pexp_ifthenelse (expr e1, expr e2, Some (expr e3)))
  | ExInt (loc, s) -> mkexp loc (Pexp_constant (Const_int (int_of_string s)))
  | ExLab (loc, _, _) -> error loc "labeled expression not allowed here"
  | ExLet (loc, rf, pel, e) ->
      mkexp loc (Pexp_let (mkrf rf, List.map mkpe pel, expr e))
  | ExLid (loc, s) -> mkexp loc (Pexp_ident (lident s))
  | ExLmd (loc, i, me, e) ->
      mkexp loc (Pexp_letmodule (i, module_expr me, expr e))
  | ExMat (loc, e, pel) -> mkexp loc (Pexp_match (expr e, List.map mkpwe pel))
  | ExNew (loc, id) -> mkexp loc (Pexp_new (long_id_of_string_list loc id))
  | ExOlb (loc, _, _) -> error loc "labeled expression not allowed here"
  | ExOvr (loc, iel) -> mkexp loc (Pexp_override (List.map mkideexp iel))
  | ExRec (loc, lel, eo) ->
      let eo =
        match eo with
          Some e -> Some (expr e)
        | None -> None
      in
      mkexp loc (Pexp_record (List.map mklabexp lel, eo))
  | ExSeq (loc, el) ->
      let rec loop =
        function
          [] -> expr (ExUid (loc, "()"))
        | [e] -> expr e
        | e :: el -> mkexp (loc_of_expr e) (Pexp_sequence (expr e, loop el))
      in
      loop el
  | 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, pel) -> mkexp loc (Pexp_try (expr e, List.map mkpwe pel))
  | ExTup (loc, el) -> mkexp loc (Pexp_tuple (List.map expr el))
  | ExTyc (loc, e, t) ->
      mkexp loc (Pexp_constraint (expr e, Some (ctyp t), None))
  | ExUid (loc, s) ->
      let ca = not !no_constructors_arity in
      mkexp loc (Pexp_construct (lident (conv_con s), None, ca))
  | 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))
  | ExXnd (loc, c, _) ->
      error loc ("expression \"" ^ c ^ "\" (extension) not allowed here")
and label_expr =
  function
    ExLab (loc, lab, e) -> lab, expr e
  | ExOlb (loc, lab, e) -> "?" ^ lab, expr e
  | e -> "", expr e
and mkpe (p, e) = patt p, expr e
and mkpwe (p, w, e) = patt p, when_expr e w
and when_expr e =
  function
    Some w -> mkexp (loc_of_expr e) (Pexp_when (expr w, expr e))
  | None -> expr e
and mklabexp (lab, e) = patt_label_long_id lab, expr e
and mkideexp (ide, e) = shd ide, expr e
and mktype_decl (c, tl, td, cl) =
  let cl =
    List.map
      (fun (t1, t2) ->
         let loc = fst (loc_of_ctyp t1), snd (loc_of_ctyp t2) in
         ctyp t1, ctyp t2, mkloc loc)
      cl
  in
  shd c, type_decl tl cl td
and module_type =
  function
    MtAcc (loc, _, _) as f -> mkmty loc (Pmty_ident (module_type_long_id f))
  | MtApp (loc, _, _) as f -> mkmty loc (Pmty_ident (module_type_long_id f))
  | MtFun (loc, n, nt, mt) ->
      mkmty loc (Pmty_functor (shd n, module_type nt, module_type mt))
  | MtLid (loc, s) -> mkmty loc (Pmty_ident (lident s))
  | MtSig (loc, sl) ->
      mkmty loc (Pmty_signature (List.fold_right sig_item sl []))
  | MtUid (loc, s) -> mkmty loc (Pmty_ident (lident s))
  | MtWit (loc, mt, wcl) ->
      mkmty loc (Pmty_with (module_type mt, List.map mkwithc wcl))
and sig_item s l =
  match s with
    SgCls (loc, cd) ->
      mksig loc (Psig_class (List.map (class_info class_type) cd)) :: l
  | SgClt (loc, ctd) ->
      mksig loc (Psig_class_type (List.map (class_info class_type) ctd)) :: l
  | SgDcl (loc, sl) -> List.fold_right sig_item sl l
  | SgDir (loc, _, _) -> l
  | SgExc (loc, n, tl) ->
      mksig loc (Psig_exception (shd n, List.map ctyp tl)) :: l
  | SgExt (loc, n, t, p) ->
      mksig loc (Psig_value (shd 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 (shd n, module_type mt)) :: l
  | SgMty (loc, n, mt) ->
      mksig loc (Psig_modtype (shd n, Pmodtype_manifest (module_type mt))) ::
        l
  | SgOpn (loc, id) ->
      mksig loc (Psig_open (long_id_of_string_list loc id)) :: l
  | SgTyp (loc, tdl) -> mksig loc (Psig_type (List.map mktype_decl tdl)) :: l
  | SgVal (loc, n, t) -> mksig loc (Psig_value (n, mkvalue_desc t [])) :: l
and module_expr =
  function
    MeAcc (loc, _, _) as f -> mkmod loc (Pmod_ident (module_expr_long_id f))
  | MeApp (loc, me1, me2) ->
      mkmod loc (Pmod_apply (module_expr me1, module_expr me2))
  | MeFun (loc, n, mt, me) ->
      mkmod loc (Pmod_functor (shd n, module_type mt, module_expr me))
  | MeStr (loc, sl) ->
      mkmod loc (Pmod_structure (List.fold_right str_item sl []))
  | MeTyc (loc, me, mt) ->
      mkmod loc (Pmod_constraint (module_expr me, module_type mt))
  | MeUid (loc, s) -> mkmod loc (Pmod_ident (lident s))
and str_item s l =
  match s with
    StCls (loc, cd) ->
      mkstr loc (Pstr_class (List.map (class_info class_expr) cd)) :: l
  | StClt (loc, ctd) ->
      mkstr loc (Pstr_class_type (List.map (class_info class_type) ctd)) :: l
  | StDcl (loc, sl) -> List.fold_right str_item sl l
  | StDir (loc, _, _) -> l
  | StExc (loc, n, tl) ->
      mkstr loc (Pstr_exception (shd n, List.map ctyp tl)) :: l
  | StExp (loc, e) -> mkstr loc (Pstr_eval (expr e)) :: l
  | StExt (loc, n, t, p) ->
      mkstr loc (Pstr_primitive (shd 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 (shd n, module_expr me)) :: l
  | StMty (loc, n, mt) ->
      mkstr loc (Pstr_modtype (shd n, module_type mt)) :: l
  | StOpn (loc, id) ->
      mkstr loc (Pstr_open (long_id_of_string_list loc id)) :: l
  | StTyp (loc, tdl) -> mkstr loc (Pstr_type (List.map mktype_decl tdl)) :: l
  | StVal (loc, rf, pel) ->
      mkstr loc (Pstr_value (mkrf rf, List.map mkpe pel)) :: l
and class_type =
  function
    CtCon (loc, id, tl) ->
      mkcty loc
        (Pcty_constr (long_id_of_string_list loc id, List.map 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, TyLid (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
          Some t -> t
        | None -> TyAny loc
      in
      let cil = List.fold_right class_sig_item ctfl [] in
      mkcty loc (Pcty_signature (ctyp t, cil))
  | CtXnd (loc, c, _) ->
      error loc ("class type \"" ^ c ^ "\" (extension) not allowed here")
and class_sig_item c l =
  match c with
    CgCtr (loc, t1, t2) -> Pctf_cstr (ctyp t1, ctyp t2, mkloc loc) :: l
  | CgDcl (loc, cl) -> List.fold_right class_sig_item cl l
  | CgInh (loc, ct) -> Pctf_inher (class_type ct) :: l
  | CgMth (loc, s, pf, t) ->
      Pctf_meth (s, mkprivate pf, ctyp t, mkloc loc) :: l
  | CgVal (loc, s, b, t) ->
      Pctf_val (s, mkmutable b, Some (ctyp t), mkloc loc) :: l
  | CgVir (loc, s, b, t) -> Pctf_virt (s, mkprivate b, ctyp t, mkloc loc) :: l
and class_expr =
  function
    CeApp (loc, ce, el) ->
      let el = List.map label_expr el in
      mkpcl loc (Pcl_apply (class_expr ce, el))
  | CeCon (loc, id, tl) ->
      mkpcl loc (Pcl_constr (long_id_of_string_list loc id, List.map ctyp tl))
  | CeFun (loc, PaLab (_, lab, p), ce) ->
      mkpcl loc (Pcl_fun (lab, None, patt p, class_expr ce))
  | CeFun (loc, PaOlb (_, lab, p, eo), ce) ->
      let eo =
        match eo with
          Some e -> Some (expr e)
        | None -> None
      in
      mkpcl loc (Pcl_fun (("?" ^ lab), eo, patt p, class_expr ce))
  | CeFun (loc, p, ce) ->
      mkpcl loc (Pcl_fun ("", None, patt p, class_expr ce))
  | CeLet (loc, rf, pel, ce) ->
      mkpcl loc (Pcl_let (mkrf rf, List.map mkpe pel, class_expr ce))
  | CeStr (loc, po, cfl) ->
      let p =
        match po with
          Some p -> p
        | None -> PaAny loc
      in
      let cil = List.fold_right 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))
  | CeXnd (loc, c, _) ->
      error loc
        ("class expression \"" ^ c ^ "\" (extension) not allowed here")
and class_str_item c l =
  match c with
    CrCtr (loc, t1, t2) -> Pcf_cstr (ctyp t1, ctyp t2, mkloc loc) :: l
  | CrDcl (loc, cl) -> List.fold_right class_str_item cl l
  | CrInh (loc, ce, pb) -> Pcf_inher (class_expr ce, pb) :: l
  | CrIni (loc, e) -> Pcf_init (expr e) :: l
  | CrMth (loc, s, b, e) -> Pcf_meth (s, mkprivate b, expr 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, ctyp t, mkloc loc) :: l
;;

let interf ast = List.fold_right sig_item ast [];;
let implem ast = List.fold_right str_item ast [];;