More explicit internal representation of attribute payload. Now also support patterns as payload [%id ? pat].
git-svn-id: http://caml.inria.fr/svn/ocaml/branches/extension_points@13919 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02master
parent
8df2057b46
commit
87d9d6c877
|
@ -1270,7 +1270,7 @@ value varify_constructors var_names =
|
||||||
;
|
;
|
||||||
|
|
||||||
value attribute loc s str =
|
value attribute loc s str =
|
||||||
(with_loc s loc, str_item str);
|
(with_loc s loc, PStr (str_item str));
|
||||||
|
|
||||||
value () =
|
value () =
|
||||||
attribute_fwd.val := attribute;
|
attribute_fwd.val := attribute;
|
||||||
|
|
|
@ -23,9 +23,8 @@
|
||||||
|
|
||||||
module Main : sig end = struct
|
module Main : sig end = struct
|
||||||
open Asttypes
|
open Asttypes
|
||||||
open Location
|
open! Location
|
||||||
open Parsetree
|
open Parsetree
|
||||||
open Longident
|
|
||||||
|
|
||||||
let fatal loc s =
|
let fatal loc s =
|
||||||
Location.print_error Format.err_formatter loc;
|
Location.print_error Format.err_formatter loc;
|
||||||
|
@ -122,7 +121,7 @@ module Main : sig end = struct
|
||||||
val mutable file = ""
|
val mutable file = ""
|
||||||
|
|
||||||
method source name = function
|
method source name = function
|
||||||
| [] ->
|
| PStr [] ->
|
||||||
let file =
|
let file =
|
||||||
if Filename.check_suffix file ".ml"
|
if Filename.check_suffix file ".ml"
|
||||||
then (Filename.chop_suffix file ".ml") ^ ".mli"
|
then (Filename.chop_suffix file ".ml") ^ ".mli"
|
||||||
|
@ -131,7 +130,7 @@ module Main : sig end = struct
|
||||||
else failwith "Unknown source extension"
|
else failwith "Unknown source extension"
|
||||||
in
|
in
|
||||||
file, path, name
|
file, path, name
|
||||||
| [{pstr_desc=Pstr_eval
|
| PStr [{pstr_desc=Pstr_eval
|
||||||
({pexp_desc=Pexp_apply
|
({pexp_desc=Pexp_apply
|
||||||
({pexp_desc=Pexp_constant(Const_string (file, _)); _},
|
({pexp_desc=Pexp_constant(Const_string (file, _)); _},
|
||||||
["", {pexp_desc=Pexp_ident{txt=lid;_}; _}]); _}, _); _}] ->
|
["", {pexp_desc=Pexp_ident{txt=lid;_}; _}]); _}, _); _}] ->
|
||||||
|
|
|
@ -38,7 +38,7 @@ module Main : sig end = struct
|
||||||
| Oval_string x -> str x
|
| Oval_string x -> str x
|
||||||
| Oval_int x -> int x
|
| Oval_int x -> int x
|
||||||
| Oval_char x -> char x
|
| Oval_char x -> char x
|
||||||
| Oval_float x -> float x
|
| Oval_float x -> Ast_helper.Convenience.float x
|
||||||
| Oval_list l -> list (List.map exp_of_out_value l)
|
| Oval_list l -> list (List.map exp_of_out_value l)
|
||||||
| Oval_array l -> Exp.array (List.map exp_of_out_value l)
|
| Oval_array l -> Exp.array (List.map exp_of_out_value l)
|
||||||
| Oval_constr (c, args) -> constr (lid_of_out_ident c) (List.map exp_of_out_value args)
|
| Oval_constr (c, args) -> constr (lid_of_out_ident c) (List.map exp_of_out_value args)
|
||||||
|
@ -61,9 +61,9 @@ module Main : sig end = struct
|
||||||
exit 2
|
exit 2
|
||||||
|
|
||||||
let get_exp loc = function
|
let get_exp loc = function
|
||||||
| [ {pstr_desc=Pstr_eval (e, _); _} ] -> e
|
| PStr [ {pstr_desc=Pstr_eval (e, _); _} ] -> e
|
||||||
| _ ->
|
| _ ->
|
||||||
Format.eprintf "%aExpression expected"
|
Format.eprintf "%aExpression expected@."
|
||||||
Location.print_error loc;
|
Location.print_error loc;
|
||||||
exit 2
|
exit 2
|
||||||
|
|
||||||
|
@ -90,14 +90,14 @@ module Main : sig end = struct
|
||||||
end;
|
end;
|
||||||
empty_str_item
|
empty_str_item
|
||||||
| Pstr_extension(({txt="eval.start";_},
|
| Pstr_extension(({txt="eval.start";_},
|
||||||
[{pstr_desc=Pstr_eval (e, _);_}]
|
PStr [{pstr_desc=Pstr_eval (e, _);_}]
|
||||||
), _) when get_lid e = Some "both" ->
|
), _) when get_lid e = Some "both" ->
|
||||||
eval_str_items <- Some true;
|
eval_str_items <- Some true;
|
||||||
empty_str_item
|
empty_str_item
|
||||||
| Pstr_extension(({txt="eval.start";_}, []), _) ->
|
| Pstr_extension(({txt="eval.start";_}, PStr []), _) ->
|
||||||
eval_str_items <- Some false;
|
eval_str_items <- Some false;
|
||||||
empty_str_item
|
empty_str_item
|
||||||
| Pstr_extension(({txt="eval.stop";_}, []), _) ->
|
| Pstr_extension(({txt="eval.stop";_}, PStr []), _) ->
|
||||||
eval_str_items <- None;
|
eval_str_items <- None;
|
||||||
empty_str_item
|
empty_str_item
|
||||||
| _ ->
|
| _ ->
|
||||||
|
|
|
@ -13,16 +13,14 @@ and a payload (written s below).
|
||||||
In the Parsetree, the identifier is represented as a single string
|
In the Parsetree, the identifier is represented as a single string
|
||||||
(without spaces).
|
(without spaces).
|
||||||
|
|
||||||
* The payload 's' is an OCaml structure (i.e. a list of structure items).
|
* The payload 's' can be one of three things:
|
||||||
Note that a payload can be empty or reduced to a single expression
|
|
||||||
(both cases are valid structures). To support attributes whose
|
|
||||||
payload needs to be a type expression, the special syntax:
|
|
||||||
|
|
||||||
: T
|
- An OCaml structure (i.e. a list of structure items). Note that a
|
||||||
|
structure can be empty or reduced to a single expression.
|
||||||
|
|
||||||
(where T is a type expression) is also accepted as a valid payload,
|
- A type expression, prefixed with the ":" character.
|
||||||
and is interpreted internally as the structure made of the single
|
|
||||||
expression (() : T).
|
- A pattern, prefixed with the "?" character.
|
||||||
|
|
||||||
|
|
||||||
Attributes on expressions, type expressions, module expressions, module type expressions,
|
Attributes on expressions, type expressions, module expressions, module type expressions,
|
||||||
|
|
|
@ -29,15 +29,15 @@
|
||||||
|
|
||||||
*)
|
*)
|
||||||
|
|
||||||
|
open Location
|
||||||
open Ast_helper
|
open Ast_helper
|
||||||
open Asttypes
|
open! Asttypes
|
||||||
open Parsetree
|
open Parsetree
|
||||||
open Longident
|
open Longident
|
||||||
open Location
|
|
||||||
|
|
||||||
let getenv loc arg =
|
let getenv loc arg =
|
||||||
match arg with
|
match arg with
|
||||||
| [{pstr_desc=Pstr_eval({pexp_desc = Pexp_construct ({txt = Lident sym; _}, None); _}, _); _}] ->
|
| PStr [{pstr_desc=Pstr_eval({pexp_desc = Pexp_construct ({txt = Lident sym; _}, None); _}, _); _}] ->
|
||||||
(try Sys.getenv sym with Not_found -> "")
|
(try Sys.getenv sym with Not_found -> "")
|
||||||
| _ ->
|
| _ ->
|
||||||
Format.eprintf "%a** IFDEF: bad syntax."
|
Format.eprintf "%a** IFDEF: bad syntax."
|
||||||
|
|
|
@ -11,7 +11,7 @@
|
||||||
*)
|
*)
|
||||||
|
|
||||||
open Asttypes
|
open Asttypes
|
||||||
open Location
|
open! Location
|
||||||
open Parsetree
|
open Parsetree
|
||||||
open Longident
|
open Longident
|
||||||
open Ast_helper
|
open Ast_helper
|
||||||
|
@ -81,7 +81,7 @@ let mapper =
|
||||||
method! expr e =
|
method! expr e =
|
||||||
let loc = e.pexp_loc in
|
let loc = e.pexp_loc in
|
||||||
match e.pexp_desc with
|
match e.pexp_desc with
|
||||||
| Pexp_extension({txt="js";_}, [{pstr_desc=Pstr_eval (e, _);_}]) ->
|
| Pexp_extension({txt="js";_}, PStr [{pstr_desc=Pstr_eval (e, _);_}]) ->
|
||||||
{< js = true >} # expr e
|
{< js = true >} # expr e
|
||||||
|
|
||||||
| Pexp_field (o, {txt = Lident meth; loc = _}) when js ->
|
| Pexp_field (o, {txt = Lident meth; loc = _}) when js ->
|
||||||
|
|
|
@ -67,9 +67,23 @@ module Main : sig end = struct
|
||||||
|
|
||||||
|
|
||||||
let get_exp loc = function
|
let get_exp loc = function
|
||||||
| [ {pstr_desc=Pstr_eval (e, _); _} ] -> e
|
| PStr [ {pstr_desc=Pstr_eval (e, _); _} ] -> e
|
||||||
| _ ->
|
| _ ->
|
||||||
Format.eprintf "%aExpression expected"
|
Format.eprintf "%aExpression expected@."
|
||||||
|
Location.print_error loc;
|
||||||
|
exit 2
|
||||||
|
|
||||||
|
let get_typ loc = function
|
||||||
|
| PTyp t -> t
|
||||||
|
| _ ->
|
||||||
|
Format.eprintf "%aType expected@."
|
||||||
|
Location.print_error loc;
|
||||||
|
exit 2
|
||||||
|
|
||||||
|
let get_pat loc = function
|
||||||
|
| PPat t -> t
|
||||||
|
| _ ->
|
||||||
|
Format.eprintf "%aPattern expected@."
|
||||||
Location.print_error loc;
|
Location.print_error loc;
|
||||||
exit 2
|
exit 2
|
||||||
|
|
||||||
|
@ -144,13 +158,11 @@ module Main : sig end = struct
|
||||||
| Pexp_extension({txt="expr";loc=l}, e) ->
|
| Pexp_extension({txt="expr";loc=l}, e) ->
|
||||||
(lifter !loc) # lift_Parsetree_expression (get_exp l e)
|
(lifter !loc) # lift_Parsetree_expression (get_exp l e)
|
||||||
| Pexp_extension({txt="pat";loc=l}, e) ->
|
| Pexp_extension({txt="pat";loc=l}, e) ->
|
||||||
let p = extract_str Parse.pattern "pattern" (get_exp l e) in
|
(lifter !loc) # lift_Parsetree_pattern (get_pat l e)
|
||||||
(lifter !loc) # lift_Parsetree_pattern p
|
| Pexp_extension({txt="str";_}, PStr e) ->
|
||||||
| Pexp_extension({txt="str";_}, e) ->
|
|
||||||
(lifter !loc) # lift_Parsetree_structure e
|
(lifter !loc) # lift_Parsetree_structure e
|
||||||
| Pexp_extension({txt="type";loc=l}, e) ->
|
| Pexp_extension({txt="type";loc=l}, e) ->
|
||||||
let p = extract_str Parse.core_type "type" (get_exp l e) in
|
(lifter !loc) # lift_Parsetree_core_type (get_typ l e)
|
||||||
(lifter !loc) # lift_Parsetree_core_type p
|
|
||||||
| _ ->
|
| _ ->
|
||||||
super # expr e
|
super # expr e
|
||||||
)
|
)
|
||||||
|
|
|
@ -2,7 +2,7 @@ let loc1 = Location.in_file "111"
|
||||||
let loc2 = Location.in_file "222"
|
let loc2 = Location.in_file "222"
|
||||||
|
|
||||||
let x = [%expr foobar]
|
let x = [%expr foobar]
|
||||||
let pat = [%pat "_ as x"]
|
let pat = [%pat? _ as x]
|
||||||
|
|
||||||
let e = [%expr fun (x, [%p pat]) -> x + [%e x] + 1]
|
let e = [%expr fun (x, [%p pat]) -> x + [%e x] + 1]
|
||||||
let () = Format.printf "%a@." (Printast.expression 0) e
|
let () = Format.printf "%a@." (Printast.expression 0) e
|
||||||
|
@ -16,6 +16,6 @@ let e = [%expr fun (x, [%p pat]) -> x + [%e x] + 1]
|
||||||
let () = Format.printf "%a@." (Printast.expression 0) e
|
let () = Format.printf "%a@." (Printast.expression 0) e
|
||||||
|
|
||||||
|
|
||||||
let mytype = [%type "int list"]
|
let mytype = [%type: int list]
|
||||||
let s = [%str type t = A of [%t mytype] | B of string]
|
let s = [%str type t = A of [%t mytype] | B of string]
|
||||||
let () = Format.printf "%a@." Printast.implementation s
|
let () = Format.printf "%a@." Printast.implementation s
|
||||||
|
|
|
@ -6,7 +6,7 @@ open Longident
|
||||||
let pendings = ref []
|
let pendings = ref []
|
||||||
|
|
||||||
let doc ppf = function
|
let doc ppf = function
|
||||||
| ({txt="doc";_}, [{pstr_desc=Pstr_eval(e, _); _}]) ->
|
| ({txt="doc";_}, PStr [{pstr_desc=Pstr_eval(e, _); _}]) ->
|
||||||
begin match e.pexp_desc with
|
begin match e.pexp_desc with
|
||||||
| Pexp_constant(Const_string (s, _)) ->
|
| Pexp_constant(Const_string (s, _)) ->
|
||||||
Format.fprintf ppf " --> %s@." s
|
Format.fprintf ppf " --> %s@." s
|
||||||
|
|
|
@ -6,7 +6,7 @@ open Longident
|
||||||
open Misc
|
open Misc
|
||||||
open Parsetree
|
open Parsetree
|
||||||
open Types
|
open Types
|
||||||
open Typedtree
|
open! Typedtree
|
||||||
open Ast_helper
|
open Ast_helper
|
||||||
|
|
||||||
let mli_attr l = Convenience.find_attr "mli" l
|
let mli_attr l = Convenience.find_attr "mli" l
|
||||||
|
@ -15,7 +15,7 @@ let map_flatten f l =
|
||||||
List.flatten (List.map f l)
|
List.flatten (List.map f l)
|
||||||
|
|
||||||
let is_abstract = function
|
let is_abstract = function
|
||||||
| [{pstr_desc=Pstr_eval({pexp_desc=Pexp_ident{txt=Lident "abstract"}},_)}] -> true
|
| PStr [{pstr_desc=Pstr_eval({pexp_desc=Pexp_ident{txt=Lident "abstract"}},_)}] -> true
|
||||||
| _ -> false
|
| _ -> false
|
||||||
|
|
||||||
let explicit_type_of_expr = function
|
let explicit_type_of_expr = function
|
||||||
|
@ -23,8 +23,8 @@ let explicit_type_of_expr = function
|
||||||
| _ -> []
|
| _ -> []
|
||||||
|
|
||||||
let explicit_type = function
|
let explicit_type = function
|
||||||
| [{pstr_desc=Pstr_eval({pexp_desc=Pexp_tuple el},_)}] -> map_flatten explicit_type_of_expr el
|
| PStr [{pstr_desc=Pstr_eval({pexp_desc=Pexp_tuple el},_)}] -> map_flatten explicit_type_of_expr el
|
||||||
| [{pstr_desc=Pstr_eval(e,_)}] -> explicit_type_of_expr e
|
| PStr [{pstr_desc=Pstr_eval(e,_)}] -> explicit_type_of_expr e
|
||||||
| _ -> []
|
| _ -> []
|
||||||
|
|
||||||
let rec structure l : Parsetree.signature =
|
let rec structure l : Parsetree.signature =
|
||||||
|
@ -98,12 +98,12 @@ and typ x : Parsetree.core_type =
|
||||||
|
|
||||||
let mli_of_ml ppf sourcefile =
|
let mli_of_ml ppf sourcefile =
|
||||||
Location.input_name := sourcefile;
|
Location.input_name := sourcefile;
|
||||||
Compile.init_path ();
|
Compmisc.init_path false;
|
||||||
let file = chop_extension_if_any sourcefile in
|
let file = chop_extension_if_any sourcefile in
|
||||||
let modulename = String.capitalize(Filename.basename file) in
|
let modulename = String.capitalize(Filename.basename file) in
|
||||||
Env.set_unit_name modulename;
|
Env.set_unit_name modulename;
|
||||||
let inputfile = Pparse.preprocess sourcefile in
|
let inputfile = Pparse.preprocess sourcefile in
|
||||||
let env = Compile.initial_env() in
|
let env = Compmisc.initial_env() in
|
||||||
let ast = Pparse.file ppf inputfile Parse.implementation Config.ast_impl_magic_number in
|
let ast = Pparse.file ppf inputfile Parse.implementation Config.ast_impl_magic_number in
|
||||||
let (str, _coerc) = Typemod.type_implementation sourcefile file modulename env ast in
|
let (str, _coerc) = Typemod.type_implementation sourcefile file modulename env ast in
|
||||||
let sg = structure str in
|
let sg = structure str in
|
||||||
|
|
|
@ -20,7 +20,7 @@
|
||||||
|
|
||||||
module Main : sig end = struct
|
module Main : sig end = struct
|
||||||
open Asttypes
|
open Asttypes
|
||||||
open Location
|
open! Location
|
||||||
open Parsetree
|
open Parsetree
|
||||||
open Ast_helper
|
open Ast_helper
|
||||||
open Ast_helper.Convenience
|
open Ast_helper.Convenience
|
||||||
|
|
|
@ -16,4 +16,4 @@ let _x = M.A
|
||||||
let _y : t = [1; 2]
|
let _y : t = [1; 2]
|
||||||
|
|
||||||
|
|
||||||
type loc = [%copy_typedef "../../parsing/location.mli" t]
|
type _loc = [%copy_typedef "../../parsing/location.mli" t]
|
||||||
|
|
|
@ -412,13 +412,13 @@ module Convenience = struct
|
||||||
try Some (snd (List.find (fun (x, _) -> x.txt = s) attrs))
|
try Some (snd (List.find (fun (x, _) -> x.txt = s) attrs))
|
||||||
with Not_found -> None
|
with Not_found -> None
|
||||||
|
|
||||||
let expr_of_struct = function
|
let expr_of_payload = function
|
||||||
| [{pstr_desc=Pstr_eval(e, _)}] -> Some e
|
| PStr [{pstr_desc=Pstr_eval(e, _)}] -> Some e
|
||||||
| _ -> None
|
| _ -> None
|
||||||
|
|
||||||
let find_attr_expr s attrs =
|
let find_attr_expr s attrs =
|
||||||
match find_attr s attrs with
|
match find_attr s attrs with
|
||||||
| Some e -> expr_of_struct e
|
| Some e -> expr_of_payload e
|
||||||
| None -> None
|
| None -> None
|
||||||
|
|
||||||
let has_attr s attrs =
|
let has_attr s attrs =
|
||||||
|
|
|
@ -361,6 +361,6 @@ module Convenience :
|
||||||
val get_lid: expression -> string option
|
val get_lid: expression -> string option
|
||||||
|
|
||||||
val has_attr: string -> attributes -> bool
|
val has_attr: string -> attributes -> bool
|
||||||
val find_attr: string -> attributes -> structure option
|
val find_attr: string -> attributes -> payload option
|
||||||
val find_attr_expr: string -> attributes -> expression option
|
val find_attr_expr: string -> attributes -> expression option
|
||||||
end
|
end
|
||||||
|
|
|
@ -409,9 +409,13 @@ class mapper =
|
||||||
|
|
||||||
method location l = l
|
method location l = l
|
||||||
|
|
||||||
method extension (s, e) = (map_loc this s, this # structure e)
|
method extension (s, e) = (map_loc this s, this # payload e)
|
||||||
method attribute (s, e) = (map_loc this s, this # structure e)
|
method attribute (s, e) = (map_loc this s, this # payload e)
|
||||||
method attributes l = List.map (this # attribute) l
|
method attributes l = List.map (this # attribute) l
|
||||||
|
method payload = function
|
||||||
|
| PStr x -> PStr (this # structure x)
|
||||||
|
| PTyp x -> PTyp (this # typ x)
|
||||||
|
| PPat x -> PPat (this # pat x)
|
||||||
end
|
end
|
||||||
|
|
||||||
class type main_entry_points =
|
class type main_entry_points =
|
||||||
|
|
|
@ -54,6 +54,7 @@ class mapper:
|
||||||
method constructor_declaration: constructor_declaration -> constructor_declaration
|
method constructor_declaration: constructor_declaration -> constructor_declaration
|
||||||
method label_declaration: label_declaration -> label_declaration
|
method label_declaration: label_declaration -> label_declaration
|
||||||
method value_binding: value_binding -> value_binding
|
method value_binding: value_binding -> value_binding
|
||||||
|
method payload: payload -> payload
|
||||||
end
|
end
|
||||||
|
|
||||||
class type main_entry_points =
|
class type main_entry_points =
|
||||||
|
|
|
@ -276,7 +276,7 @@ let wrap_exp_attrs body (ext, attrs) =
|
||||||
let body = {body with pexp_attributes = attrs @ body.pexp_attributes} in
|
let body = {body with pexp_attributes = attrs @ body.pexp_attributes} in
|
||||||
match ext with
|
match ext with
|
||||||
| None -> body
|
| None -> body
|
||||||
| Some id -> ghexp(Pexp_extension (id, [mkstrexp body []]))
|
| Some id -> ghexp(Pexp_extension (id, PStr [mkstrexp body []]))
|
||||||
|
|
||||||
let mkexp_attrs d attrs =
|
let mkexp_attrs d attrs =
|
||||||
wrap_exp_attrs (mkexp d) attrs
|
wrap_exp_attrs (mkexp d) attrs
|
||||||
|
@ -1978,10 +1978,10 @@ attr_id:
|
||||||
| single_attr_id DOT attr_id { mkloc ($1 ^ "." ^ $3.txt) (symbol_rloc())}
|
| single_attr_id DOT attr_id { mkloc ($1 ^ "." ^ $3.txt) (symbol_rloc())}
|
||||||
;
|
;
|
||||||
attribute:
|
attribute:
|
||||||
LBRACKETAT attr_id ext_arg RBRACKET { ($2, $3) }
|
LBRACKETAT attr_id payload RBRACKET { ($2, $3) }
|
||||||
;
|
;
|
||||||
post_item_attribute:
|
post_item_attribute:
|
||||||
LBRACKETATAT attr_id ext_arg RBRACKET { ($2, $3) }
|
LBRACKETATAT attr_id payload RBRACKET { ($2, $3) }
|
||||||
;
|
;
|
||||||
post_item_attributes:
|
post_item_attributes:
|
||||||
/* empty */ { [] }
|
/* empty */ { [] }
|
||||||
|
@ -1997,15 +1997,18 @@ ext_attributes:
|
||||||
| PERCENT attr_id attributes { Some $2, $3 }
|
| PERCENT attr_id attributes { Some $2, $3 }
|
||||||
;
|
;
|
||||||
extension:
|
extension:
|
||||||
LBRACKETPERCENT attr_id ext_arg RBRACKET { ($2, $3) }
|
LBRACKETPERCENT attr_id payload RBRACKET { ($2, $3) }
|
||||||
;
|
;
|
||||||
item_extension:
|
item_extension:
|
||||||
LBRACKETPERCENTPERCENT attr_id ext_arg RBRACKET { ($2, $3) }
|
LBRACKETPERCENTPERCENT attr_id payload RBRACKET { ($2, $3) }
|
||||||
;
|
;
|
||||||
ext_arg:
|
payload:
|
||||||
structure { $1 }
|
structure { PStr $1 }
|
||||||
| COLON core_type {
|
| COLON core_type { PTyp $2
|
||||||
[ mkstrexp (ghexp (Pexp_constraint (ghunit (), $2))) [] ]
|
(* [ mkstrexp (ghexp (Pexp_constraint (ghunit (), $2))) [] ] *)
|
||||||
|
}
|
||||||
|
| QUESTION pattern { PPat $2
|
||||||
|
(* [ mkstr(Pstr_value(Nonrecursive, [Vb.mk $2 (ghunit ())])) ] *)
|
||||||
}
|
}
|
||||||
;
|
;
|
||||||
%%
|
%%
|
||||||
|
|
|
@ -16,18 +16,23 @@ open Asttypes
|
||||||
|
|
||||||
(** {2 Extension points} *)
|
(** {2 Extension points} *)
|
||||||
|
|
||||||
type attribute = string loc * structure
|
type attribute = string loc * payload
|
||||||
(* [@id STRUCTURE]
|
(* [@id STRUCTURE]
|
||||||
[@@id STRUCTURE]
|
[@@id STRUCTURE]
|
||||||
*)
|
*)
|
||||||
|
|
||||||
and extension = string loc * structure
|
and extension = string loc * payload
|
||||||
(* [%id STRUCTURE]
|
(* [%id STRUCTURE]
|
||||||
[%%id STRUCTURE]
|
[%%id STRUCTURE]
|
||||||
*)
|
*)
|
||||||
|
|
||||||
and attributes = attribute list
|
and attributes = attribute list
|
||||||
|
|
||||||
|
and payload =
|
||||||
|
| PStr of structure
|
||||||
|
| PTyp of core_type
|
||||||
|
| PPat of pattern
|
||||||
|
|
||||||
(** {2 Core language} *)
|
(** {2 Core language} *)
|
||||||
|
|
||||||
(* Type expressions *)
|
(* Type expressions *)
|
||||||
|
|
|
@ -322,7 +322,7 @@ class printer ()= object(self:'self)
|
||||||
pp f "@[<hov2>(module@ %a@ with@ %a)@]" self#longident_loc lid
|
pp f "@[<hov2>(module@ %a@ with@ %a)@]" self#longident_loc lid
|
||||||
(self#list aux ~sep:"@ and@ ") cstrs)
|
(self#list aux ~sep:"@ and@ ") cstrs)
|
||||||
| Ptyp_extension (s, arg) ->
|
| Ptyp_extension (s, arg) ->
|
||||||
pp f "@[<2>(&%s@ %a)@]" s.txt self#structure arg
|
pp f "@[<2>(&%s@ %a)@]" s.txt self#payload arg
|
||||||
| _ -> self#paren true self#core_type f x
|
| _ -> self#paren true self#core_type f x
|
||||||
(********************pattern********************)
|
(********************pattern********************)
|
||||||
(* be cautious when use [pattern], [pattern1] is preferred *)
|
(* be cautious when use [pattern], [pattern1] is preferred *)
|
||||||
|
@ -618,7 +618,7 @@ class printer ()= object(self:'self)
|
||||||
| Pexp_variant (l,Some eo) ->
|
| Pexp_variant (l,Some eo) ->
|
||||||
pp f "@[<2>`%s@;%a@]" l self#simple_expr eo
|
pp f "@[<2>`%s@;%a@]" l self#simple_expr eo
|
||||||
| Pexp_extension (s, arg) ->
|
| Pexp_extension (s, arg) ->
|
||||||
pp f "@[<2>(&%s@ %a)@]" s.txt self#structure arg
|
pp f "@[<2>(&%s@ %a)@]" s.txt self#payload arg
|
||||||
| _ -> self#expression1 f x
|
| _ -> self#expression1 f x
|
||||||
method expression1 f x =
|
method expression1 f x =
|
||||||
if x.pexp_attributes <> [] then self#expression f x
|
if x.pexp_attributes <> [] then self#expression f x
|
||||||
|
@ -688,7 +688,7 @@ class printer ()= object(self:'self)
|
||||||
List.iter (self # attribute f) l
|
List.iter (self # attribute f) l
|
||||||
|
|
||||||
method attribute f (s, e) =
|
method attribute f (s, e) =
|
||||||
pp f "[@@%s %a]" s.txt self#structure e
|
pp f "[@@%s %a]" s.txt self#payload e
|
||||||
|
|
||||||
method value_description f x =
|
method value_description f x =
|
||||||
pp f "@[<hov2>%a%a@]" self#core_type x.pval_type
|
pp f "@[<hov2>%a%a@]" self#core_type x.pval_type
|
||||||
|
@ -951,6 +951,11 @@ class printer ()= object(self:'self)
|
||||||
|
|
||||||
method structure f x = self#list ~sep:"@\n" self#structure_item f x
|
method structure f x = self#list ~sep:"@\n" self#structure_item f x
|
||||||
|
|
||||||
|
method payload f = function
|
||||||
|
| PStr x -> self#structure f x
|
||||||
|
| PTyp x -> pp f ":"; self#core_type f x
|
||||||
|
| PPat x -> pp f "?"; self#pattern f x
|
||||||
|
|
||||||
(* transform [f = fun g h -> ..] to [f g h = ... ] could be improved *)
|
(* transform [f = fun g h -> ..] to [f g h = ... ] could be improved *)
|
||||||
method binding f {pvb_pat=p; pvb_expr=x; pvb_attributes=_} = (* TODO: print attributes *)
|
method binding f {pvb_pat=p; pvb_expr=x; pvb_attributes=_} = (* TODO: print attributes *)
|
||||||
let rec pp_print_pexp_function f x =
|
let rec pp_print_pexp_function f x =
|
||||||
|
|
|
@ -75,6 +75,7 @@ class printer :
|
||||||
(Format.formatter -> 'a -> unit) -> Format.formatter -> 'a -> unit
|
(Format.formatter -> 'a -> unit) -> Format.formatter -> 'a -> unit
|
||||||
method pattern : Format.formatter -> Parsetree.pattern -> unit
|
method pattern : Format.formatter -> Parsetree.pattern -> unit
|
||||||
method pattern1 : Format.formatter -> Parsetree.pattern -> unit
|
method pattern1 : Format.formatter -> Parsetree.pattern -> unit
|
||||||
|
method payload : Format.formatter -> Parsetree.payload -> unit
|
||||||
method private_flag : Format.formatter -> Asttypes.private_flag -> unit
|
method private_flag : Format.formatter -> Asttypes.private_flag -> unit
|
||||||
method rec_flag : Format.formatter -> Asttypes.rec_flag -> unit
|
method rec_flag : Format.formatter -> Asttypes.rec_flag -> unit
|
||||||
|
|
||||||
|
|
|
@ -177,7 +177,7 @@ let rec core_type i ppf x =
|
||||||
list i package_with ppf l;
|
list i package_with ppf l;
|
||||||
| Ptyp_extension (s, arg) ->
|
| Ptyp_extension (s, arg) ->
|
||||||
line i ppf "Ptyp_extension \"%s\"\n" s.txt;
|
line i ppf "Ptyp_extension \"%s\"\n" s.txt;
|
||||||
structure i ppf arg
|
payload i ppf arg
|
||||||
|
|
||||||
and package_with i ppf (s, t) =
|
and package_with i ppf (s, t) =
|
||||||
line i ppf "with type %a\n" fmt_longident_loc s;
|
line i ppf "with type %a\n" fmt_longident_loc s;
|
||||||
|
@ -228,7 +228,7 @@ and pattern i ppf x =
|
||||||
line i ppf "Ppat_unpack %a\n" fmt_string_loc s;
|
line i ppf "Ppat_unpack %a\n" fmt_string_loc s;
|
||||||
| Ppat_extension (s, arg) ->
|
| Ppat_extension (s, arg) ->
|
||||||
line i ppf "Ppat_extension \"%s\"\n" s.txt;
|
line i ppf "Ppat_extension \"%s\"\n" s.txt;
|
||||||
structure i ppf arg
|
payload i ppf arg
|
||||||
|
|
||||||
and expression i ppf x =
|
and expression i ppf x =
|
||||||
line i ppf "expression %a\n" fmt_location x.pexp_loc;
|
line i ppf "expression %a\n" fmt_location x.pexp_loc;
|
||||||
|
@ -352,7 +352,7 @@ and expression i ppf x =
|
||||||
expression i ppf e
|
expression i ppf e
|
||||||
| Pexp_extension (s, arg) ->
|
| Pexp_extension (s, arg) ->
|
||||||
line i ppf "Pexp_extension \"%s\"\n" s.txt;
|
line i ppf "Pexp_extension \"%s\"\n" s.txt;
|
||||||
structure i ppf arg
|
payload i ppf arg
|
||||||
|
|
||||||
and value_description i ppf x =
|
and value_description i ppf x =
|
||||||
line i ppf "value_description %a %a\n" fmt_string_loc x.pval_name fmt_location x.pval_loc;
|
line i ppf "value_description %a %a\n" fmt_string_loc x.pval_name fmt_location x.pval_loc;
|
||||||
|
@ -386,10 +386,15 @@ and attributes i ppf l =
|
||||||
List.iter
|
List.iter
|
||||||
(fun (s, arg) ->
|
(fun (s, arg) ->
|
||||||
line i ppf "attribute \"%s\"\n" s.txt;
|
line i ppf "attribute \"%s\"\n" s.txt;
|
||||||
structure (i + 1) ppf arg;
|
payload (i + 1) ppf arg;
|
||||||
)
|
)
|
||||||
l
|
l
|
||||||
|
|
||||||
|
and payload i ppf = function
|
||||||
|
| PStr x -> structure i ppf x
|
||||||
|
| PTyp x -> core_type i ppf x
|
||||||
|
| PPat x -> pattern i ppf x
|
||||||
|
|
||||||
and type_kind i ppf x =
|
and type_kind i ppf x =
|
||||||
match x with
|
match x with
|
||||||
| Ptype_abstract ->
|
| Ptype_abstract ->
|
||||||
|
@ -418,7 +423,7 @@ and class_type i ppf x =
|
||||||
class_type i ppf cl;
|
class_type i ppf cl;
|
||||||
| Pcty_extension (s, arg) ->
|
| Pcty_extension (s, arg) ->
|
||||||
line i ppf "Pcty_extension \"%s\"\n" s.txt;
|
line i ppf "Pcty_extension \"%s\"\n" s.txt;
|
||||||
structure i ppf arg
|
payload i ppf arg
|
||||||
|
|
||||||
and class_signature i ppf cs =
|
and class_signature i ppf cs =
|
||||||
line i ppf "class_signature\n";
|
line i ppf "class_signature\n";
|
||||||
|
@ -446,7 +451,7 @@ and class_type_field i ppf x =
|
||||||
core_type (i+1) ppf ct2;
|
core_type (i+1) ppf ct2;
|
||||||
| Pctf_extension (s, arg) ->
|
| Pctf_extension (s, arg) ->
|
||||||
line i ppf "Pctf_extension \"%s\"\n" s.txt;
|
line i ppf "Pctf_extension \"%s\"\n" s.txt;
|
||||||
structure i ppf arg
|
payload i ppf arg
|
||||||
|
|
||||||
and class_description i ppf x =
|
and class_description i ppf x =
|
||||||
line i ppf "class_description %a\n" fmt_location x.pci_loc;
|
line i ppf "class_description %a\n" fmt_location x.pci_loc;
|
||||||
|
@ -501,7 +506,7 @@ and class_expr i ppf x =
|
||||||
class_type i ppf ct;
|
class_type i ppf ct;
|
||||||
| Pcl_extension (s, arg) ->
|
| Pcl_extension (s, arg) ->
|
||||||
line i ppf "Pcl_extension \"%s\"\n" s.txt;
|
line i ppf "Pcl_extension \"%s\"\n" s.txt;
|
||||||
structure i ppf arg
|
payload i ppf arg
|
||||||
|
|
||||||
and class_structure i ppf { pcstr_self = p; pcstr_fields = l } =
|
and class_structure i ppf { pcstr_self = p; pcstr_fields = l } =
|
||||||
line i ppf "class_structure\n";
|
line i ppf "class_structure\n";
|
||||||
|
@ -534,7 +539,7 @@ and class_field i ppf x =
|
||||||
expression (i+1) ppf e;
|
expression (i+1) ppf e;
|
||||||
| Pcf_extension (s, arg) ->
|
| Pcf_extension (s, arg) ->
|
||||||
line i ppf "Pcf_extension \"%s\"\n" s.txt;
|
line i ppf "Pcf_extension \"%s\"\n" s.txt;
|
||||||
structure i ppf arg
|
payload i ppf arg
|
||||||
|
|
||||||
and class_field_kind i ppf = function
|
and class_field_kind i ppf = function
|
||||||
| Cfk_concrete (o, e) ->
|
| Cfk_concrete (o, e) ->
|
||||||
|
@ -577,7 +582,7 @@ and module_type i ppf x =
|
||||||
module_expr i ppf m;
|
module_expr i ppf m;
|
||||||
| Pmty_extension (s, arg) ->
|
| Pmty_extension (s, arg) ->
|
||||||
line i ppf "Pmod_extension \"%s\"\n" s.txt;
|
line i ppf "Pmod_extension \"%s\"\n" s.txt;
|
||||||
structure i ppf arg
|
payload i ppf arg
|
||||||
|
|
||||||
and signature i ppf x = list i signature_item ppf x
|
and signature i ppf x = list i signature_item ppf x
|
||||||
|
|
||||||
|
@ -623,10 +628,10 @@ and signature_item i ppf x =
|
||||||
| Psig_extension ((s, arg), attrs) ->
|
| Psig_extension ((s, arg), attrs) ->
|
||||||
line i ppf "Psig_extension \"%s\"\n" s.txt;
|
line i ppf "Psig_extension \"%s\"\n" s.txt;
|
||||||
attributes i ppf attrs;
|
attributes i ppf attrs;
|
||||||
structure i ppf arg
|
payload i ppf arg
|
||||||
| Psig_attribute (s, arg) ->
|
| Psig_attribute (s, arg) ->
|
||||||
line i ppf "Psig_attribute \"%s\"\n" s.txt;
|
line i ppf "Psig_attribute \"%s\"\n" s.txt;
|
||||||
structure i ppf arg
|
payload i ppf arg
|
||||||
|
|
||||||
and modtype_declaration i ppf = function
|
and modtype_declaration i ppf = function
|
||||||
| None -> line i ppf "#abstract"
|
| None -> line i ppf "#abstract"
|
||||||
|
@ -675,7 +680,7 @@ and module_expr i ppf x =
|
||||||
expression i ppf e;
|
expression i ppf e;
|
||||||
| Pmod_extension (s, arg) ->
|
| Pmod_extension (s, arg) ->
|
||||||
line i ppf "Pmod_extension \"%s\"\n" s.txt;
|
line i ppf "Pmod_extension \"%s\"\n" s.txt;
|
||||||
structure i ppf arg
|
payload i ppf arg
|
||||||
|
|
||||||
and structure i ppf x = list i structure_item ppf x
|
and structure i ppf x = list i structure_item ppf x
|
||||||
|
|
||||||
|
@ -732,10 +737,10 @@ and structure_item i ppf x =
|
||||||
| Pstr_extension ((s, arg), attrs) ->
|
| Pstr_extension ((s, arg), attrs) ->
|
||||||
line i ppf "Pstr_extension \"%s\"\n" s.txt;
|
line i ppf "Pstr_extension \"%s\"\n" s.txt;
|
||||||
attributes i ppf attrs;
|
attributes i ppf attrs;
|
||||||
structure i ppf arg
|
payload i ppf arg
|
||||||
| Pstr_attribute (s, arg) ->
|
| Pstr_attribute (s, arg) ->
|
||||||
line i ppf "Pstr_attribute \"%s\"\n" s.txt;
|
line i ppf "Pstr_attribute \"%s\"\n" s.txt;
|
||||||
structure i ppf arg
|
payload i ppf arg
|
||||||
|
|
||||||
and module_declaration i ppf pmd =
|
and module_declaration i ppf pmd =
|
||||||
string_loc i ppf pmd.pmd_name;
|
string_loc i ppf pmd.pmd_name;
|
||||||
|
|
|
@ -19,3 +19,4 @@ val top_phrase : formatter -> toplevel_phrase -> unit;;
|
||||||
|
|
||||||
val expression: int -> formatter -> expression -> unit
|
val expression: int -> formatter -> expression -> unit
|
||||||
val structure: int -> formatter -> structure -> unit
|
val structure: int -> formatter -> structure -> unit
|
||||||
|
val payload: int -> formatter -> payload -> unit
|
||||||
|
|
|
@ -141,7 +141,7 @@ let attributes i ppf l =
|
||||||
List.iter
|
List.iter
|
||||||
(fun (s, arg) ->
|
(fun (s, arg) ->
|
||||||
line i ppf "attribute \"%s\"\n" s.txt;
|
line i ppf "attribute \"%s\"\n" s.txt;
|
||||||
Printast.structure (i + 1) ppf arg;
|
Printast.payload (i + 1) ppf arg;
|
||||||
)
|
)
|
||||||
l
|
l
|
||||||
|
|
||||||
|
@ -613,7 +613,7 @@ and signature_item i ppf x =
|
||||||
list i class_type_declaration ppf l;
|
list i class_type_declaration ppf l;
|
||||||
| Tsig_attribute (s, arg) ->
|
| Tsig_attribute (s, arg) ->
|
||||||
line i ppf "Psig_attribute \"%s\"\n" s.txt;
|
line i ppf "Psig_attribute \"%s\"\n" s.txt;
|
||||||
Printast.structure i ppf arg
|
Printast.payload i ppf arg
|
||||||
|
|
||||||
and module_declaration i ppf md =
|
and module_declaration i ppf md =
|
||||||
line i ppf "%a" fmt_ident md.md_id;
|
line i ppf "%a" fmt_ident md.md_id;
|
||||||
|
@ -719,7 +719,7 @@ and structure_item i ppf x =
|
||||||
module_expr i ppf me;
|
module_expr i ppf me;
|
||||||
| Tstr_attribute (s, arg) ->
|
| Tstr_attribute (s, arg) ->
|
||||||
line i ppf "Pstr_attribute \"%s\"\n" s.txt;
|
line i ppf "Pstr_attribute \"%s\"\n" s.txt;
|
||||||
Printast.structure i ppf arg
|
Printast.payload i ppf arg
|
||||||
|
|
||||||
and string_x_module_type i ppf (s, _, mty) =
|
and string_x_module_type i ppf (s, _, mty) =
|
||||||
ident i ppf s;
|
ident i ppf s;
|
||||||
|
|
|
@ -1993,7 +1993,7 @@ and type_expect_ ?in_function env sexp ty_expected =
|
||||||
Exp.fun_ ~loc
|
Exp.fun_ ~loc
|
||||||
l None
|
l None
|
||||||
(Pat.var ~loc (mknoloc "*opt*"))
|
(Pat.var ~loc (mknoloc "*opt*"))
|
||||||
(Exp.let_ ~loc Nonrecursive ~attrs:[mknoloc "#default",[]] [Vb.mk spat smatch] sexp)
|
(Exp.let_ ~loc Nonrecursive ~attrs:[mknoloc "#default",PStr []] [Vb.mk spat smatch] sexp)
|
||||||
in
|
in
|
||||||
type_expect ?in_function env sfun ty_expected
|
type_expect ?in_function env sfun ty_expected
|
||||||
(* TODO: keep attributes, call type_function directly *)
|
(* TODO: keep attributes, call type_function directly *)
|
||||||
|
|
|
@ -21,7 +21,7 @@ open Types
|
||||||
type partial = Partial | Total
|
type partial = Partial | Total
|
||||||
type optional = Required | Optional
|
type optional = Required | Optional
|
||||||
|
|
||||||
type attribute = string loc * Parsetree.structure
|
type attribute = Parsetree.attribute
|
||||||
type attributes = attribute list
|
type attributes = attribute list
|
||||||
|
|
||||||
type pattern =
|
type pattern =
|
||||||
|
|
|
@ -20,7 +20,7 @@ open Types
|
||||||
type partial = Partial | Total
|
type partial = Partial | Total
|
||||||
type optional = Required | Optional
|
type optional = Required | Optional
|
||||||
|
|
||||||
type attribute = string loc * Parsetree.structure
|
type attribute = Parsetree.attribute
|
||||||
type attributes = attribute list
|
type attributes = attribute list
|
||||||
|
|
||||||
type pattern =
|
type pattern =
|
||||||
|
|
Loading…
Reference in New Issue