213 lines
11 KiB
OCaml
213 lines
11 KiB
OCaml
open Camlp4; (* -*- 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 OCaml *)
|
|
(* source tree. *)
|
|
(* *)
|
|
(****************************************************************************)
|
|
|
|
(* Authors:
|
|
* - Nicolas Pouillard: initial version
|
|
*)
|
|
|
|
module Id = struct
|
|
value name = "Camlp4QuotationCommon";
|
|
value version = Sys.ocaml_version;
|
|
end;
|
|
|
|
module Make (Syntax : Sig.Camlp4Syntax)
|
|
(TheAntiquotSyntax : (Sig.Parser Syntax.Ast).SIMPLE)
|
|
= struct
|
|
open Sig;
|
|
include Syntax; (* Be careful an AntiquotSyntax module appears here *)
|
|
|
|
module MetaLocHere = Ast.Meta.MetaLoc;
|
|
module MetaLoc = struct
|
|
module Ast = Ast;
|
|
value loc_name = ref None;
|
|
value meta_loc_expr _loc loc =
|
|
match loc_name.val with
|
|
[ None -> <:expr< $lid:Loc.name.val$ >>
|
|
| Some "here" -> MetaLocHere.meta_loc_expr _loc loc
|
|
| Some x -> <:expr< $lid:x$ >> ];
|
|
value meta_loc_patt _loc _ = <:patt< _ >>;
|
|
end;
|
|
module MetaAst = Ast.Meta.Make MetaLoc;
|
|
module ME = MetaAst.Expr;
|
|
module MP = MetaAst.Patt;
|
|
|
|
value is_antiquot s =
|
|
let len = String.length s in
|
|
len > 2 && s.[0] = '\\' && s.[1] = '$';
|
|
|
|
value handle_antiquot_in_string s term parse loc decorate =
|
|
if is_antiquot s then
|
|
let pos = String.index s ':' in
|
|
let name = String.sub s 2 (pos - 2)
|
|
and code = String.sub s (pos + 1) (String.length s - pos - 1) in
|
|
decorate name (parse loc code)
|
|
else term;
|
|
|
|
value antiquot_expander = object
|
|
inherit Ast.map as super;
|
|
method patt = fun
|
|
[ <:patt@_loc< $anti:s$ >> | <:patt@_loc< $str:s$ >> as p ->
|
|
let mloc _loc = MetaLoc.meta_loc_patt _loc _loc in
|
|
handle_antiquot_in_string s p TheAntiquotSyntax.parse_patt _loc (fun n p ->
|
|
match n with
|
|
[ "antisig_item" -> <:patt< Ast.SgAnt $mloc _loc$ $p$ >>
|
|
| "antistr_item" -> <:patt< Ast.StAnt $mloc _loc$ $p$ >>
|
|
| "antictyp" -> <:patt< Ast.TyAnt $mloc _loc$ $p$ >>
|
|
| "antipatt" -> <:patt< Ast.PaAnt $mloc _loc$ $p$ >>
|
|
| "antiexpr" -> <:patt< Ast.ExAnt $mloc _loc$ $p$ >>
|
|
| "antimodule_type" -> <:patt< Ast.MtAnt $mloc _loc$ $p$ >>
|
|
| "antimodule_expr" -> <:patt< Ast.MeAnt $mloc _loc$ $p$ >>
|
|
| "anticlass_type" -> <:patt< Ast.CtAnt $mloc _loc$ $p$ >>
|
|
| "anticlass_expr" -> <:patt< Ast.CeAnt $mloc _loc$ $p$ >>
|
|
| "anticlass_sig_item" -> <:patt< Ast.CgAnt $mloc _loc$ $p$ >>
|
|
| "anticlass_str_item" -> <:patt< Ast.CrAnt $mloc _loc$ $p$ >>
|
|
| "antiwith_constr" -> <:patt< Ast.WcAnt $mloc _loc$ $p$ >>
|
|
| "antibinding" -> <:patt< Ast.BiAnt $mloc _loc$ $p$ >>
|
|
| "antirec_binding" -> <:patt< Ast.RbAnt $mloc _loc$ $p$ >>
|
|
| "antimatch_case" -> <:patt< Ast.McAnt $mloc _loc$ $p$ >>
|
|
| "antimodule_binding" -> <:patt< Ast.MbAnt $mloc _loc$ $p$ >>
|
|
| "antiident" -> <:patt< Ast.IdAnt $mloc _loc$ $p$ >>
|
|
| _ -> p ])
|
|
| p -> super#patt p ];
|
|
method expr = fun
|
|
[ <:expr@_loc< $anti:s$ >> | <:expr@_loc< $str:s$ >> as e ->
|
|
let mloc _loc = MetaLoc.meta_loc_expr _loc _loc in
|
|
handle_antiquot_in_string s e TheAntiquotSyntax.parse_expr _loc (fun n e ->
|
|
match n with
|
|
[ "`int" -> <:expr< string_of_int $e$ >>
|
|
| "`int32" -> <:expr< Int32.to_string $e$ >>
|
|
| "`int64" -> <:expr< Int64.to_string $e$ >>
|
|
| "`nativeint" -> <:expr< Nativeint.to_string $e$ >>
|
|
| "`flo" -> <:expr< Camlp4_import.Oprint.float_repres $e$ >>
|
|
| "`str" -> <:expr< Ast.safe_string_escaped $e$ >>
|
|
| "`chr" -> <:expr< Char.escaped $e$ >>
|
|
| "`bool" -> <:expr< Ast.IdUid $mloc _loc$ (if $e$ then "True" else "False") >>
|
|
| "liststr_item" -> <:expr< Ast.stSem_of_list $e$ >>
|
|
| "listsig_item" -> <:expr< Ast.sgSem_of_list $e$ >>
|
|
| "listclass_sig_item" -> <:expr< Ast.cgSem_of_list $e$ >>
|
|
| "listclass_str_item" -> <:expr< Ast.crSem_of_list $e$ >>
|
|
| "listmodule_expr" -> <:expr< Ast.meApp_of_list $e$ >>
|
|
| "listmodule_type" -> <:expr< Ast.mtApp_of_list $e$ >>
|
|
| "listmodule_binding" -> <:expr< Ast.mbAnd_of_list $e$ >>
|
|
| "listbinding" -> <:expr< Ast.biAnd_of_list $e$ >>
|
|
| "listbinding;" -> <:expr< Ast.biSem_of_list $e$ >>
|
|
| "listrec_binding" -> <:expr< Ast.rbSem_of_list $e$ >>
|
|
| "listclass_type" -> <:expr< Ast.ctAnd_of_list $e$ >>
|
|
| "listclass_expr" -> <:expr< Ast.ceAnd_of_list $e$ >>
|
|
| "listident" -> <:expr< Ast.idAcc_of_list $e$ >>
|
|
| "listctypand" -> <:expr< Ast.tyAnd_of_list $e$ >>
|
|
| "listctyp;" -> <:expr< Ast.tySem_of_list $e$ >>
|
|
| "listctyp*" -> <:expr< Ast.tySta_of_list $e$ >>
|
|
| "listctyp|" -> <:expr< Ast.tyOr_of_list $e$ >>
|
|
| "listctyp," -> <:expr< Ast.tyCom_of_list $e$ >>
|
|
| "listctyp&" -> <:expr< Ast.tyAmp_of_list $e$ >>
|
|
| "listwith_constr" -> <:expr< Ast.wcAnd_of_list $e$ >>
|
|
| "listmatch_case" -> <:expr< Ast.mcOr_of_list $e$ >>
|
|
| "listpatt," -> <:expr< Ast.paCom_of_list $e$ >>
|
|
| "listpatt;" -> <:expr< Ast.paSem_of_list $e$ >>
|
|
| "listexpr," -> <:expr< Ast.exCom_of_list $e$ >>
|
|
| "listexpr;" -> <:expr< Ast.exSem_of_list $e$ >>
|
|
| "antisig_item" -> <:expr< Ast.SgAnt $mloc _loc$ $e$ >>
|
|
| "antistr_item" -> <:expr< Ast.StAnt $mloc _loc$ $e$ >>
|
|
| "antictyp" -> <:expr< Ast.TyAnt $mloc _loc$ $e$ >>
|
|
| "antipatt" -> <:expr< Ast.PaAnt $mloc _loc$ $e$ >>
|
|
| "antiexpr" -> <:expr< Ast.ExAnt $mloc _loc$ $e$ >>
|
|
| "antimodule_type" -> <:expr< Ast.MtAnt $mloc _loc$ $e$ >>
|
|
| "antimodule_expr" -> <:expr< Ast.MeAnt $mloc _loc$ $e$ >>
|
|
| "anticlass_type" -> <:expr< Ast.CtAnt $mloc _loc$ $e$ >>
|
|
| "anticlass_expr" -> <:expr< Ast.CeAnt $mloc _loc$ $e$ >>
|
|
| "anticlass_sig_item" -> <:expr< Ast.CgAnt $mloc _loc$ $e$ >>
|
|
| "anticlass_str_item" -> <:expr< Ast.CrAnt $mloc _loc$ $e$ >>
|
|
| "antiwith_constr" -> <:expr< Ast.WcAnt $mloc _loc$ $e$ >>
|
|
| "antibinding" -> <:expr< Ast.BiAnt $mloc _loc$ $e$ >>
|
|
| "antirec_binding" -> <:expr< Ast.RbAnt $mloc _loc$ $e$ >>
|
|
| "antimatch_case" -> <:expr< Ast.McAnt $mloc _loc$ $e$ >>
|
|
| "antimodule_binding" -> <:expr< Ast.MbAnt $mloc _loc$ $e$ >>
|
|
| "antiident" -> <:expr< Ast.IdAnt $mloc _loc$ $e$ >>
|
|
| _ -> e ])
|
|
| e -> super#expr e ];
|
|
end;
|
|
|
|
value add_quotation name entry mexpr mpatt =
|
|
let entry_eoi = Gram.Entry.mk (Gram.Entry.name entry) in
|
|
let parse_quot_string entry loc s =
|
|
let q = Camlp4_config.antiquotations.val in
|
|
let () = Camlp4_config.antiquotations.val := True in
|
|
let res = Gram.parse_string entry loc s in
|
|
let () = Camlp4_config.antiquotations.val := q in
|
|
res in
|
|
let expand_expr loc loc_name_opt s =
|
|
let ast = parse_quot_string entry_eoi loc s in
|
|
let () = MetaLoc.loc_name.val := loc_name_opt in
|
|
let meta_ast = mexpr loc ast in
|
|
let exp_ast = antiquot_expander#expr meta_ast in
|
|
exp_ast in
|
|
let expand_str_item loc loc_name_opt s =
|
|
let exp_ast = expand_expr loc loc_name_opt s in
|
|
<:str_item@loc< $exp:exp_ast$ >> in
|
|
let expand_patt _loc loc_name_opt s =
|
|
let ast = parse_quot_string entry_eoi _loc s in
|
|
let meta_ast = mpatt _loc ast in
|
|
let exp_ast = antiquot_expander#patt meta_ast in
|
|
match loc_name_opt with
|
|
[ None -> exp_ast
|
|
| Some name ->
|
|
let rec subst_first_loc =
|
|
fun
|
|
[ <:patt@_loc< Ast.$uid:u$ $_$ >> -> <:patt< Ast.$uid:u$ $lid:name$ >>
|
|
| <:patt@_loc< $a$ $b$ >> -> <:patt< $subst_first_loc a$ $b$ >>
|
|
| p -> p ] in
|
|
subst_first_loc exp_ast ] in
|
|
do {
|
|
EXTEND Gram
|
|
entry_eoi:
|
|
[ [ x = entry; `EOI -> x ] ]
|
|
;
|
|
END;
|
|
Quotation.add name Quotation.DynAst.expr_tag expand_expr;
|
|
Quotation.add name Quotation.DynAst.patt_tag expand_patt;
|
|
Quotation.add name Quotation.DynAst.str_item_tag expand_str_item;
|
|
};
|
|
|
|
add_quotation "sig_item" sig_item_quot ME.meta_sig_item MP.meta_sig_item;
|
|
add_quotation "str_item" str_item_quot ME.meta_str_item MP.meta_str_item;
|
|
add_quotation "ctyp" ctyp_quot ME.meta_ctyp MP.meta_ctyp;
|
|
add_quotation "patt" patt_quot ME.meta_patt MP.meta_patt;
|
|
add_quotation "expr" expr_quot ME.meta_expr MP.meta_expr;
|
|
add_quotation "module_type" module_type_quot ME.meta_module_type MP.meta_module_type;
|
|
add_quotation "module_expr" module_expr_quot ME.meta_module_expr MP.meta_module_expr;
|
|
add_quotation "class_type" class_type_quot ME.meta_class_type MP.meta_class_type;
|
|
add_quotation "class_expr" class_expr_quot ME.meta_class_expr MP.meta_class_expr;
|
|
add_quotation "class_sig_item"
|
|
class_sig_item_quot ME.meta_class_sig_item MP.meta_class_sig_item;
|
|
add_quotation "class_str_item"
|
|
class_str_item_quot ME.meta_class_str_item MP.meta_class_str_item;
|
|
add_quotation "with_constr" with_constr_quot ME.meta_with_constr MP.meta_with_constr;
|
|
add_quotation "binding" binding_quot ME.meta_binding MP.meta_binding;
|
|
add_quotation "rec_binding" rec_binding_quot ME.meta_rec_binding MP.meta_rec_binding;
|
|
add_quotation "match_case" match_case_quot ME.meta_match_case MP.meta_match_case;
|
|
add_quotation "module_binding"
|
|
module_binding_quot ME.meta_module_binding MP.meta_module_binding;
|
|
add_quotation "ident" ident_quot ME.meta_ident MP.meta_ident;
|
|
add_quotation "rec_flag" rec_flag_quot ME.meta_rec_flag MP.meta_rec_flag;
|
|
add_quotation "private_flag" private_flag_quot ME.meta_private_flag MP.meta_private_flag;
|
|
add_quotation "row_var_flag" row_var_flag_quot ME.meta_row_var_flag MP.meta_row_var_flag;
|
|
add_quotation "mutable_flag" mutable_flag_quot ME.meta_mutable_flag MP.meta_mutable_flag;
|
|
add_quotation "virtual_flag" virtual_flag_quot ME.meta_virtual_flag MP.meta_virtual_flag;
|
|
add_quotation "override_flag" override_flag_quot ME.meta_override_flag MP.meta_override_flag;
|
|
add_quotation "direction_flag" direction_flag_quot ME.meta_direction_flag MP.meta_direction_flag;
|
|
|
|
end;
|