(* camlp4r *)
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* 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 Camlp4 *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Daniel de Rauglaudre: initial version
* - Nicolas Pouillard: refactoring
*)
(* We copy the implementation of a few functions from OCaml to avoid depending on its
implementation. *)
module Location = struct
type t = Location.t == {
loc_start: Lexing.position;
loc_end: Lexing.position;
loc_ghost: bool;
};
type loc 'a = Location.loc 'a == {
txt : 'a;
loc : t;
};
value none =
let loc = {
Lexing.
pos_fname = "_none_";
pos_lnum = 1;
pos_bol = 0;
pos_cnum = -1;
} in
{ loc_start = loc; loc_end = loc; loc_ghost = True };
value mkloc txt loc = { txt; loc };
end;
module Longident = struct
type t = Longident.t ==
[ Lident of string
| Ldot of t and string
| Lapply of t and t ];
value last = fun
[ Lident s -> s
| Ldot _ s -> s
| Lapply _ _ -> failwith "Longident.last" ];
end;
module Make (Ast : Sig.Camlp4Ast) = struct
open Format;
open Parsetree;
open Longident;
open Asttypes;
open Ast;
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 remove_underscores s =
let s = Bytes.of_string s in
let l = Bytes.length s in
let rec remove src dst =
if src >= l then
if dst >= l then s else Bytes.sub s 0 dst
else
match Bytes.get s src with
[ '_' -> remove (src + 1) dst
| c -> do { Bytes.set s dst c; remove (src + 1) (dst + 1) } ]
in Bytes.to_string (remove 0 0)
;
value mkloc = Loc.to_ocaml_location;
value mkghloc loc = Loc.to_ocaml_location (Loc.ghostify loc);
value with_loc txt loc = Location.mkloc txt (mkloc loc);
value mktyp loc d = {ptyp_desc = d; ptyp_loc = mkloc loc; ptyp_attributes = []};
value mkpat loc d = {ppat_desc = d; ppat_loc = mkloc loc; ppat_attributes = []};
value mkghpat loc d = {ppat_desc = d; ppat_loc = mkghloc loc; ppat_attributes = []};
value mkexp loc d = {pexp_desc = d; pexp_loc = mkloc loc; pexp_attributes = []};
value mkmty loc d = {pmty_desc = d; pmty_loc = mkloc loc; pmty_attributes = []};
value mksig loc d = {psig_desc = d; psig_loc = mkloc loc};
value mkmod loc d = {pmod_desc = d; pmod_loc = mkloc loc; pmod_attributes = []};
value mkstr loc d = {pstr_desc = d; pstr_loc = mkloc loc};
value mkcty loc d = {pcty_desc = d; pcty_loc = mkloc loc; pcty_attributes = []};
value mkcl loc d = {pcl_desc = d; pcl_loc = mkloc loc; pcl_attributes = []};
value mkcf loc d = { pcf_desc = d; pcf_loc = mkloc loc; pcf_attributes = []};
value mkctf loc d = { pctf_desc = d; pctf_loc = mkloc loc; pctf_attributes = []};
value mkpolytype t =
match t.ptyp_desc with
[ Ptyp_poly _ _ -> t
| _ -> { (t) with ptyp_desc = Ptyp_poly [] t } ]
;
value mkvirtual = fun
[ <:virtual_flag< virtual >> -> Virtual
| <:virtual_flag<>> -> Concrete
| _ -> assert False ];
value mkdirection = fun
[ <:direction_flag< to >> -> Upto
| <:direction_flag< downto >> -> Downto
| _ -> assert False ];
value lident s = Lident s;
value lident_with_loc s loc = with_loc (Lident s) loc;
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_no_loc str name =
ldot (lident str) (if Camlp4_config.unsafe.val then "unsafe_" ^ name else name)
;
value array_function loc str name = with_loc (array_function_no_loc str name) loc;
value mkrf =
fun
[ Ast.ReRecursive -> Recursive
| Ast.ReNonrecursive | Ast.ReNil -> Nonrecursive
| _ -> assert False ];
value mknrf =
fun
[ Ast.ReNonrecursive -> Nonrecursive
| Ast.ReRecursive | Ast.ReNil -> Recursive
| _ -> assert False ];
value mkli sloc s list = with_loc (loop lident list) sloc
where rec loop f =
fun
[ [i :: il] -> loop (ldot (f i)) 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_noloc ?conv_lid i = fst (ident_tag ?conv_lid i);
value ident ?conv_lid i =
with_loc (ident_noloc ?conv_lid i) (loc_of_ident i);
value long_lident msg id =
match ident_tag id with
[ (i, `lident) -> with_loc i (loc_of_ident id)
| _ -> error (loc_of_ident id) msg ]
;
value long_type_ident = long_lident "invalid long identifier type";
value long_class_ident = long_lident "invalid class name";
value long_uident_noloc ?(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 long_uident ?conv_con i =
with_loc (long_uident_noloc ?conv_con i) (loc_of_ident i);
value rec ctyp_long_id_prefix t =
match t with
[ <:ctyp< $id:i$ >> -> ident_noloc 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@loc< '$s$ >> -> [with_loc s loc]
| _ -> assert False ];
value attribute_fwd = ref (fun _ _ _ -> assert False);
value attribute loc s str =
!attribute_fwd loc s str;
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 (Labelled lab) (ctyp t1) (ctyp t2))
| TyArr loc (TyOlb _ lab t1) t2 ->
mktyp loc (Ptyp_arrow (Optional lab) (ctyp t1) (ctyp t2))
| TyArr loc t1 t2 -> mktyp loc (Ptyp_arrow Nolabel (ctyp t1) (ctyp t2))
| <:ctyp@loc< < $fl$ > >> -> mktyp loc (Ptyp_object (meth_list fl []) Closed)
| <:ctyp@loc< < $fl$ .. > >> ->
mktyp loc (Ptyp_object (meth_list fl []) Open)
| TyCls loc id ->
mktyp loc (Ptyp_class (ident id) [])
| <:ctyp@loc< (module $pt$) >> ->
let (i, cs) = package_type pt in
mktyp loc (Ptyp_package i cs)
| TyAtt loc s str e ->
let e = ctyp e in
{(e) with ptyp_attributes = e.ptyp_attributes @ [attribute loc s str]}
| 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"
| TyTypePol loc _ _ -> error loc "locally abstract type 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) Closed None)
| <:ctyp@loc< [ > $t$ ] >> -> mktyp loc (Ptyp_variant (row_field t) Open None)
| <:ctyp@loc< [ < $t$ ] >> -> mktyp loc (Ptyp_variant (row_field t) Closed (Some []))
| <:ctyp@loc< [ < $t$ > $t'$ ] >> ->
mktyp loc (Ptyp_variant (row_field t) Closed (Some (name_tags t')))
| TyAnt loc _ -> error loc "antiquotation not allowed here"
| TyOfAmp loc _ _
| TyAmp loc _ _
| TySta loc _ _
| TyCom loc _ _
| TyVrn loc _
| TyQuM loc _
| TyQuP loc _
| TyDcl loc _ _ _ _
| TyExt loc _ _ _
| TyAnP loc
| TyAnM loc
| TyObj loc _ (RvAnt _)
| TyNil loc
| TyOpn loc
| TyTup loc _ -> error loc "this construction is not allowed here" ]
and row_field = fun
[ <:ctyp<>> -> []
| <:ctyp@loc< `$i$ >> ->
[Rtag (with_loc (conv_con i) loc) [] True []]
| <:ctyp@loc< `$i$ of & $t$ >> ->
[Rtag (with_loc (conv_con i) loc) [] True (List.map ctyp (list_of_ctyp t []))]
| <:ctyp@loc< `$i$ of $t$ >> ->
[Rtag (with_loc (conv_con i) loc) [] 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<>> -> acc
| <:ctyp< $t1$; $t2$ >> -> meth_list t1 (meth_list t2 acc)
| <:ctyp@loc< $lid:lab$ : $t$ >> ->
[Otag (with_loc lab loc) [] (mkpolytype (ctyp t)) :: acc]
| _ -> assert False ]
and package_type_constraints wc acc =
match wc with
[ <:with_constr<>> -> acc
| <:with_constr< type $id:id$ = $ct$ >> ->
[(ident id, ctyp ct) :: acc]
| <:with_constr< $wc1$ and $wc2$ >> ->
package_type_constraints wc1 (package_type_constraints wc2 acc)
| _ -> error (loc_of_with_constr wc) "unexpected `with constraint' for a package type" ]
and package_type : module_type -> package_type =
fun
[ <:module_type< $id:i$ with $wc$ >> ->
(long_uident i, package_type_constraints wc [])
| <:module_type< $id:i$ >> -> (long_uident i, [])
| mt -> error (loc_of_module_type mt) "unexpected package type" ]
;
value mktype loc name tl cl tk tp tm =
{ptype_name = name;
ptype_params = tl; ptype_cstrs = cl; ptype_kind = tk;
ptype_private = tp; ptype_manifest = tm; ptype_loc = mkloc loc;
ptype_attributes = []}
;
value mktypext path tl tc tp =
{ptyext_path = path;
ptyext_params = tl;
ptyext_constructors = tc;
ptyext_private = tp;
ptyext_attributes = []}
;
value mkprivate' m = if m then Private else Public;
value mkprivate = fun
[ <:private_flag< private >> -> Private
| <:private_flag<>> -> Public
| _ -> assert False ];
value mktrecord =
fun
[ <:ctyp@loc< $id:(<:ident@sloc< $lid:s$ >>)$ : mutable $t$ >> ->
{pld_name=with_loc s sloc;
pld_mutable=Mutable;
pld_type=mkpolytype (ctyp t);
pld_loc=mkloc loc;
pld_attributes=[];
}
| <:ctyp@loc< $id:(<:ident@sloc< $lid:s$ >>)$ : $t$ >> ->
{pld_name=with_loc s sloc;
pld_mutable=Immutable;
pld_type=mkpolytype (ctyp t);
pld_loc=mkloc loc;
pld_attributes=[];
}
| _ -> assert False (*FIXME*) ];
value mkvariant =
fun
[ <:ctyp@loc< $id:(<:ident@sloc< $uid:s$ >>)$ >> ->
{ pcd_name = with_loc (conv_con s) sloc
; pcd_args = Pcstr_tuple []
; pcd_res = None
; pcd_loc = mkloc loc
; pcd_attributes = []
}
| <:ctyp@loc< $id:(<:ident@sloc< $uid:s$ >>)$ of $t$ >> ->
{ pcd_name = with_loc (conv_con s) sloc
; pcd_args = Pcstr_tuple (List.map ctyp (list_of_ctyp t []))
; pcd_res = None
; pcd_loc = mkloc loc
; pcd_attributes = []
}
| <:ctyp@loc< $id:(<:ident@sloc< $uid:s$ >>)$ : ($t$ -> $u$) >> ->
{ pcd_name = with_loc (conv_con s) sloc
; pcd_args = Pcstr_tuple (List.map ctyp (list_of_ctyp t []))
; pcd_res = Some (ctyp u)
; pcd_loc = mkloc loc
; pcd_attributes = []
}
| <:ctyp@loc< $id:(<:ident@sloc< $uid:s$ >>)$ : $t$ >> ->
{ pcd_name = with_loc (conv_con s) sloc
; pcd_args = Pcstr_tuple []
; pcd_res = Some (ctyp t)
; pcd_loc = mkloc loc
; pcd_attributes = []
}
| _ -> assert False (*FIXME*) ];
value mkextension_constructor =
fun
[ <:ctyp@loc< $id:(<:ident@sloc< $uid:s$ >>)$ >> ->
{pext_name = with_loc (conv_con s) sloc;
pext_kind = Pext_decl (Pcstr_tuple []) None;
pext_loc = mkloc loc;
pext_attributes = []}
| <:ctyp@loc< $id:(<:ident@sloc< $uid:s$ >>)$ of $t$ >> ->
{pext_name = with_loc (conv_con s) sloc;
pext_kind = Pext_decl (Pcstr_tuple (List.map ctyp (list_of_ctyp t []))) None;
pext_loc = mkloc loc;
pext_attributes = []}
| <:ctyp@loc< $id:(<:ident@sloc< $uid:s$ >>)$ : ($t$ -> $u$) >> ->
{pext_name = with_loc (conv_con s) sloc;
pext_kind = Pext_decl (Pcstr_tuple (List.map ctyp (list_of_ctyp t []))) (Some (ctyp u));
pext_loc = mkloc loc;
pext_attributes = []}
| <:ctyp@loc< $id:(<:ident@sloc< $uid:s$ >>)$ : $t$ >> ->
{pext_name = with_loc (conv_con s) sloc;
pext_kind = Pext_decl (Pcstr_tuple []) (Some (ctyp t));
pext_loc = mkloc loc;
pext_attributes = []}
| <:ctyp@loc< $id:(<:ident@sloc< $uid:s$ >>)$ == $id:r$ >> ->
{pext_name = with_loc (conv_con s) sloc;
pext_kind = Pext_rebind (long_uident r);
pext_loc = mkloc loc;
pext_attributes = []}
| _ -> assert False (*FIXME*) ];
value rec type_decl name tl cl loc m pflag =
fun
[ <:ctyp< $t1$ == $t2$ >> ->
type_decl name tl cl loc (Some (ctyp t1)) pflag t2
| <:ctyp@_loc< private $t$ >> ->
if pflag then
error _loc "multiple private keyword used, use only one instead"
else
type_decl name tl cl loc m True t
| <:ctyp< { $t$ } >> ->
mktype loc name tl cl
(Ptype_record (List.map mktrecord (list_of_ctyp t []))) (mkprivate' pflag) m
| <:ctyp< [ $t$ ] >> ->
mktype loc name tl cl
(Ptype_variant (List.map mkvariant (list_of_ctyp t []))) (mkprivate' pflag) m
| TyOpn loc ->
mktype loc name tl cl Ptype_open (mkprivate' pflag) m
| t ->
if m <> None then
error loc "only one manifest type allowed by definition" else
let m =
match t with
[ <:ctyp<>> -> None
| _ -> Some (ctyp t) ]
in
mktype loc name tl cl Ptype_abstract (mkprivate' pflag) m ]
;
value rec type_ext path tl loc pflag =
fun
[ <:ctyp@_loc< $_$ == $_$ >> ->
error _loc "manifest type not allowed for extensions"
| <:ctyp@_loc< private $t$ >> ->
if pflag then
error _loc "multiple private keyword used, use only one instead"
else
type_ext path tl loc True t
| <:ctyp< [ $t$ ] >> ->
mktypext path tl
(List.map mkextension_constructor (list_of_ctyp t []))
(mkprivate' pflag)
| _ ->
error loc "invalid type extension" ]
;
value type_decl name tl cl t loc = type_decl name tl cl loc None False t;
value type_ext path tl t loc = type_ext path tl loc False t;
value mkvalue_desc loc name t p = {pval_name = name; pval_type = ctyp t; pval_prim = p; pval_loc = mkloc loc; pval_attributes = []};
value rec list_of_meta_list =
fun
[ Ast.LNil -> []
| Ast.LCons x xs -> [x :: list_of_meta_list xs]
| Ast.LAnt _ -> assert False ];
value mkmutable = fun
[ <:mutable_flag< mutable >> -> Mutable
| <:mutable_flag<>> -> Immutable
| _ -> assert False ];
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 opt_private_ctyp =
fun
[ <:ctyp< private $t$ >> -> (Ptype_abstract, Private, ctyp t)
| t -> (Ptype_abstract, Public, ctyp t) ];
value rec type_parameters t acc =
match t with
[ <:ctyp< $t1$ $t2$ >> -> type_parameters t1 (type_parameters t2 acc)
| <:ctyp< +'$s$ >> -> [(s, Covariant) :: acc]
| <:ctyp< -'$s$ >> -> [(s, Contravariant) :: acc]
| <:ctyp< '$s$ >> -> [(s, Invariant) :: acc]
| _ -> assert False ];
value core_type loc ty =
{ ptyp_desc = ty
; ptyp_loc = mkloc loc
; ptyp_attributes = []
};
value ptyp_var loc s = core_type loc (Ptyp_var s);
value ptyp_any loc = core_type loc Ptyp_any;
value rec optional_type_parameters t acc =
match t with
[ <:ctyp< $t1$ $t2$ >> -> optional_type_parameters t1 (optional_type_parameters t2 acc)
| <:ctyp@loc< +'$s$ >> -> [(ptyp_var loc s, Covariant) :: acc]
| Ast.TyAnP loc -> [(ptyp_any loc, Covariant) :: acc]
| <:ctyp@loc< -'$s$ >> -> [(ptyp_var loc s, Contravariant) :: acc]
| Ast.TyAnM loc -> [(ptyp_any loc, Contravariant) :: acc]
| <:ctyp@loc< '$s$ >> -> [(ptyp_var loc s, Invariant) :: acc]
| Ast.TyAny loc -> [(ptyp_any loc, Invariant) :: acc]
| _ -> assert False ];
value rec class_parameters t acc =
match t with
[ <:ctyp< $t1$, $t2$ >> -> class_parameters t1 (class_parameters t2 acc)
| <:ctyp@loc< +'$s$ >> -> [(ptyp_var loc s, Covariant) :: acc]
| <:ctyp@loc< -'$s$ >> -> [(ptyp_var loc s, Contravariant) :: acc]
| <:ctyp@loc< '$s$ >> -> [(ptyp_var loc s, Invariant) :: acc]
| _ -> assert False ];
value rec type_parameters_and_type_name t acc =
match t with
[ <:ctyp< $t1$ $t2$ >> ->
type_parameters_and_type_name t1
(optional_type_parameters t2 acc)
| <:ctyp< $id:i$ >> -> (ident i, acc)
| _ -> assert False ];
value mkwithtyp pwith_type loc id_tpl ct =
let (id, tpl) = type_parameters_and_type_name id_tpl [] in
let (kind, priv, ct) = opt_private_ctyp ct in
pwith_type id
{ ptype_name = Location.mkloc (Longident.last id.txt) id.loc;
ptype_params = tpl; ptype_cstrs = [];
ptype_kind = kind;
ptype_private = priv;
ptype_manifest = Some ct;
ptype_loc = mkloc loc;
ptype_attributes = [];
};
value rec mkwithc wc acc =
match wc with
[ <:with_constr<>> -> acc
| <:with_constr@loc< type $id_tpl$ = $ct$ >> ->
[mkwithtyp (fun lid x -> Pwith_type lid x) loc id_tpl ct :: acc]
| <:with_constr< module $i1$ = $i2$ >> ->
[(Pwith_module (long_uident i1) (long_uident i2)) :: acc]
| <:with_constr@loc< type $id_tpl$ := $ct$ >> ->
[mkwithtyp (fun lid x -> Pwith_typesubst lid x) loc id_tpl ct :: acc]
| <:with_constr< module $i1$ := $i2$ >> (*WcMoS _ i1 i2*) ->
[(Pwith_modsubst (long_uident i1) (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 (Pconst_char c1))
else
mkghpat loc
(Ppat_or (mkghpat loc (Ppat_constant (Pconst_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 (Pconst_char c1))
else
mkpat loc
(Ppat_or (mkghpat loc (Ppat_constant (Pconst_char c1)))
(deep_mkrangepat loc (Char.chr (Char.code c1 + 1)) c2))
;
value rec patt =
fun
[ <:patt@loc< $id:(<:ident@sloc< $lid:s$ >>)$ >> ->
mkpat loc (Ppat_var (with_loc s sloc))
| <:patt@loc< $id:i$ >> ->
let p = Ppat_construct (long_uident ~conv_con i) None
in mkpat loc p
| PaAli loc p1 p2 ->
let (p, i) =
match (p1, p2) with
[ (p, <:patt< $id:(<:ident@sloc< $lid:s$ >>)$ >>) -> (p, with_loc s sloc)
| (<:patt< $id:(<:ident@sloc< $lid:s$ >>)$ >>, p) -> (p, with_loc s sloc)
| _ -> 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< $id:(<:ident@sloc< $uid:s$ >>)$ ($tup:<:patt@loc_any< _ >>$) >> ->
mkpat loc (Ppat_construct (lident_with_loc (conv_con s) sloc)
(Some (mkpat loc_any Ppat_any)))
| 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 ->
let a =
match al with
[ [a] -> a
| _ -> mkpat loc (Ppat_tuple al) ]
in
mkpat loc (Ppat_construct li (Some a))
| 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" ]
| PaArr loc p -> mkpat loc (Ppat_array (List.map patt (list_of_patt p [])))
| PaChr loc s ->
mkpat loc (Ppat_constant (Pconst_char (char_of_char_token loc s)))
| PaInt loc s -> mkpat loc (Ppat_constant (Pconst_integer (s, None)))
| PaInt32 loc s -> mkpat loc (Ppat_constant (Pconst_integer (s, Some 'l')))
| PaInt64 loc s -> mkpat loc (Ppat_constant (Pconst_integer (s, Some 'L')))
| PaNativeInt loc s -> mkpat loc (Ppat_constant (Pconst_integer (s, Some 'n')))
| PaFlo loc s -> mkpat loc (Ppat_constant (Pconst_float (remove_underscores s, None)))
| 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 ->
let ps = list_of_patt p [] in
let is_wildcard = fun [ <:patt< _ >> -> True | _ -> False ] in
let (wildcards,ps) = List.partition is_wildcard ps in
let is_closed = if wildcards = [] then Closed else Open in
mkpat loc (Ppat_record (List.map mklabpat ps, is_closed))
| PaStr loc s ->
mkpat loc (Ppat_constant (Pconst_string (string_of_string_token loc s) None))
| <: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 (conv_con s) None)
| PaLaz loc p -> mkpat loc (Ppat_lazy (patt p))
| PaMod loc m -> mkpat loc (Ppat_unpack (with_loc m loc))
| PaExc loc p -> mkpat loc (Ppat_exception (patt p))
| PaAtt loc s str e ->
let e = patt e in
{(e) with ppat_attributes = e.ppat_attributes @ [attribute loc s str]}
| PaEq _ _ _ | PaSem _ _ _ | PaCom _ _ _ | PaNil _ as p ->
error (loc_of_patt p) "invalid pattern" ]
and mklabpat =
fun
[ <:patt< $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 override_flag loc =
fun [ <:override_flag< ! >> -> Override
| <:override_flag<>> -> Fresh
| _ -> error loc "antiquotation not allowed here"
];
value list_of_opt_ctyp ot acc =
match ot with
[ <:ctyp<>> -> acc
| t -> list_of_ctyp t acc ];
value varify_constructors var_names =
let rec loop t =
let desc =
match t.ptyp_desc with
[
Ptyp_any -> Ptyp_any
| Ptyp_var x -> Ptyp_var x
| Ptyp_arrow label core_type core_type' ->
Ptyp_arrow label (loop core_type) (loop core_type')
| Ptyp_tuple lst -> Ptyp_tuple (List.map loop lst)
| Ptyp_constr ({ txt = Lident s }) []
when List.exists (fun x -> s = x.txt) var_names ->
Ptyp_var ("&" ^ s)
| Ptyp_constr longident lst ->
Ptyp_constr longident (List.map loop lst)
| Ptyp_object (lst, o) ->
Ptyp_object (List.map loop_object_field lst, o)
| Ptyp_class longident lst ->
Ptyp_class (longident, List.map loop lst)
| Ptyp_alias core_type string ->
Ptyp_alias(loop core_type, string)
| Ptyp_variant row_field_list flag lbl_lst_option ->
Ptyp_variant(List.map loop_row_field row_field_list, flag, lbl_lst_option)
| Ptyp_poly string_lst core_type ->
Ptyp_poly(string_lst, loop core_type)
| Ptyp_package longident lst ->
Ptyp_package(longident,List.map (fun (n,typ) -> (n,loop typ) ) lst)
| Ptyp_extension x ->
Ptyp_extension x
]
in
{(t) with ptyp_desc = desc}
and loop_object_field x =
match x with
[ Otag s a t -> Otag s a (loop t)
| Oinherit t -> Oinherit (loop t) ]
and loop_row_field x =
match x with
[ Rtag(label,attrs,flag,lst) ->
Rtag(label,attrs,flag,List.map loop lst)
| Rinherit t ->
Rinherit (loop t) ]
in
loop;
value rec expr =
fun
[ <:expr@loc< $x$.val >> ->
mkexp loc
(Pexp_apply (mkexp loc (Pexp_ident (lident_with_loc "!" loc)))
[(Nolabel, 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] ->
(mkexp loc (Pexp_construct (mkli loc (conv_con s) ml) None), l)
| [(loc, ml, <:expr< $lid:s$ >>) :: l] ->
(mkexp loc (Pexp_ident (mkli loc 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@sloc< $lid:s$ >> ->
let loc = Loc.merge loc_bp loc_ep
in (loc, mkexp loc (Pexp_field e1 (mkli sloc (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
let a =
match al with
[ [a] -> a
| _ -> mkexp loc (Pexp_tuple al) ]
in
mkexp loc (Pexp_construct li (Some a))
| 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) ]
| ExAre loc e1 e2 ->
mkexp loc
(Pexp_apply (mkexp loc (Pexp_ident (array_function loc "Array" "get")))
[(Nolabel, expr e1); (Nolabel, expr e2)])
| ExArr loc e -> mkexp loc (Pexp_array (List.map expr (list_of_expr e [])))
| ExAsf loc ->
mkexp loc (Pexp_assert (mkexp loc (Pexp_construct {txt=Lident "false"; loc=mkloc loc} None)))
| ExAss loc e v ->
let e =
match e with
[ <:expr@loc< $x$.val >> ->
Pexp_apply (mkexp loc (Pexp_ident (lident_with_loc ":=" loc)))
[(Nolabel, expr x); (Nolabel, 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 loc e1 e2 ->
Pexp_apply (mkexp loc (Pexp_ident (array_function loc "Array" "set")))
[(Nolabel, expr e1); (Nolabel, expr e2); (Nolabel, expr v)]
| <:expr< $id:(<:ident@lloc< $lid:lab$ >>)$ >> -> Pexp_setinstvar (with_loc lab lloc) (expr v)
| ExSte loc e1 e2 ->
Pexp_apply
(mkexp loc (Pexp_ident (array_function loc "String" "set")))
[(Nolabel, expr e1); (Nolabel, expr e2); (Nolabel, 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 (Pconst_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_coerce (expr e) t1 (ctyp t2))
| ExFlo loc s -> mkexp loc (Pexp_constant (Pconst_float (remove_underscores s, None)))
| ExFor loc p e1 e2 df el ->
let e3 = ExSeq loc el in
mkexp loc (Pexp_for (patt p) (expr e1) (expr e2) (mkdirection df) (expr e3))
| <:expr@loc< fun [ $PaLab _ lab po$ when $w$ -> $e$ ] >> ->
mkfun loc (Labelled lab) None (patt_of_lab loc lab po) e w
| <:expr@loc< fun [ $PaOlbi _ lab p e1$ when $w$ -> $e2$ ] >> ->
let lab = paolab lab p in
mkfun loc (Optional lab) (Some (expr e1)) (patt p) e2 w
| <:expr@loc< fun [ $PaOlb _ lab p$ when $w$ -> $e$ ] >> ->
let lab = paolab lab p in
mkfun loc (Optional lab) None (patt_of_lab loc lab p) e w
| ExFun loc a -> mkexp loc (Pexp_function (match_case a []))
| ExIfe loc e1 e2 e3 ->
mkexp loc (Pexp_ifthenelse (expr e1) (expr e2) (Some (expr e3)))
| ExInt loc s -> mkexp loc (Pexp_constant (Pconst_integer (s, None)))
| ExInt32 loc s -> mkexp loc (Pexp_constant (Pconst_integer (s, Some 'l')))
| ExInt64 loc s -> mkexp loc (Pexp_constant (Pconst_integer (s, Some 'L')))
| ExNativeInt loc s -> mkexp loc (Pexp_constant (Pconst_integer (s, Some 'n')))
| ExLab loc _ _ -> error loc "labeled expression not allowed here"
| ExLaz loc e -> mkexp loc (Pexp_lazy (expr e))
| ExLet loc rf bi e ->
let e = expr e in
match binding bi [] with
[ [] -> e
| bi -> mkexp loc (Pexp_let (mkrf rf) bi e) ]
| ExLmd loc i me e -> mkexp loc (Pexp_letmodule (with_loc i loc) (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 { pcstr_self = patt p; pcstr_fields = 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
[ <:rec_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) (with_loc s loc))
| ExSte loc e1 e2 ->
mkexp loc
(Pexp_apply (mkexp loc (Pexp_ident (array_function loc "String" "get")))
[(Nolabel, expr e1); (Nolabel, expr e2)])
| ExStr loc s ->
mkexp loc (Pexp_constant (Pconst_string (string_of_string_token loc s) None))
| 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) (ctyp t))
| <:expr@loc< () >> ->
mkexp loc (Pexp_construct (lident_with_loc "()" loc) None)
| <:expr@loc< $lid:s$ >> ->
mkexp loc (Pexp_ident (lident_with_loc s loc))
| <:expr@loc< $uid:s$ >> ->
mkexp loc (Pexp_construct (lident_with_loc (conv_con s) loc) None)
| ExVrn loc s -> mkexp loc (Pexp_variant (conv_con s) None)
| ExWhi loc e1 el ->
let e2 = ExSeq loc el in
mkexp loc (Pexp_while (expr e1) (expr e2))
| ExOpI loc i ov e ->
let fresh = override_flag loc ov in
mkexp loc (Pexp_open fresh (long_uident i) (expr e))
| <:expr@loc< (module $me$ : $pt$) >> ->
mkexp loc (Pexp_constraint (mkexp loc (Pexp_pack (module_expr me)),
mktyp loc (Ptyp_package (package_type pt))))
| <:expr@loc< (module $me$) >> ->
mkexp loc (Pexp_pack (module_expr me))
| ExFUN loc i e ->
mkexp loc (Pexp_newtype (with_loc i loc) (expr e))
| <:expr@loc< $_$,$_$ >> -> error loc "expr, expr: not allowed here"
| <:expr@loc< $_$;$_$ >> ->
error loc "expr; expr: not allowed here, use do {...} or [|...|] to surround them"
| ExAtt loc s str e ->
let e = expr e in
{(e) with pexp_attributes = e.pexp_attributes @ [attribute loc s str]}
| 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 -> (Labelled lab, expr_of_lab loc lab eo)
| ExOlb loc lab eo -> (Optional lab, expr_of_lab loc lab eo)
| e -> (Nolabel, expr e) ]
and binding x acc =
match x with
[ <:binding< $x$ and $y$ >> ->
binding x (binding y acc)
| <:binding@_loc< $pat:( <:patt@sloc< $lid:bind_name$ >> )$ = ($e$ : $TyTypePol _ vs ty$) >> ->
(* this code is not pretty because it is temporary *)
let rec id_to_string x =
match x with
[ <:ctyp@loc< $lid:x$ >> -> [with_loc x loc]
| <:ctyp< $x$ $y$ >> -> (id_to_string x) @ (id_to_string y)
| _ -> assert False]
in
let vars = id_to_string vs in
let ampersand_vars = List.map (fun x ->
{ loc = x.loc; txt = "&" ^ x.txt}) vars in
let ty' = varify_constructors vars (ctyp ty) in
let mkexp = mkexp _loc in
let mkpat = mkpat _loc in
let e = mkexp (Pexp_constraint (expr e) (ctyp ty)) in
let rec mk_newtypes x =
match x with
[ [newtype :: []] -> mkexp (Pexp_newtype(newtype, e))
| [newtype :: newtypes] ->
mkexp(Pexp_newtype (newtype,mk_newtypes newtypes))
| [] -> assert False]
in
let pat =
mkpat (Ppat_constraint (mkpat (Ppat_var (with_loc bind_name sloc)),
mktyp _loc (Ptyp_poly ampersand_vars ty')))
in
let e = mk_newtypes vars in
[{pvb_pat=pat; pvb_expr=e; pvb_attributes=[]; pvb_loc = mkloc _loc} :: acc]
| <:binding@_loc< $p$ = ($e$ : ! $vs$ . $ty$) >> ->
[{pvb_pat=patt <:patt< ($p$ : ! $vs$ . $ty$ ) >>;
pvb_expr=expr e;
pvb_attributes=[];
pvb_loc=mkloc _loc} :: acc]
| <:binding@_loc< $p$ = $e$ >> -> [{pvb_pat=patt p; pvb_expr=expr e; pvb_attributes=[];
pvb_loc=mkloc _loc} :: 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$ >> ->
[when_expr (patt p) e w :: acc]
| <:match_case<>> -> acc
| _ -> assert False ]
and when_expr p e w =
let g = match w with
[ <:expr<>> -> None
| g -> Some (expr g) ]
in
{pc_lhs = p; pc_guard = g; pc_rhs = expr e}
and mkfun loc lab def p e w =
let () =
match w with
[ <:expr<>> -> ()
| _ -> assert False ]
in
mkexp loc (Pexp_fun lab def p (expr e))
and mklabexp x acc =
match x with
[ <:rec_binding< $x$; $y$ >> ->
mklabexp x (mklabexp y acc)
| <:rec_binding< $i$ = $e$ >> -> [(ident ~conv_lid:conv_lab i, expr e) :: acc]
| _ -> assert False ]
and mkideexp x acc =
match x with
[ <:rec_binding<>> -> acc
| <:rec_binding< $x$; $y$ >> ->
mkideexp x (mkideexp y acc)
| <:rec_binding< $id:( <:ident@sloc< $lid:s$ >>)$ = $e$ >> -> [(with_loc s sloc, expr e) :: acc]
| _ -> assert False ]
and mktype_decl_or_ext x acc =
match x with
[ <:ctyp< $x$ and $y$ >> ->
mktype_decl_or_ext x (mktype_decl_or_ext y acc)
| Ast.TyDcl cloc 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
let td =
type_decl (with_loc c cloc) (List.fold_right optional_type_parameters tl [])
cl td cloc
in
match acc with
[ `Unknown -> `Dcl [td]
| `Dcl acc -> `Dcl [td :: acc]
| `Ext _ ->
error cloc "cannot mix type declaration and extension" ]
| Ast.TyExt cloc c tl td ->
match acc with
[ `Unknown ->
`Ext(type_ext (long_type_ident c)
(List.fold_right optional_type_parameters tl []) td cloc)
| `Dcl _ ->
error cloc "cannot mix type declaration and extension"
| `Ext _ ->
error cloc "only one type extension allowed" ]
| _ -> assert False ]
and module_type =
fun
[ <:module_type@loc<>> -> error loc "abstract/nil module type not allowed here"
| <:module_type@loc< $id:i$ >> -> mkmty loc (Pmty_ident (long_uident i))
| Ast.MtFun(loc, "*", Ast.MtNil _, mt) ->
mkmty loc (Pmty_functor (with_loc "*" loc) None (module_type mt))
| <:module_type@loc< functor ($n$ : $nt$) -> $mt$ >> ->
mkmty loc (Pmty_functor (with_loc n loc) (Some (module_type nt)) (module_type mt))
| <:module_type@loc< '$_$ >> -> error loc "module type variable not allowed here"
| <:module_type@loc< sig $sl$ end >> ->
mkmty loc (Pmty_signature (sig_item sl []))
| <:module_type@loc< $mt$ with $wc$ >> ->
mkmty loc (Pmty_with (module_type mt) (mkwithc wc []))
| <:module_type@loc< module type of $me$ >> ->
mkmty loc (Pmty_typeof (module_expr me))
| MtAtt loc s str e ->
let e = module_type e in
{(e) with pmty_attributes = e.pmty_attributes @ [attribute loc s str]}
| Ast.MtAlias(loc, id) ->
mkmty loc (Pmty_alias (long_uident id))
| <: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 { pext_name = with_loc (conv_con s) loc
; pext_kind = Pext_decl (Pcstr_tuple [], None)
; pext_attributes = []
; pext_loc = mkloc loc })
:: l]
| <:sig_item@loc< exception $uid:s$ of $t$ >> ->
[mksig loc (Psig_exception { pext_name = with_loc (conv_con s) loc
; pext_kind = Pext_decl (Pcstr_tuple (List.map ctyp (list_of_ctyp t [])), None)
; pext_attributes = []
; pext_loc = mkloc loc })
:: l]
| SgExc _ _ -> assert False (*FIXME*)
| SgExt loc n t sl -> [mksig loc (Psig_value (mkvalue_desc loc (with_loc n loc) t (list_of_meta_list sl))) :: l]
| SgInc loc mt -> [mksig loc (Psig_include {pincl_mod=module_type mt;
pincl_attributes=[];
pincl_loc = mkloc loc}) :: l]
| SgMod loc n mt -> [mksig loc (Psig_module {pmd_loc=mkloc loc; pmd_name=with_loc n loc; pmd_type=module_type mt; pmd_attributes=[]}) :: l]
| SgRecMod loc mb ->
[mksig loc (Psig_recmodule (module_sig_binding mb [])) :: l]
| SgMty loc n mt ->
let si =
match mt with
[ MtQuo _ _ -> None
| _ -> Some (module_type mt) ]
in
[mksig loc (Psig_modtype {pmtd_loc=mkloc loc; pmtd_name=with_loc n loc; pmtd_type=si; pmtd_attributes=[]}) :: l]
| SgOpn loc ov id ->
let fresh = override_flag loc ov in
[mksig loc (Psig_open {popen_override=fresh; popen_lid=long_uident id;
popen_attributes=[]; popen_loc = mkloc loc}) :: l]
| SgTyp loc rf tdl ->
let rf = mknrf rf in
let ty =
match mktype_decl_or_ext tdl `Unknown with
[ `Unknown -> Psig_type (rf, [])
| `Dcl l -> Psig_type (rf, l)
| `Ext e -> Psig_typext e ]
in
[mksig loc ty :: l]
| SgVal loc n t -> [mksig loc (Psig_value (mkvalue_desc loc (with_loc n loc) 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@loc< $s$ : $mt$ >> ->
[{pmd_loc=mkloc loc; pmd_name=with_loc s loc; pmd_type=module_type mt; pmd_attributes=[]} :: 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@loc< $s$ : $mt$ = $me$ >> ->
[{pmb_loc=mkloc loc;
pmb_name=with_loc s loc;
pmb_expr=
{pmod_loc=Location.none;
pmod_desc=Pmod_constraint(module_expr me,module_type mt);
pmod_attributes=[];
};
pmb_attributes=[]} :: acc]
| _ -> assert False ]
and module_expr =
fun
[ <:module_expr@loc<>> -> error loc "nil module expression"
| <:module_expr@loc< $id:i$ >> -> mkmod loc (Pmod_ident (long_uident i))
| <:module_expr@loc< $me1$ $me2$ >> ->
mkmod loc (Pmod_apply (module_expr me1) (module_expr me2))
| Ast.MeFun(loc, "*", Ast.MtNil _, me) ->
mkmod loc (Pmod_functor (with_loc "*" loc) None (module_expr me))
| <:module_expr@loc< functor ($n$ : $mt$) -> $me$ >> ->
mkmod loc (Pmod_functor (with_loc n loc) (Some (module_type mt)) (module_expr me))
| <:module_expr@loc< struct $sl$ end >> ->
mkmod loc (Pmod_structure (str_item sl []))
| <:module_expr@loc< ($me$ : $mt$) >> ->
mkmod loc (Pmod_constraint (module_expr me) (module_type mt))
| <:module_expr@loc< (value $e$ : $pt$) >> ->
mkmod loc (Pmod_unpack (
mkexp loc (Pexp_constraint (expr e,
mktyp loc (Ptyp_package (package_type pt))))))
| <:module_expr@loc< (value $e$) >> ->
mkmod loc (Pmod_unpack (expr e))
| MeAtt loc s str e ->
let e = module_expr e in
{(e) with pmod_attributes = e.pmod_attributes @ [attribute loc s str]}
| <: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 { pext_name = with_loc (conv_con s) loc
; pext_kind = Pext_decl (Pcstr_tuple [], None)
; pext_attributes = []
; pext_loc = mkloc loc })
:: l ]
| <:str_item@loc< exception $uid:s$ of $t$ >> ->
[mkstr loc (Pstr_exception { pext_name = with_loc (conv_con s) loc
; pext_kind = Pext_decl (Pcstr_tuple (List.map ctyp (list_of_ctyp t [])), None)
; pext_attributes = []
; pext_loc = mkloc loc })
:: l ]
| <:str_item@loc< exception $uid:s$ = $i$ >> ->
[mkstr loc (Pstr_exception { pext_name = with_loc (conv_con s) loc
; pext_kind = Pext_rebind (long_uident ~conv_con i)
; pext_attributes = []
; pext_loc = mkloc loc })
:: l ]
| <:str_item@loc< exception $uid:_$ of $_$ = $_$ >> ->
error loc "type in exception alias"
| StExc _ _ _ -> assert False (*FIXME*)
| StExp loc e -> [mkstr loc (Pstr_eval (expr e) []) :: l]
| StExt loc n t sl -> [mkstr loc (Pstr_primitive (mkvalue_desc loc (with_loc n loc) t (list_of_meta_list sl))) :: l]
| StInc loc me -> [mkstr loc (Pstr_include {pincl_mod=module_expr me;
pincl_attributes=[];
pincl_loc=mkloc loc}) :: l]
| StMod loc n me -> [mkstr loc (Pstr_module {pmb_loc=mkloc loc; pmb_name=with_loc n loc;pmb_expr=module_expr me;pmb_attributes=[]}) :: l]
| StRecMod loc mb ->
[mkstr loc (Pstr_recmodule (module_str_binding mb [])) :: l]
| StMty loc n mt ->
let si =
match mt with
[ MtQuo _ _ -> None
| _ -> Some (module_type mt) ]
in
[mkstr loc (Pstr_modtype {pmtd_loc=mkloc loc; pmtd_name=with_loc n loc; pmtd_type=si; pmtd_attributes=[]}) :: l]
| StOpn loc ov id ->
let fresh = override_flag loc ov in
[mkstr loc (Pstr_open {popen_override=fresh;
popen_lid=long_uident id;
popen_attributes=[];
popen_loc=mkloc loc}) :: l]
| StTyp loc rf tdl ->
let rf = mknrf rf in
let ty =
match mktype_decl_or_ext tdl `Unknown with
[ `Unknown -> Pstr_type (rf, [])
| `Dcl l -> Pstr_type (rf, l)
| `Ext e -> Pstr_typext e ]
in
[mkstr loc ty :: 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 ViNil 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_arrow (Labelled lab) (ctyp t) (class_type ct))
| CtFun loc (TyOlb _ lab t) ct ->
mkcty loc (Pcty_arrow (Optional lab) (ctyp t) (class_type ct))
| CtFun loc t ct -> mkcty loc (Pcty_arrow Nolabel (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 {
pcsig_self = ctyp t;
pcsig_fields = cil;
})
| CtAtt loc s str e ->
let e = class_type e in
{(e) with pcty_attributes = e.pcty_attributes @ [attribute loc s str]}
| 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 nloc name) params) ce ->
let params =
match params with
[ <:ctyp<>> -> []
| t -> class_parameters t [] ]
in
{pci_virt = mkvirtual vir;
pci_params = params;
pci_name = with_loc name nloc;
pci_expr = class_expr ce;
pci_loc = mkloc loc;
pci_attributes = []
}
| ce -> error (loc_of_class_expr ce) "bad class definition" ]
and class_info_class_type ci =
match ci with
[ CtEq _ (CtCon loc vir (IdLid nloc name) params) ct |
CtCol _ (CtCon loc vir (IdLid nloc name) params) ct ->
let params =
match params with
[ <:ctyp<>> -> []
| t -> class_parameters t [] ]
in
{pci_virt = mkvirtual vir;
pci_params = params;
pci_name = with_loc name nloc;
pci_expr = class_type ct;
pci_attributes = [];
pci_loc = mkloc loc
}
| 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 -> [mkctf loc (Pctf_constraint (ctyp t1, ctyp t2)) :: l]
| <:class_sig_item< $csg1$; $csg2$ >> ->
class_sig_item csg1 (class_sig_item csg2 l)
| CgInh loc ct -> [mkctf loc (Pctf_inherit (class_type ct)) :: l]
| CgMth loc s pf t ->
[mkctf loc (Pctf_method (with_loc s loc, mkprivate pf, Concrete, mkpolytype (ctyp t))) :: l]
| CgVal loc s b v t ->
[mkctf loc (Pctf_val (with_loc s loc, mkmutable b, mkvirtual v, ctyp t)) :: l]
| CgVir loc s b t ->
[mkctf loc (Pctf_method (with_loc s loc, mkprivate b, Virtual, mkpolytype (ctyp t))) :: 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
mkcl loc (Pcl_apply (class_expr ce) el)
| CeCon loc ViNil id tl ->
mkcl loc
(Pcl_constr (long_class_ident id) (List.map ctyp (list_of_opt_ctyp tl [])))
| CeFun loc (PaLab _ lab po) ce ->
mkcl loc
(Pcl_fun (Labelled lab) None (patt_of_lab loc lab po) (class_expr ce))
| CeFun loc (PaOlbi _ lab p e) ce ->
let lab = paolab lab p in
mkcl loc (Pcl_fun (Optional lab) (Some (expr e)) (patt p) (class_expr ce))
| CeFun loc (PaOlb _ lab p) ce ->
let lab = paolab lab p in
mkcl loc
(Pcl_fun (Optional lab) None (patt_of_lab loc lab p) (class_expr ce))
| CeFun loc p ce -> mkcl loc (Pcl_fun Nolabel None (patt p) (class_expr ce))
| CeLet loc rf bi ce ->
mkcl 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
mkcl loc (Pcl_structure {
pcstr_self = patt p;
pcstr_fields = cil;
})
| CeTyc loc ce ct ->
mkcl loc (Pcl_constraint (class_expr ce) (class_type ct))
| CeAtt loc s str e ->
let e = class_expr e in
{(e) with pcl_attributes = e.pcl_attributes @ [attribute loc s str]}
| 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 -> [mkcf loc (Pcf_constraint (ctyp t1, ctyp t2)) :: l]
| <:class_str_item< $cst1$; $cst2$ >> ->
class_str_item cst1 (class_str_item cst2 l)
| CrInh loc ov ce pb ->
let opb = if pb = "" then None else Some (with_loc pb loc) in
[mkcf loc (Pcf_inherit (override_flag loc ov) (class_expr ce) opb) :: l]
| CrIni loc e -> [mkcf loc (Pcf_initializer (expr e)) :: l]
| CrMth loc s ov pf 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
[mkcf loc (Pcf_method (with_loc s loc, mkprivate pf, Cfk_concrete (override_flag loc ov, e))) :: l]
| CrVal loc s ov mf e ->
[mkcf loc (Pcf_val (with_loc s loc, mkmutable mf, Cfk_concrete (override_flag loc ov, expr e))) :: l]
| CrVir loc s pf t ->
[mkcf loc (Pcf_method (with_loc s loc, mkprivate pf, Cfk_virtual (mkpolytype (ctyp t)))) :: l]
| CrVvr loc s mf t ->
[mkcf loc (Pcf_val (with_loc s loc, mkmutable mf, Cfk_virtual (ctyp t))) :: l]
| CrAnt _ _ -> assert False ];
value sig_item ast = sig_item ast [];
value str_item ast = str_item ast [];
value directive_arg =
fun
[ ExStr _ s -> Pdir_string s
| ExInt _ i -> Pdir_int (i, None)
| <:expr< True >> -> Pdir_bool True
| <:expr< False >> -> Pdir_bool False
| <:expr< >> -> Pdir_none
| e -> Pdir_ident (ident_noloc (ident_of_expr e)) ]
;
value phrase =
fun
[ StDir _ d arg -> Ptop_dir d (directive_arg arg)
| si -> Ptop_def (str_item si) ]
;
value attribute loc s str =
(with_loc s loc, PStr (str_item str));
value () =
attribute_fwd.val := attribute;
end;