The arument of attributes and extension nodes is now a structure, which is syntactically more general than an expression (through the embedding E -> [Pexp_eval E]).
git-svn-id: http://caml.inria.fr/svn/ocaml/branches/extension_points@13579 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02master
Alain Frisch
parent
4de999bd87
commit
eb4130e47c
|
|
@ -508,7 +508,7 @@ let rec push_defaults loc bindings cases partial =
|
|||
let pl = push_defaults exp.exp_loc bindings pl partial in
|
||||
[{c_lhs=pat; c_guard=None; c_rhs={exp with exp_desc = Texp_function(l, pl, partial)}}]
|
||||
| [{c_lhs=pat; c_guard=None;
|
||||
c_rhs={exp_attributes=["#default",_];
|
||||
c_rhs={exp_attributes=[{txt="#default"},_];
|
||||
exp_desc = Texp_let
|
||||
(Nonrecursive, binds, ({exp_desc = Texp_function _} as e2))}}] ->
|
||||
push_defaults loc (binds :: bindings) [{c_lhs=pat;c_guard=None;c_rhs=e2}] partial
|
||||
|
|
|
|||
|
|
@ -122,7 +122,7 @@ module Main : sig end = struct
|
|||
val mutable file = ""
|
||||
|
||||
method source name = function
|
||||
| {pexp_desc=Pexp_construct({txt=Lident "()";_},None); _} ->
|
||||
| [] ->
|
||||
let file =
|
||||
if Filename.check_suffix file ".ml"
|
||||
then (Filename.chop_suffix file ".ml") ^ ".mli"
|
||||
|
|
@ -131,9 +131,10 @@ module Main : sig end = struct
|
|||
else failwith "Unknown source extension"
|
||||
in
|
||||
file, path, name
|
||||
| {pexp_desc=Pexp_apply
|
||||
({pexp_desc=Pexp_constant(Const_string (file, _)); _},
|
||||
["", {pexp_desc=Pexp_ident{txt=lid;_}; _}]); _} ->
|
||||
| [{pstr_desc=Pstr_eval
|
||||
({pexp_desc=Pexp_apply
|
||||
({pexp_desc=Pexp_constant(Const_string (file, _)); _},
|
||||
["", {pexp_desc=Pexp_ident{txt=lid;_}; _}]); _}, _); _}] ->
|
||||
begin match List.rev (Longident.flatten lid) with
|
||||
| [] -> assert false
|
||||
| name :: path -> file, path, name
|
||||
|
|
@ -144,7 +145,7 @@ module Main : sig end = struct
|
|||
method! tydecl = function
|
||||
| {ptype_kind = Ptype_abstract;
|
||||
ptype_manifest =
|
||||
Some{ptyp_desc=Ptyp_extension("copy_typedef", arg); _};
|
||||
Some{ptyp_desc=Ptyp_extension({txt="copy_typedef";_}, arg); _};
|
||||
ptype_name = name; ptype_loc = loc; _
|
||||
} ->
|
||||
begin try
|
||||
|
|
@ -156,7 +157,7 @@ module Main : sig end = struct
|
|||
| td -> td
|
||||
|
||||
method! mtydecl = function
|
||||
| {pmtd_type = Some{pmty_desc=Pmty_extension("copy_typedef", arg);
|
||||
| {pmtd_type = Some{pmty_desc=Pmty_extension({txt="copy_typedef";_}, arg);
|
||||
pmty_loc=loc; _};
|
||||
pmtd_name = name; _
|
||||
} ->
|
||||
|
|
|
|||
|
|
@ -23,6 +23,7 @@
|
|||
|
||||
module Main : sig end = struct
|
||||
|
||||
open Location
|
||||
open Parsetree
|
||||
open Ast_helper
|
||||
open Outcometree
|
||||
|
|
@ -59,6 +60,13 @@ module Main : sig end = struct
|
|||
Errors.report_error Format.err_formatter exn;
|
||||
exit 2
|
||||
|
||||
let get_exp loc = function
|
||||
| [ {pstr_desc=Pstr_eval (e, _); _} ] -> e
|
||||
| _ ->
|
||||
Format.eprintf "%aExpression expected"
|
||||
Location.print_error loc;
|
||||
exit 2
|
||||
|
||||
let eval = object
|
||||
inherit Ast_mapper.mapper as super
|
||||
|
||||
|
|
@ -66,7 +74,8 @@ module Main : sig end = struct
|
|||
|
||||
method! structure_item i =
|
||||
match i.pstr_desc with
|
||||
| Pstr_extension(("eval.load", e0), _) ->
|
||||
| Pstr_extension(({txt="eval.load";loc}, e0), _) ->
|
||||
let e0 = get_exp loc e0 in
|
||||
let s =
|
||||
match get_str e0 with
|
||||
| Some s -> s
|
||||
|
|
@ -80,13 +89,15 @@ module Main : sig end = struct
|
|||
exit 2;
|
||||
end;
|
||||
empty_str_item
|
||||
| Pstr_extension(("eval.start", e), _) when get_lid e = Some "both" ->
|
||||
| Pstr_extension(({txt="eval.start";_},
|
||||
[{pstr_desc=Pstr_eval (e, _);_}]
|
||||
), _) when get_lid e = Some "both" ->
|
||||
eval_str_items <- Some true;
|
||||
empty_str_item
|
||||
| Pstr_extension(("eval.start", _), _) ->
|
||||
| Pstr_extension(({txt="eval.start";_}, []), _) ->
|
||||
eval_str_items <- Some false;
|
||||
empty_str_item
|
||||
| Pstr_extension(("eval.stop", _), _) ->
|
||||
| Pstr_extension(({txt="eval.stop";_}, []), _) ->
|
||||
eval_str_items <- None;
|
||||
empty_str_item
|
||||
| _ ->
|
||||
|
|
@ -103,7 +114,8 @@ module Main : sig end = struct
|
|||
|
||||
method! expr e =
|
||||
match e.pexp_desc with
|
||||
| Pexp_extension("eval", e0) ->
|
||||
| Pexp_extension({txt="eval";loc}, e0) ->
|
||||
let e0 = get_exp loc e0 in
|
||||
let last_result = ref None in
|
||||
let pop = !Toploop.print_out_phrase in
|
||||
Toploop.print_out_phrase := begin fun _ppf -> function
|
||||
|
|
|
|||
|
|
@ -5,19 +5,22 @@ This file describes the changes on the extension_points branch.
|
|||
|
||||
Attributes are "decorations" of the syntax tree which are ignored by
|
||||
the type-checker. An attribute is made of an identifier (written id)
|
||||
and an optional expression (written expr below).
|
||||
and a argument, which is an OCaml structure (i.e. a list of structure
|
||||
items), written s below.
|
||||
|
||||
The identifier can be a lowercase or uppercase identifier (including
|
||||
OCaml keywords) or a sequence of such atomic identifiers separated with
|
||||
a dots (whitespaces are allowed around the dots). In the Parsetree,
|
||||
the identifier is represented as a single string (without spaces).
|
||||
|
||||
Note: a structure can be empty, or reduced to a single expression.
|
||||
|
||||
Attributes on expressions, type expressions, module expressions, module type expressions,
|
||||
patterns, class expressions, class type expressions:
|
||||
|
||||
... [@id expr]
|
||||
... [@id s]
|
||||
|
||||
The same syntax [@id expr] is also available to add attributes on
|
||||
The same syntax [@id s] is also available to add attributes on
|
||||
constructors and labels in type declarations:
|
||||
|
||||
type t =
|
||||
|
|
@ -36,7 +39,7 @@ and id3 is attached to the int type expression. Example on records:
|
|||
|
||||
Attributes on items:
|
||||
|
||||
... [@@id expr]
|
||||
... [@@id s]
|
||||
|
||||
Items designate signature items, structure items, class fields,
|
||||
class type fields and also individual components of multiple
|
||||
|
|
@ -53,7 +56,7 @@ Attributes on items:
|
|||
Note: item attributes are currently not supported on Pstr_eval
|
||||
and Pstr_value structure items.
|
||||
|
||||
The [@@id expr] form, when used at the beginning of a signature or
|
||||
The [@@id s] form, when used at the beginning of a signature or
|
||||
structure, or after a double semi-colon (;;), defines an attribute
|
||||
which stands as a stand-alone signature or structure item (not
|
||||
attached to another item).
|
||||
|
|
@ -86,14 +89,14 @@ Two syntaxes exist for extension node:
|
|||
As expressions, type expressions, module expressions, module type expressions,
|
||||
patterns, class expressions, class type expressions:
|
||||
|
||||
[%id expr]
|
||||
[%id s]
|
||||
|
||||
As structure item, signature item, class field, class type field:
|
||||
|
||||
[%%id expr]
|
||||
[%%id s]
|
||||
|
||||
As other structure item, signature item, class field or class type
|
||||
field, attributes can be attached to a [%%id expr] extension node.
|
||||
field, attributes can be attached to a [%%id s] extension node.
|
||||
|
||||
|
||||
=== Alternative syntax for attributes and extensions on specific kinds of nodes
|
||||
|
|
@ -101,17 +104,17 @@ field, attributes can be attached to a [%%id expr] extension node.
|
|||
All expression constructions starting with a keyword (EXPR = KW REST) support an
|
||||
alternative syntax for attributes and/or extensions:
|
||||
|
||||
KW[@id expr]...[@id expr] REST
|
||||
KW[@id s]...[@id s] REST
|
||||
---->
|
||||
EXPR[@id expr]...[@id expr]
|
||||
EXPR[@id s]...[@id s]
|
||||
|
||||
KW%id REST
|
||||
---->
|
||||
[%id EXPR]
|
||||
|
||||
KW%id[@id expr]...[@id expr] REST
|
||||
KW%id[@id s]...[@id s] REST
|
||||
---->
|
||||
[%id EXPR[@id expr]...[@id expr]]
|
||||
[%id EXPR[@id s]...[@id s]]
|
||||
|
||||
|
||||
where KW can stand for:
|
||||
|
|
|
|||
|
|
@ -35,11 +35,11 @@ open Parsetree
|
|||
open Longident
|
||||
open Location
|
||||
|
||||
let getenv arg =
|
||||
let getenv loc arg =
|
||||
match arg with
|
||||
| {pexp_desc = Pexp_construct ({txt = Lident sym; _}, None); _} ->
|
||||
| [{pstr_desc=Pstr_eval({pexp_desc = Pexp_construct ({txt = Lident sym; _}, None); _}, _); _}] ->
|
||||
(try Sys.getenv sym with Not_found -> "")
|
||||
| {pexp_loc = loc; _} ->
|
||||
| _ ->
|
||||
Format.eprintf "%a** IFDEF: bad syntax."
|
||||
Location.print_error loc;
|
||||
exit 2
|
||||
|
|
@ -55,8 +55,8 @@ let ifdef =
|
|||
method eval_attributes =
|
||||
List.for_all
|
||||
(function
|
||||
| "IFDEF", arg -> getenv arg <> ""
|
||||
| "IFNDEF", arg -> getenv arg = ""
|
||||
| {txt="IFDEF"; loc}, arg -> getenv loc arg <> ""
|
||||
| {txt="IFNDEF"; loc}, arg -> getenv loc arg = ""
|
||||
| _ -> true)
|
||||
|
||||
method filter_constr cd = this # eval_attributes cd.pcd_attributes
|
||||
|
|
@ -71,32 +71,32 @@ let ifdef =
|
|||
List.fold_right
|
||||
(fun c rest ->
|
||||
match c with
|
||||
| {pc_guard=Some {pexp_desc=Pexp_extension("IFDEF", arg); _}; _} ->
|
||||
if getenv arg = "" then rest else {c with pc_guard=None} :: rest
|
||||
| {pc_guard=Some {pexp_desc=Pexp_extension({txt="IFDEF";loc}, arg); _}; _} ->
|
||||
if getenv loc arg = "" then rest else {c with pc_guard=None} :: rest
|
||||
| c -> c :: rest
|
||||
) l []
|
||||
|
||||
method! structure_item i =
|
||||
match i.pstr_desc, stack with
|
||||
| Pstr_extension(("IFDEF", arg), _), _ ->
|
||||
stack <- (getenv arg <> "") :: stack;
|
||||
| Pstr_extension(({txt="IFDEF";loc}, arg), _), _ ->
|
||||
stack <- (getenv loc arg <> "") :: stack;
|
||||
empty_str_item
|
||||
| Pstr_extension(("ELSE", _), _), (hd :: tl) ->
|
||||
| Pstr_extension(({txt="ELSE";loc=_}, _), _), (hd :: tl) ->
|
||||
stack <- not hd :: tl;
|
||||
empty_str_item
|
||||
| Pstr_extension(("END", _), _), _ :: tl ->
|
||||
| Pstr_extension(({txt="END";loc=_}, _), _), _ :: tl ->
|
||||
stack <- tl;
|
||||
empty_str_item
|
||||
| Pstr_extension((("ELSE"|"END"), _), _), [] ->
|
||||
| Pstr_extension(({txt="ELSE"|"END";loc}, _), _), [] ->
|
||||
Format.printf "%a** IFDEF: mo matching [%%%%IFDEF]"
|
||||
Location.print_error i.pstr_loc;
|
||||
Location.print_error loc;
|
||||
exit 2
|
||||
| _, (true :: _ | []) -> super # structure_item i
|
||||
| _, false :: _ -> empty_str_item
|
||||
|
||||
method! expr = function
|
||||
| {pexp_desc = Pexp_extension("GETENV", arg); pexp_loc = loc; _} ->
|
||||
Exp.constant ~loc (Const_string (getenv arg, None))
|
||||
| {pexp_desc = Pexp_extension({txt="GETENV";loc=l}, arg); pexp_loc = loc; _} ->
|
||||
Exp.constant ~loc (Const_string (getenv l arg, None))
|
||||
| x -> super # expr x
|
||||
end
|
||||
|
||||
|
|
|
|||
|
|
@ -81,7 +81,7 @@ let mapper =
|
|||
method! expr e =
|
||||
let loc = e.pexp_loc in
|
||||
match e.pexp_desc with
|
||||
| Pexp_extension("js", e) ->
|
||||
| Pexp_extension({txt="js";_}, [{pstr_desc=Pstr_eval (e, _);_}]) ->
|
||||
{< js = true >} # expr e
|
||||
|
||||
| Pexp_field (o, {txt = Lident meth; loc = _}) when js ->
|
||||
|
|
|
|||
|
|
@ -8,10 +8,10 @@
|
|||
[%expr ...] maps to code which creates the expression represented by ...
|
||||
[%pat "..."] maps to code which creates the pattern represented by ...
|
||||
[%pat "..."] maps to code which creates the pattern represented by ...
|
||||
[%str "..."] maps to code which creates the structure represented by ...
|
||||
[%str ...] maps to code which creates the structure represented by ...
|
||||
[type "..."] maps to code which creates the core type represented by ...
|
||||
|
||||
Note that except for the expr expander, the argument needs to be
|
||||
Note that except for the expr and str expander, the argument needs to be
|
||||
a string literal (it can also be a quoted string, of course), which
|
||||
will be re-parse by the expander (in case of a parsing error,
|
||||
the location will be relative to the parsed string).
|
||||
|
|
@ -66,6 +66,13 @@ module Main : sig end = struct
|
|||
end
|
||||
|
||||
|
||||
let get_exp loc = function
|
||||
| [ {pstr_desc=Pstr_eval (e, _); _} ] -> e
|
||||
| _ ->
|
||||
Format.eprintf "%aExpression expected"
|
||||
Location.print_error loc;
|
||||
exit 2
|
||||
|
||||
let lifter loc =
|
||||
object
|
||||
inherit [_] Ast_lifter.lifter as super
|
||||
|
|
@ -76,21 +83,21 @@ module Main : sig end = struct
|
|||
|
||||
(* Support for antiquotations *)
|
||||
method! lift_Parsetree_expression = function
|
||||
| {pexp_desc=Pexp_extension("e", e); _} -> e
|
||||
| {pexp_desc=Pexp_extension({txt="e";loc}, e); _} -> get_exp loc e
|
||||
| x -> super # lift_Parsetree_expression x
|
||||
|
||||
method! lift_Parsetree_pattern = function
|
||||
| {ppat_desc=Ppat_extension("p", e); _} -> e
|
||||
| {ppat_desc=Ppat_extension({txt="p";loc}, e); _} -> get_exp loc e
|
||||
| x -> super # lift_Parsetree_pattern x
|
||||
|
||||
method! lift_Parsetree_core_type = function
|
||||
| {ptyp_desc=Ptyp_extension("t", e); _} -> e
|
||||
| {ptyp_desc=Ptyp_extension({txt="t";loc}, e); _} -> get_exp loc e
|
||||
| x -> super # lift_Parsetree_core_type x
|
||||
end
|
||||
|
||||
let loc = ref (evar "Location.none")
|
||||
let handle_attr = function
|
||||
| "metaloc", l -> loc := l
|
||||
| {txt="metaloc";loc=l}, e -> loc := get_exp l e
|
||||
| _ -> ()
|
||||
|
||||
let with_loc ?(attrs = []) f =
|
||||
|
|
@ -134,16 +141,15 @@ module Main : sig end = struct
|
|||
with_loc ~attrs:e.pexp_attributes
|
||||
(fun () ->
|
||||
match e.pexp_desc with
|
||||
| Pexp_extension("expr", e) ->
|
||||
(lifter !loc) # lift_Parsetree_expression e
|
||||
| Pexp_extension("pat", e) ->
|
||||
let p = extract_str Parse.pattern "pattern" e in
|
||||
| Pexp_extension({txt="expr";loc=l}, e) ->
|
||||
(lifter !loc) # lift_Parsetree_expression (get_exp 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 p
|
||||
| Pexp_extension("str", e) ->
|
||||
let p = extract_str Parse.implementation "structure" e in
|
||||
(lifter !loc) # lift_Parsetree_structure p
|
||||
| Pexp_extension("type", e) ->
|
||||
let p = extract_str Parse.core_type "type" e in
|
||||
| Pexp_extension({txt="str";_}, e) ->
|
||||
(lifter !loc) # lift_Parsetree_structure 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 p
|
||||
| _ ->
|
||||
super # expr e
|
||||
|
|
|
|||
|
|
@ -17,5 +17,5 @@ let () = Format.printf "%a@." (Printast.expression 0) e
|
|||
|
||||
|
||||
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
|
||||
|
|
|
|||
|
|
@ -6,13 +6,15 @@ open Longident
|
|||
let pendings = ref []
|
||||
|
||||
let doc ppf = function
|
||||
| ("doc", {pexp_desc=Pexp_constant(Const_string (s, _))}) ->
|
||||
Format.fprintf ppf " --> %s@." s
|
||||
| ("doc",
|
||||
{pexp_desc=Pexp_apply({pexp_desc=Pexp_ident{txt=Lident "section"}},
|
||||
["", {pexp_desc=Pexp_constant(Const_string (s, _))}])}
|
||||
) ->
|
||||
Format.fprintf ppf " ==== %s ====@." s
|
||||
| ({txt="doc";_}, [{pstr_desc=Pstr_eval(e, _); _}]) ->
|
||||
begin match e.pexp_desc with
|
||||
| Pexp_constant(Const_string (s, _)) ->
|
||||
Format.fprintf ppf " --> %s@." s
|
||||
| Pexp_apply({pexp_desc=Pexp_ident{txt=Lident "section"}},
|
||||
["", {pexp_desc=Pexp_constant(Const_string (s, _))}]) ->
|
||||
Format.fprintf ppf " ==== %s ====@." s
|
||||
| _ -> ()
|
||||
end
|
||||
| _ -> ()
|
||||
|
||||
let rec signature path ppf sg =
|
||||
|
|
|
|||
|
|
@ -31,10 +31,10 @@ module Main : sig end = struct
|
|||
exit 2
|
||||
|
||||
let param named name loc attrs =
|
||||
let default = find_attr "default" attrs in
|
||||
let default = find_attr_expr "default" attrs in
|
||||
let opt = has_attr "opt" attrs in
|
||||
let label =
|
||||
match find_attr "label" attrs with
|
||||
match find_attr_expr "label" attrs with
|
||||
| None -> if named then name else ""
|
||||
| Some e ->
|
||||
match get_lid e with
|
||||
|
|
|
|||
|
|
@ -399,9 +399,19 @@ module Convenience = struct
|
|||
Some (String.concat "." (Longident.flatten id))
|
||||
| _ -> None
|
||||
|
||||
let has_attr s attrs = List.mem_assoc s attrs
|
||||
|
||||
let find_attr s attrs =
|
||||
try Some (List.assoc s attrs)
|
||||
try Some (snd (List.find (fun (x, _) -> x.txt = s) attrs))
|
||||
with Not_found -> None
|
||||
|
||||
let expr_of_struct = function
|
||||
| [{pstr_desc=Pstr_eval(e, _)}] -> Some e
|
||||
| _ -> None
|
||||
|
||||
let find_attr_expr s attrs =
|
||||
match find_attr s attrs with
|
||||
| Some e -> expr_of_struct e
|
||||
| None -> None
|
||||
|
||||
let has_attr s attrs =
|
||||
find_attr s attrs <> None
|
||||
end
|
||||
|
|
|
|||
|
|
@ -353,5 +353,6 @@ module Convenience :
|
|||
val get_lid: expression -> string option
|
||||
|
||||
val has_attr: string -> attributes -> bool
|
||||
val find_attr: string -> attributes -> expression option
|
||||
val find_attr: string -> attributes -> structure option
|
||||
val find_attr_expr: string -> attributes -> expression option
|
||||
end
|
||||
|
|
|
|||
|
|
@ -191,13 +191,6 @@ module E = struct
|
|||
let apply_nolabs ?loc ?attrs f el = Exp.apply ?loc ?attrs f (List.map (fun e -> ("", e)) el)
|
||||
let strconst ?loc ?attrs x = Exp.constant ?loc ?attrs (Const_string (x, None))
|
||||
|
||||
let map_case sub {pc_lhs; pc_guard; pc_rhs} =
|
||||
{
|
||||
pc_lhs = sub # pat pc_lhs;
|
||||
pc_guard = map_opt (sub # expr) pc_guard;
|
||||
pc_rhs = sub # expr pc_rhs;
|
||||
}
|
||||
|
||||
let map sub {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} =
|
||||
let open Exp in
|
||||
let loc = sub # location loc in
|
||||
|
|
@ -207,10 +200,10 @@ module E = struct
|
|||
| Pexp_constant x -> constant ~loc ~attrs x
|
||||
| Pexp_let (r, pel, e) -> let_ ~loc ~attrs r (List.map (map_tuple (sub # pat) (sub # expr)) pel) (sub # expr e)
|
||||
| Pexp_fun (lab, def, p, e) -> fun_ ~loc ~attrs lab (map_opt (sub # expr) def) (sub # pat p) (sub # expr e)
|
||||
| Pexp_function pel -> function_ ~loc ~attrs (List.map (map_case sub) pel)
|
||||
| Pexp_function pel -> function_ ~loc ~attrs (sub # cases pel)
|
||||
| Pexp_apply (e, l) -> apply ~loc ~attrs (sub # expr e) (List.map (map_snd (sub # expr)) l)
|
||||
| Pexp_match (e, l) -> match_ ~loc ~attrs (sub # expr e) (List.map (map_case sub) l)
|
||||
| Pexp_try (e, l) -> try_ ~loc ~attrs (sub # expr e) (List.map (map_case sub) l)
|
||||
| Pexp_match (e, pel) -> match_ ~loc ~attrs (sub # expr e) (sub # cases pel)
|
||||
| Pexp_try (e, pel) -> try_ ~loc ~attrs (sub # expr e) (sub # cases pel)
|
||||
| Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub # expr) el)
|
||||
| Pexp_construct (lid, arg) -> construct ~loc ~attrs (map_loc sub lid) (map_opt (sub # expr) arg)
|
||||
| Pexp_variant (lab, eo) -> variant ~loc ~attrs lab (map_opt (sub # expr) eo)
|
||||
|
|
@ -399,11 +392,20 @@ class mapper =
|
|||
~loc:(this # location pld_loc)
|
||||
~attrs:(this # attributes pld_attributes)
|
||||
|
||||
method cases l = List.map (this # case) l
|
||||
method case {pc_lhs; pc_guard; pc_rhs} =
|
||||
{
|
||||
pc_lhs = this # pat pc_lhs;
|
||||
pc_guard = map_opt (this # expr) pc_guard;
|
||||
pc_rhs = this # expr pc_rhs;
|
||||
}
|
||||
|
||||
|
||||
|
||||
method location l = l
|
||||
|
||||
method extension (s, e) = (s, this # expr e)
|
||||
method attribute (s, e) = (s, this # expr e)
|
||||
method extension (s, e) = (map_loc this s, this # structure e)
|
||||
method attribute (s, e) = (map_loc this s, this # structure e)
|
||||
method attributes l = List.map (this # attribute) l
|
||||
end
|
||||
|
||||
|
|
|
|||
|
|
@ -18,6 +18,8 @@ open Parsetree
|
|||
|
||||
class mapper:
|
||||
object
|
||||
method case: case -> case
|
||||
method cases: case list -> case list
|
||||
method class_declaration: class_declaration -> class_declaration
|
||||
method class_description: class_description -> class_description
|
||||
method class_expr: class_expr -> class_expr
|
||||
|
|
|
|||
|
|
@ -276,7 +276,7 @@ let wrap_exp_attrs body (ext, attrs) =
|
|||
let body = {body with pexp_attributes = attrs @ body.pexp_attributes} in
|
||||
match ext with
|
||||
| None -> body
|
||||
| Some id -> ghexp(Pexp_extension (id, body))
|
||||
| Some id -> ghexp(Pexp_extension (id, [mkstrexp body []]))
|
||||
|
||||
let mkexp_attrs d attrs =
|
||||
wrap_exp_attrs (mkexp d) attrs
|
||||
|
|
@ -1966,14 +1966,14 @@ single_attr_id:
|
|||
;
|
||||
|
||||
attr_id:
|
||||
single_attr_id { $1 }
|
||||
| single_attr_id DOT attr_id { $1 ^ "." ^ $3 }
|
||||
single_attr_id { mkloc $1 (symbol_rloc()) }
|
||||
| single_attr_id DOT attr_id { mkloc ($1 ^ "." ^ $3.txt) (symbol_rloc())}
|
||||
;
|
||||
attribute:
|
||||
LBRACKETAT attr_id opt_expr RBRACKET { ($2, $3) }
|
||||
LBRACKETAT attr_id ext_arg RBRACKET { ($2, $3) }
|
||||
;
|
||||
post_item_attribute:
|
||||
LBRACKETATAT attr_id opt_expr RBRACKET { ($2, $3) }
|
||||
LBRACKETATAT attr_id ext_arg RBRACKET { ($2, $3) }
|
||||
;
|
||||
post_item_attributes:
|
||||
/* empty */ { [] }
|
||||
|
|
@ -1989,13 +1989,12 @@ ext_attributes:
|
|||
| PERCENT attr_id attributes { Some $2, $3 }
|
||||
;
|
||||
extension:
|
||||
LBRACKETPERCENT attr_id opt_expr RBRACKET { ($2, $3) }
|
||||
LBRACKETPERCENT attr_id ext_arg RBRACKET { ($2, $3) }
|
||||
;
|
||||
item_extension:
|
||||
LBRACKETPERCENTPERCENT attr_id opt_expr RBRACKET { ($2, $3) }
|
||||
LBRACKETPERCENTPERCENT attr_id ext_arg RBRACKET { ($2, $3) }
|
||||
;
|
||||
opt_expr:
|
||||
seq_expr { $1 }
|
||||
| { ghunit () }
|
||||
ext_arg:
|
||||
structure { $1 }
|
||||
;
|
||||
%%
|
||||
|
|
|
|||
|
|
@ -16,20 +16,14 @@ open Asttypes
|
|||
|
||||
(** {2 Extension points} *)
|
||||
|
||||
type attribute = string * expression
|
||||
(* [@id E]
|
||||
[@id] (expr = ())
|
||||
|
||||
[@@id EXPR]
|
||||
[@@id] (expr = ())
|
||||
type attribute = string loc * structure
|
||||
(* [@id STRUCTURE]
|
||||
[@@id STRUCTURE]
|
||||
*)
|
||||
|
||||
and extension = string * expression
|
||||
(* [%id E]
|
||||
[%id] (expr = ())
|
||||
|
||||
[%%id EXPR]
|
||||
[%%id] (expr = ())
|
||||
and extension = string loc * structure
|
||||
(* [%id STRUCTURE]
|
||||
[%%id STRUCTURE]
|
||||
*)
|
||||
|
||||
and attributes = attribute list
|
||||
|
|
@ -42,7 +36,7 @@ and core_type =
|
|||
{
|
||||
ptyp_desc: core_type_desc;
|
||||
ptyp_loc: Location.t;
|
||||
ptyp_attributes: attributes; (* ... [@id1 E1] [@id2 E2] *)
|
||||
ptyp_attributes: attributes; (* ... [@id1] [@id2] *)
|
||||
}
|
||||
|
||||
and core_type_desc =
|
||||
|
|
@ -102,7 +96,7 @@ and core_type_desc =
|
|||
| Ptyp_package of package_type
|
||||
(* (module S) *)
|
||||
| Ptyp_extension of extension
|
||||
(* [%id E] *)
|
||||
(* [%id] *)
|
||||
|
||||
and package_type = Longident.t loc * (Longident.t loc * core_type) list
|
||||
(*
|
||||
|
|
@ -126,7 +120,7 @@ and pattern =
|
|||
{
|
||||
ppat_desc: pattern_desc;
|
||||
ppat_loc: Location.t;
|
||||
ppat_attributes: attributes; (* ... [@id1 E1] [@id2 E2] *)
|
||||
ppat_attributes: attributes; (* ... [@id1] [@id2] *)
|
||||
}
|
||||
|
||||
and pattern_desc =
|
||||
|
|
@ -173,7 +167,7 @@ and pattern_desc =
|
|||
Note: (module P : S) is represented as Ppat_constraint(Ppat_unpack, Ptyp_package)
|
||||
*)
|
||||
| Ppat_extension of extension
|
||||
(* [%id E] *)
|
||||
(* [%id] *)
|
||||
|
||||
(* Value expressions *)
|
||||
|
||||
|
|
@ -181,7 +175,7 @@ and expression =
|
|||
{
|
||||
pexp_desc: expression_desc;
|
||||
pexp_loc: Location.t;
|
||||
pexp_attributes: attributes; (* ... [@id1 E1] [@id2 E2] *)
|
||||
pexp_attributes: attributes; (* ... [@id1] [@id2] *)
|
||||
}
|
||||
|
||||
and expression_desc =
|
||||
|
|
@ -287,7 +281,7 @@ and expression_desc =
|
|||
| Pexp_open of Longident.t loc * expression
|
||||
(* let open M in E *)
|
||||
| Pexp_extension of extension
|
||||
(* [%id E] *)
|
||||
(* [%id] *)
|
||||
|
||||
and case = (* (P -> E) or (P when E0 -> E) *)
|
||||
{
|
||||
|
|
@ -303,7 +297,7 @@ and value_description =
|
|||
pval_name: string loc;
|
||||
pval_type: core_type;
|
||||
pval_prim: string list;
|
||||
pval_attributes: attributes; (* ... [@@id1 E1] [@@id2 E2] *)
|
||||
pval_attributes: attributes; (* ... [@@id1] [@@id2] *)
|
||||
pval_loc: Location.t;
|
||||
}
|
||||
|
||||
|
|
@ -326,7 +320,7 @@ and type_declaration =
|
|||
ptype_kind: type_kind;
|
||||
ptype_private: private_flag; (* = private ... *)
|
||||
ptype_manifest: core_type option; (* = T *)
|
||||
ptype_attributes: attributes; (* ... [@@id1 E1] [@@id2 E2] *)
|
||||
ptype_attributes: attributes; (* ... [@@id1] [@@id2] *)
|
||||
ptype_loc: Location.t;
|
||||
}
|
||||
|
||||
|
|
@ -350,7 +344,7 @@ and label_declaration =
|
|||
pld_mutable: mutable_flag;
|
||||
pld_type: core_type;
|
||||
pld_loc: Location.t;
|
||||
pld_attributes: attributes; (* l [@id1 E1] [@id2 E2] : T *)
|
||||
pld_attributes: attributes; (* l [@id1] [@id2] : T *)
|
||||
}
|
||||
|
||||
(* { ...; l: T; ... } (mutable=Immutable)
|
||||
|
|
@ -365,7 +359,7 @@ and constructor_declaration =
|
|||
pcd_args: core_type list;
|
||||
pcd_res: core_type option;
|
||||
pcd_loc: Location.t;
|
||||
pcd_attributes: attributes; (* C [@id1 E1] [@id2 E2] of ... *)
|
||||
pcd_attributes: attributes; (* C [@id1] [@id2] of ... *)
|
||||
}
|
||||
(*
|
||||
| C of T1 * ... * Tn (res = None)
|
||||
|
|
@ -381,7 +375,7 @@ and class_type =
|
|||
{
|
||||
pcty_desc: class_type_desc;
|
||||
pcty_loc: Location.t;
|
||||
pcty_attributes: attributes; (* ... [@id1 E1] [@id2 E2] *)
|
||||
pcty_attributes: attributes; (* ... [@id1] [@id2] *)
|
||||
}
|
||||
|
||||
and class_type_desc =
|
||||
|
|
@ -396,7 +390,7 @@ and class_type_desc =
|
|||
?l:T -> CT (label = "?l")
|
||||
*)
|
||||
| Pcty_extension of extension
|
||||
(* [%id E] *)
|
||||
(* [%id] *)
|
||||
|
||||
and class_signature =
|
||||
{
|
||||
|
|
@ -411,7 +405,7 @@ and class_type_field =
|
|||
{
|
||||
pctf_desc: class_type_field_desc;
|
||||
pctf_loc: Location.t;
|
||||
pctf_attributes: attributes; (* ... [@@id1 E1] [@@id2 E2] *)
|
||||
pctf_attributes: attributes; (* ... [@@id1] [@@id2] *)
|
||||
}
|
||||
|
||||
and class_type_field_desc =
|
||||
|
|
@ -427,7 +421,7 @@ and class_type_field_desc =
|
|||
| Pctf_constraint of (core_type * core_type)
|
||||
(* constraint T1 = T2 *)
|
||||
| Pctf_extension of extension
|
||||
(* [%%id E] *)
|
||||
(* [%%id] *)
|
||||
|
||||
and 'a class_infos =
|
||||
{
|
||||
|
|
@ -436,7 +430,7 @@ and 'a class_infos =
|
|||
pci_name: string loc;
|
||||
pci_expr: 'a;
|
||||
pci_loc: Location.t;
|
||||
pci_attributes: attributes; (* ... [@@id1 E1] [@@id2 E2] *)
|
||||
pci_attributes: attributes; (* ... [@@id1] [@@id2] *)
|
||||
}
|
||||
(* class c = ...
|
||||
class ['a1,...,'an] c = ...
|
||||
|
|
@ -455,7 +449,7 @@ and class_expr =
|
|||
{
|
||||
pcl_desc: class_expr_desc;
|
||||
pcl_loc: Location.t;
|
||||
pcl_attributes: attributes; (* ... [@id1 E1] [@id2 E2] *)
|
||||
pcl_attributes: attributes; (* ... [@id1] [@id2] *)
|
||||
}
|
||||
|
||||
and class_expr_desc =
|
||||
|
|
@ -482,7 +476,7 @@ and class_expr_desc =
|
|||
| Pcl_constraint of class_expr * class_type
|
||||
(* (CE : CT) *)
|
||||
| Pcl_extension of extension
|
||||
(* [%id E] *)
|
||||
(* [%id] *)
|
||||
|
||||
and class_structure =
|
||||
{
|
||||
|
|
@ -497,7 +491,7 @@ and class_field =
|
|||
{
|
||||
pcf_desc: class_field_desc;
|
||||
pcf_loc: Location.t;
|
||||
pcf_attributes: attributes; (* ... [@id1 E1] [@id2 E2] *)
|
||||
pcf_attributes: attributes; (* ... [@id1] [@id2] *)
|
||||
}
|
||||
|
||||
and class_field_desc =
|
||||
|
|
@ -520,7 +514,7 @@ and class_field_desc =
|
|||
| Pcf_initializer of expression
|
||||
(* initializer E *)
|
||||
| Pcf_extension of extension
|
||||
(* [%id E] *)
|
||||
(* [%id] *)
|
||||
|
||||
and class_field_kind =
|
||||
| Cfk_virtual of core_type
|
||||
|
|
@ -536,7 +530,7 @@ and module_type =
|
|||
{
|
||||
pmty_desc: module_type_desc;
|
||||
pmty_loc: Location.t;
|
||||
pmty_attributes: attributes; (* ... [@id1 E1] [@id2 E2] *)
|
||||
pmty_attributes: attributes; (* ... [@id1] [@id2] *)
|
||||
}
|
||||
|
||||
and module_type_desc =
|
||||
|
|
@ -551,7 +545,7 @@ and module_type_desc =
|
|||
| Pmty_typeof of module_expr
|
||||
(* module type of ME *)
|
||||
| Pmty_extension of extension
|
||||
(* [%id E] *)
|
||||
(* [%id] *)
|
||||
|
||||
and signature = signature_item list
|
||||
|
||||
|
|
@ -587,17 +581,17 @@ and signature_item_desc =
|
|||
| Psig_class_type of class_type_declaration list
|
||||
(* class type ct1 = ... and ... and ctn = ... *)
|
||||
| Psig_attribute of attribute
|
||||
(* [@@id E]
|
||||
(* [@@id]
|
||||
(not attached to another item, i.e. after ";;" or at the beginning
|
||||
of the signature) *)
|
||||
| Psig_extension of extension * attributes
|
||||
(* [%%id E] *)
|
||||
(* [%%id] *)
|
||||
|
||||
and module_declaration =
|
||||
{
|
||||
pmd_name: string loc;
|
||||
pmd_type: module_type;
|
||||
pmd_attributes: attributes; (* ... [@@id1 E1] [@@id2 E2] *)
|
||||
pmd_attributes: attributes; (* ... [@@id1] [@@id2] *)
|
||||
}
|
||||
(* S : MT *)
|
||||
|
||||
|
|
@ -605,7 +599,7 @@ and module_type_declaration =
|
|||
{
|
||||
pmtd_name: string loc;
|
||||
pmtd_type: module_type option;
|
||||
pmtd_attributes: attributes; (* ... [@@id1 E1] [@@id2 E2] *)
|
||||
pmtd_attributes: attributes; (* ... [@@id1] [@@id2] *)
|
||||
}
|
||||
(* S = MT
|
||||
S (abstract module type declaration, pmtd_type = None)
|
||||
|
|
@ -630,7 +624,7 @@ and module_expr =
|
|||
{
|
||||
pmod_desc: module_expr_desc;
|
||||
pmod_loc: Location.t;
|
||||
pmod_attributes: attributes; (* ... [@id1 E1] [@id2 E2] *)
|
||||
pmod_attributes: attributes; (* ... [@id1] [@id2] *)
|
||||
}
|
||||
|
||||
and module_expr_desc =
|
||||
|
|
@ -647,7 +641,7 @@ and module_expr_desc =
|
|||
| Pmod_unpack of expression
|
||||
(* (val E) *)
|
||||
| Pmod_extension of extension
|
||||
(* [%id E] *)
|
||||
(* [%id] *)
|
||||
|
||||
and structure = structure_item list
|
||||
|
||||
|
|
@ -687,11 +681,11 @@ and structure_item_desc =
|
|||
| Pstr_include of module_expr * attributes
|
||||
(* include ME *)
|
||||
| Pstr_attribute of attribute
|
||||
(* [@@id E]
|
||||
(* [@@id]
|
||||
(not attached to another item, i.e. after ";;" or at the beginning
|
||||
of the structure) *)
|
||||
| Pstr_extension of extension * attributes
|
||||
(* [%%id E] *)
|
||||
(* [%%id] *)
|
||||
|
||||
and module_binding =
|
||||
{
|
||||
|
|
|
|||
|
|
@ -54,12 +54,6 @@ let is_predef_option = function
|
|||
| (Ldot (Lident "*predef*","option")) -> true
|
||||
| _ -> false
|
||||
|
||||
let is_unit = function
|
||||
| {pexp_desc=Pexp_construct ( {txt= Lident "()"; _},_);
|
||||
pexp_attributes = []
|
||||
} -> true
|
||||
| _ -> false
|
||||
|
||||
type space_formatter = (unit, Format.formatter, unit) format
|
||||
|
||||
let override = function
|
||||
|
|
@ -311,7 +305,7 @@ class printer ()= object(self:'self)
|
|||
pp f "@[<hov2>(module@ %a@ with@ %a)@]" self#longident_loc lid
|
||||
(self#list aux ~sep:"@ and@ ") cstrs)
|
||||
| Ptyp_extension (s, arg) ->
|
||||
pp f "@[<2>(&%s@ %a)@]" s self#expression arg
|
||||
pp f "@[<2>(&%s@ %a)@]" s.txt self#structure arg
|
||||
| _ -> self#paren true self#core_type f x
|
||||
(********************pattern********************)
|
||||
(* be cautious when use [pattern], [pattern1] is preferred *)
|
||||
|
|
@ -601,7 +595,7 @@ class printer ()= object(self:'self)
|
|||
| Pexp_variant (l,Some eo) ->
|
||||
pp f "@[<2>`%s@;%a@]" l self#simple_expr eo
|
||||
| Pexp_extension (s, arg) ->
|
||||
pp f "@[<2>(&%s@ %a)@]" s self#expression arg
|
||||
pp f "@[<2>(&%s@ %a)@]" s.txt self#structure arg
|
||||
| _ -> self#expression1 f x
|
||||
method expression1 f x =
|
||||
if x.pexp_attributes <> [] then self#expression f x
|
||||
|
|
@ -671,10 +665,7 @@ class printer ()= object(self:'self)
|
|||
List.iter (self # attribute f) l
|
||||
|
||||
method attribute f (s, e) =
|
||||
if is_unit e then
|
||||
pp f "[@@%s]" s
|
||||
else
|
||||
pp f "[@@%s %a]" s self#expression e
|
||||
pp f "[@@%s %a]" s.txt self#structure e
|
||||
|
||||
method value_description f x =
|
||||
pp f "@[<hov2>%a%a@]" self#core_type x.pval_type
|
||||
|
|
|
|||
|
|
@ -176,8 +176,8 @@ let rec core_type i ppf x =
|
|||
line i ppf "Ptyp_package %a\n" fmt_longident_loc s;
|
||||
list i package_with ppf l;
|
||||
| Ptyp_extension (s, arg) ->
|
||||
line i ppf "Ptyp_extension \"%s\"\n" s;
|
||||
expression i ppf arg
|
||||
line i ppf "Ptyp_extension \"%s\"\n" s.txt;
|
||||
structure i ppf arg
|
||||
|
||||
and package_with i ppf (s, t) =
|
||||
line i ppf "with type %a\n" fmt_longident_loc s;
|
||||
|
|
@ -227,8 +227,8 @@ and pattern i ppf x =
|
|||
| Ppat_unpack s ->
|
||||
line i ppf "Ppat_unpack %a\n" fmt_string_loc s;
|
||||
| Ppat_extension (s, arg) ->
|
||||
line i ppf "Ppat_extension \"%s\"\n" s;
|
||||
expression i ppf arg
|
||||
line i ppf "Ppat_extension \"%s\"\n" s.txt;
|
||||
structure i ppf arg
|
||||
|
||||
and expression i ppf x =
|
||||
line i ppf "expression %a\n" fmt_location x.pexp_loc;
|
||||
|
|
@ -350,8 +350,8 @@ and expression i ppf x =
|
|||
line i ppf "Pexp_open \"%a\"\n" fmt_longident_loc m;
|
||||
expression i ppf e
|
||||
| Pexp_extension (s, arg) ->
|
||||
line i ppf "Pexp_extension \"%s\"\n" s;
|
||||
expression i ppf arg
|
||||
line i ppf "Pexp_extension \"%s\"\n" s.txt;
|
||||
structure i ppf arg
|
||||
|
||||
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;
|
||||
|
|
@ -384,8 +384,8 @@ and attributes i ppf l =
|
|||
let i = i + 1 in
|
||||
List.iter
|
||||
(fun (s, arg) ->
|
||||
line i ppf "attribute \"%s\"\n" s;
|
||||
expression (i + 1) ppf arg;
|
||||
line i ppf "attribute \"%s\"\n" s.txt;
|
||||
structure (i + 1) ppf arg;
|
||||
)
|
||||
l
|
||||
|
||||
|
|
@ -416,8 +416,8 @@ and class_type i ppf x =
|
|||
core_type i ppf co;
|
||||
class_type i ppf cl;
|
||||
| Pcty_extension (s, arg) ->
|
||||
line i ppf "Pcty_extension \"%s\"\n" s;
|
||||
expression i ppf arg
|
||||
line i ppf "Pcty_extension \"%s\"\n" s.txt;
|
||||
structure i ppf arg
|
||||
|
||||
and class_signature i ppf cs =
|
||||
line i ppf "class_signature\n";
|
||||
|
|
@ -444,8 +444,8 @@ and class_type_field i ppf x =
|
|||
core_type (i+1) ppf ct1;
|
||||
core_type (i+1) ppf ct2;
|
||||
| Pctf_extension (s, arg) ->
|
||||
line i ppf "Pctf_extension \"%s\"\n" s;
|
||||
expression i ppf arg
|
||||
line i ppf "Pctf_extension \"%s\"\n" s.txt;
|
||||
structure i ppf arg
|
||||
|
||||
and class_description i ppf x =
|
||||
line i ppf "class_description %a\n" fmt_location x.pci_loc;
|
||||
|
|
@ -499,8 +499,8 @@ and class_expr i ppf x =
|
|||
class_expr i ppf ce;
|
||||
class_type i ppf ct;
|
||||
| Pcl_extension (s, arg) ->
|
||||
line i ppf "Pcl_extension \"%s\"\n" s;
|
||||
expression i ppf arg
|
||||
line i ppf "Pcl_extension \"%s\"\n" s.txt;
|
||||
structure i ppf arg
|
||||
|
||||
and class_structure i ppf { pcstr_self = p; pcstr_fields = l } =
|
||||
line i ppf "class_structure\n";
|
||||
|
|
@ -532,8 +532,8 @@ and class_field i ppf x =
|
|||
line i ppf "Pcf_initializer\n";
|
||||
expression (i+1) ppf e;
|
||||
| Pcf_extension (s, arg) ->
|
||||
line i ppf "Pcf_extension \"%s\"\n" s;
|
||||
expression i ppf arg
|
||||
line i ppf "Pcf_extension \"%s\"\n" s.txt;
|
||||
structure i ppf arg
|
||||
|
||||
and class_field_kind i ppf = function
|
||||
| Cfk_concrete (o, e) ->
|
||||
|
|
@ -575,8 +575,8 @@ and module_type i ppf x =
|
|||
line i ppf "Pmty_typeof\n";
|
||||
module_expr i ppf m;
|
||||
| Pmty_extension (s, arg) ->
|
||||
line i ppf "Pmod_extension \"%s\"\n" s;
|
||||
expression i ppf arg
|
||||
line i ppf "Pmod_extension \"%s\"\n" s.txt;
|
||||
structure i ppf arg
|
||||
|
||||
and signature i ppf x = list i signature_item ppf x
|
||||
|
||||
|
|
@ -618,12 +618,12 @@ and signature_item i ppf x =
|
|||
line i ppf "Psig_class_type\n";
|
||||
list i class_type_declaration ppf l;
|
||||
| Psig_extension ((s, arg), attrs) ->
|
||||
line i ppf "Psig_extension \"%s\"\n" s;
|
||||
line i ppf "Psig_extension \"%s\"\n" s.txt;
|
||||
attributes i ppf attrs;
|
||||
expression i ppf arg
|
||||
structure i ppf arg
|
||||
| Psig_attribute (s, arg) ->
|
||||
line i ppf "Psig_attribute \"%s\"\n" s;
|
||||
expression i ppf arg
|
||||
line i ppf "Psig_attribute \"%s\"\n" s.txt;
|
||||
structure i ppf arg
|
||||
|
||||
and modtype_declaration i ppf = function
|
||||
| None -> line i ppf "#abstract"
|
||||
|
|
@ -671,8 +671,8 @@ and module_expr i ppf x =
|
|||
line i ppf "Pmod_unpack\n";
|
||||
expression i ppf e;
|
||||
| Pmod_extension (s, arg) ->
|
||||
line i ppf "Pmod_extension \"%s\"\n" s;
|
||||
expression i ppf arg
|
||||
line i ppf "Pmod_extension \"%s\"\n" s.txt;
|
||||
structure i ppf arg
|
||||
|
||||
and structure i ppf x = list i structure_item ppf x
|
||||
|
||||
|
|
@ -726,12 +726,12 @@ and structure_item i ppf x =
|
|||
attributes i ppf attrs;
|
||||
module_expr i ppf me
|
||||
| Pstr_extension ((s, arg), attrs) ->
|
||||
line i ppf "Pstr_extension \"%s\"\n" s;
|
||||
line i ppf "Pstr_extension \"%s\"\n" s.txt;
|
||||
attributes i ppf attrs;
|
||||
expression i ppf arg
|
||||
structure i ppf arg
|
||||
| Pstr_attribute (s, arg) ->
|
||||
line i ppf "Pstr_attribute \"%s\"\n" s;
|
||||
expression i ppf arg
|
||||
line i ppf "Pstr_attribute \"%s\"\n" s.txt;
|
||||
structure i ppf arg
|
||||
|
||||
and module_declaration i ppf pmd =
|
||||
string_loc i ppf pmd.pmd_name;
|
||||
|
|
|
|||
|
|
@ -18,3 +18,4 @@ val implementation : formatter -> structure_item list -> unit;;
|
|||
val top_phrase : formatter -> toplevel_phrase -> unit;;
|
||||
|
||||
val expression: int -> formatter -> expression -> unit
|
||||
val structure: int -> formatter -> structure -> unit
|
||||
|
|
|
|||
|
|
@ -140,8 +140,8 @@ let attributes i ppf l =
|
|||
let i = i + 1 in
|
||||
List.iter
|
||||
(fun (s, arg) ->
|
||||
line i ppf "attribute \"%s\"\n" s;
|
||||
Printast.expression (i + 1) ppf arg;
|
||||
line i ppf "attribute \"%s\"\n" s.txt;
|
||||
Printast.structure (i + 1) ppf arg;
|
||||
)
|
||||
l
|
||||
|
||||
|
|
@ -612,8 +612,8 @@ and signature_item i ppf x =
|
|||
line i ppf "Psig_class_type\n";
|
||||
list i class_type_declaration ppf l;
|
||||
| Tsig_attribute (s, arg) ->
|
||||
line i ppf "Psig_attribute \"%s\"\n" s;
|
||||
Printast.expression i ppf arg
|
||||
line i ppf "Psig_attribute \"%s\"\n" s.txt;
|
||||
Printast.structure i ppf arg
|
||||
|
||||
and module_declaration i ppf md =
|
||||
line i ppf "%a" fmt_ident md.md_id;
|
||||
|
|
@ -719,8 +719,8 @@ and structure_item i ppf x =
|
|||
attributes i ppf attrs;
|
||||
module_expr i ppf me;
|
||||
| Tstr_attribute (s, arg) ->
|
||||
line i ppf "Pstr_attribute \"%s\"\n" s;
|
||||
Printast.expression i ppf arg
|
||||
line i ppf "Pstr_attribute \"%s\"\n" s.txt;
|
||||
Printast.structure i ppf arg
|
||||
|
||||
and string_x_module_type i ppf (s, _, mty) =
|
||||
ident i ppf s;
|
||||
|
|
|
|||
|
|
@ -401,7 +401,7 @@ let rec class_type_field env self_type meths
|
|||
val_sig, concr_meths, inher)
|
||||
|
||||
| Pctf_extension (s, _arg) ->
|
||||
raise (Error (ctf.pctf_loc, env, Extension s))
|
||||
raise (Error (s.loc, env, Extension s.txt))
|
||||
|
||||
and class_signature env {pcsig_self=sty; pcsig_fields=sign} =
|
||||
let meths = ref Meths.empty in
|
||||
|
|
@ -485,7 +485,7 @@ and class_type env scty =
|
|||
let typ = Cty_arrow (l, ty, clty.cltyp_type) in
|
||||
cltyp (Tcty_arrow (l, cty, clty)) typ
|
||||
| Pcty_extension (s, _arg) ->
|
||||
raise (Error (scty.pcty_loc, env, Extension s))
|
||||
raise (Error (s.loc, env, Extension s.txt))
|
||||
|
||||
let class_type env scty =
|
||||
delayed_meth_specs := [];
|
||||
|
|
@ -683,7 +683,7 @@ let rec class_field self_loc cl_num self_type meths vars
|
|||
(val_env, met_env, par_env, field::fields, concr_meths, warn_vals, inher)
|
||||
|
||||
| Pcf_extension (s, _arg) ->
|
||||
raise (Error (loc, val_env, Extension s))
|
||||
raise (Error (s.loc, val_env, Extension s.txt))
|
||||
|
||||
and class_structure cl_num final val_env met_env loc
|
||||
{ pcstr_self = spat; pcstr_fields = str } =
|
||||
|
|
@ -1103,7 +1103,7 @@ and class_expr cl_num val_env met_env scl =
|
|||
cl_attributes = scl.pcl_attributes;
|
||||
}
|
||||
| Pcl_extension (s, _arg) ->
|
||||
raise (Error (scl.pcl_loc, val_env, Extension s))
|
||||
raise (Error (s.loc, val_env, Extension s.txt))
|
||||
|
||||
(*******************************)
|
||||
|
||||
|
|
|
|||
|
|
@ -1142,7 +1142,7 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty =
|
|||
unify_pat_types loc !env ty expected_ty;
|
||||
{ p with pat_extra = (Tpat_type (path, lid), loc, sp.ppat_attributes) :: p.pat_extra }
|
||||
| Ppat_extension (s, _arg) ->
|
||||
raise (Error (loc, !env, Extension s))
|
||||
raise (Error (s.loc, !env, Extension s.txt))
|
||||
|
||||
let type_pat ?(allow_existentials=false) ?constrs ?labels
|
||||
?(lev=get_current_level()) env sp expected_ty =
|
||||
|
|
@ -1920,7 +1920,7 @@ and type_expect_ ?in_function env sexp ty_expected =
|
|||
| Pexp_let(rec_flag, spat_sexp_list, sbody) ->
|
||||
let scp =
|
||||
match sexp.pexp_attributes, rec_flag with
|
||||
| ["#default",_], _ -> None
|
||||
| [{txt="#default"},_], _ -> None
|
||||
| _, Recursive -> Some (Annot.Idef loc)
|
||||
| _, Nonrecursive -> Some (Annot.Idef sbody.pexp_loc)
|
||||
in
|
||||
|
|
@ -1960,7 +1960,7 @@ and type_expect_ ?in_function env sexp ty_expected =
|
|||
Exp.fun_ ~loc
|
||||
l None
|
||||
(Pat.var ~loc (mknoloc "*opt*"))
|
||||
(Exp.let_ ~loc Nonrecursive ~attrs:["#default",Exp.constant (Const_int 0)] [spat, smatch] sexp)
|
||||
(Exp.let_ ~loc Nonrecursive ~attrs:[mknoloc "#default",[]] [spat, smatch] sexp)
|
||||
in
|
||||
type_expect ?in_function env sfun ty_expected
|
||||
(* TODO: keep attributes, call type_function directly *)
|
||||
|
|
@ -2720,7 +2720,7 @@ and type_expect_ ?in_function env sexp ty_expected =
|
|||
exp_extra = (Texp_open (path, lid, newenv), loc, sexp.pexp_attributes) :: exp.exp_extra;
|
||||
}
|
||||
| Pexp_extension (s, _arg) ->
|
||||
raise (Error (loc, env, Extension s))
|
||||
raise (Error (s.loc, env, Extension s.txt))
|
||||
|
||||
and type_function ?in_function loc attrs env ty_expected l caselist =
|
||||
let (loc_fun, ty_fun) =
|
||||
|
|
|
|||
|
|
@ -21,7 +21,7 @@ open Types
|
|||
type partial = Partial | Total
|
||||
type optional = Required | Optional
|
||||
|
||||
type attribute = string * Parsetree.expression
|
||||
type attribute = string loc * Parsetree.structure
|
||||
type attributes = attribute list
|
||||
|
||||
type pattern =
|
||||
|
|
|
|||
|
|
@ -20,7 +20,7 @@ open Types
|
|||
type partial = Partial | Total
|
||||
type optional = Required | Optional
|
||||
|
||||
type attribute = string * Parsetree.expression
|
||||
type attribute = string loc * Parsetree.structure
|
||||
type attributes = attribute list
|
||||
|
||||
type pattern =
|
||||
|
|
|
|||
|
|
@ -294,7 +294,7 @@ let rec approx_modtype env smty =
|
|||
let (_, mty) = !type_module_type_of_fwd env smod in
|
||||
mty
|
||||
| Pmty_extension (s, _arg) ->
|
||||
raise (Error (smty.pmty_loc, env, Extension s))
|
||||
raise (Error (s.loc, env, Extension s.txt))
|
||||
|
||||
and approx_sig env ssg =
|
||||
match ssg with
|
||||
|
|
@ -457,7 +457,7 @@ let rec transl_modtype env smty =
|
|||
let tmty, mty = !type_module_type_of_fwd env smod in
|
||||
mkmty (Tmty_typeof tmty) mty env loc smty.pmty_attributes
|
||||
| Pmty_extension (s, _arg) ->
|
||||
raise (Error (smty.pmty_loc, env, Extension s))
|
||||
raise (Error (s.loc, env, Extension s.txt))
|
||||
|
||||
|
||||
and transl_signature env sg =
|
||||
|
|
@ -587,7 +587,7 @@ and transl_signature env sg =
|
|||
let (trem,rem, final_env) = transl_sig env srem in
|
||||
mksig (Tsig_attribute x) env loc :: trem, rem, final_env
|
||||
| Psig_extension ((s, _), _) ->
|
||||
raise (Error (loc, env, Extension s))
|
||||
raise (Error (s.loc, env, Extension s.txt))
|
||||
in
|
||||
let previous_saved_types = Cmt_format.get_saved_types () in
|
||||
let (trem, rem, final_env) = transl_sig (Env.in_signature env) sg in
|
||||
|
|
@ -971,7 +971,7 @@ let rec type_module sttn funct_body anchor env smod =
|
|||
mod_attributes = smod.pmod_attributes;
|
||||
mod_loc = smod.pmod_loc }
|
||||
| Pmod_extension (s, _arg) ->
|
||||
raise (Error (smod.pmod_loc, env, Extension s))
|
||||
raise (Error (s.loc, env, Extension s.txt))
|
||||
|
||||
and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
|
||||
let type_names = ref StringSet.empty
|
||||
|
|
@ -1194,7 +1194,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
|
|||
sg @ sig_rem,
|
||||
final_env)
|
||||
| Pstr_extension ((s, _), _) ->
|
||||
raise (Error (loc, env, Extension s))
|
||||
raise (Error (s.loc, env, Extension s.txt))
|
||||
| Pstr_attribute x ->
|
||||
let (str_rem, sig_rem, final_env) = type_struct env srem in
|
||||
mk (Tstr_attribute x) :: str_rem, sig_rem, final_env
|
||||
|
|
|
|||
|
|
@ -548,7 +548,7 @@ let rec transl_type env policy styp =
|
|||
pack_txt = p;
|
||||
}) ty
|
||||
| Ptyp_extension (s, _arg) ->
|
||||
raise (Error (loc, env, Extension s))
|
||||
raise (Error (s.loc, env, Extension s.txt))
|
||||
|
||||
and transl_poly_type env policy t =
|
||||
transl_type env policy (Ast_helper.Typ.force_poly t)
|
||||
|
|
|
|||
Loading…
Reference in New Issue