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-0dff7051ff02

10 files changed, 59 insertions, 34 deletions

diff --git a/parsing/ast_helper.ml b/parsing/ast_helper.ml
index 40d5a62da6..6bb01d9534 100644
--- a/parsing/ast_helper.ml
+++ b/parsing/ast_helper.ml
@@ -412,13 +412,13 @@ module Convenience = struct
     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
+  let expr_of_payload = function
+    | PStr [{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
+    | Some e -> expr_of_payload e
     | None -> None
 
   let has_attr s attrs =
diff --git a/parsing/ast_helper.mli b/parsing/ast_helper.mli
index 57ac800f14..329db3616e 100644
--- a/parsing/ast_helper.mli
+++ b/parsing/ast_helper.mli
@@ -361,6 +361,6 @@ module Convenience :
     val get_lid: expression -> string option
 
     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
   end
diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml
index 7305d89b96..5ea1766e2a 100644
--- a/parsing/ast_mapper.ml
+++ b/parsing/ast_mapper.ml
@@ -409,9 +409,13 @@ class mapper =
 
     method location l = l
 
-    method extension (s, e) = (map_loc this s, this # structure e)
-    method attribute (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 # payload e)
     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
 
 class type main_entry_points =
diff --git a/parsing/ast_mapper.mli b/parsing/ast_mapper.mli
index 6f88d88d2e..b5ad431a69 100644
--- a/parsing/ast_mapper.mli
+++ b/parsing/ast_mapper.mli
@@ -54,6 +54,7 @@ class mapper:
     method constructor_declaration: constructor_declaration -> constructor_declaration
     method label_declaration: label_declaration -> label_declaration
     method value_binding: value_binding -> value_binding
+    method payload: payload -> payload
   end
 
 class type main_entry_points =
diff --git a/parsing/parser.mly b/parsing/parser.mly
index f01ac43ec3..7fb44b73fd 100644
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -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, [mkstrexp body []]))
+  | Some id -> ghexp(Pexp_extension (id, PStr [mkstrexp body []]))
 
 let mkexp_attrs 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())}
 ;
 attribute:
-  LBRACKETAT attr_id ext_arg RBRACKET { ($2, $3) }
+  LBRACKETAT attr_id payload RBRACKET { ($2, $3) }
 ;
 post_item_attribute:
-  LBRACKETATAT attr_id ext_arg RBRACKET { ($2, $3) }
+  LBRACKETATAT attr_id payload RBRACKET { ($2, $3) }
 ;
 post_item_attributes:
     /* empty */  { [] }
@@ -1997,15 +1997,18 @@ ext_attributes:
   | PERCENT attr_id attributes { Some $2, $3 }
 ;
 extension:
-  LBRACKETPERCENT attr_id ext_arg RBRACKET { ($2, $3) }
+  LBRACKETPERCENT attr_id payload RBRACKET { ($2, $3) }
 ;
 item_extension:
-  LBRACKETPERCENTPERCENT attr_id ext_arg RBRACKET { ($2, $3) }
+  LBRACKETPERCENTPERCENT attr_id payload RBRACKET { ($2, $3) }
 ;
-ext_arg:
-    structure { $1 }
-  | COLON core_type {
-      [ mkstrexp (ghexp (Pexp_constraint (ghunit (), $2))) [] ]
+payload:
+    structure { PStr $1 }
+  | COLON core_type { PTyp $2
+(*      [ mkstrexp (ghexp (Pexp_constraint (ghunit (), $2))) [] ] *)
+  }
+  | QUESTION pattern { PPat $2
+(*       [ mkstr(Pstr_value(Nonrecursive, [Vb.mk $2 (ghunit ())])) ] *)
   }
 ;
 %%
diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
index 14ed11ef3e..361fce5879 100644
--- a/parsing/parsetree.mli
+++ b/parsing/parsetree.mli
@@ -16,18 +16,23 @@ open Asttypes
 
 (** {2 Extension points} *)
 
-type attribute = string loc * structure
+type attribute = string loc * payload
       (* [@id STRUCTURE]
          [@@id STRUCTURE]
        *)
 
-and extension = string loc * structure
+and extension = string loc * payload
       (* [%id STRUCTURE]
          [%%id STRUCTURE]
        *)
 
 and attributes = attribute list
 
+and payload =
+  | PStr of structure
+  | PTyp of core_type
+  | PPat of pattern
+
 (** {2 Core language} *)
 
 (* Type expressions *)
diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml
index 3212aca365..9dfe7b6225 100644
--- a/parsing/pprintast.ml
+++ b/parsing/pprintast.ml
@@ -322,7 +322,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.txt self#structure arg
+      pp f "@[<2>(&%s@ %a)@]" s.txt self#payload arg
     | _ -> self#paren true self#core_type f x
           (********************pattern********************)
           (* be cautious when use [pattern], [pattern1] is preferred *)
@@ -618,7 +618,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.txt self#structure arg
+      pp f "@[<2>(&%s@ %a)@]" s.txt self#payload arg
     | _ -> self#expression1 f x
   method expression1 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
 
   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 =
     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 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 *)
   method binding f {pvb_pat=p; pvb_expr=x; pvb_attributes=_} = (* TODO: print attributes *)
     let rec pp_print_pexp_function f x =
diff --git a/parsing/pprintast.mli b/parsing/pprintast.mli
index 6fc21255bc..86297cea82 100644
--- a/parsing/pprintast.mli
+++ b/parsing/pprintast.mli
@@ -75,6 +75,7 @@ class printer :
           (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a -> unit
     method pattern : 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 rec_flag : Format.formatter -> Asttypes.rec_flag -> unit
 
diff --git a/parsing/printast.ml b/parsing/printast.ml
index d4f3f17058..cfefe441da 100644
--- a/parsing/printast.ml
+++ b/parsing/printast.ml
@@ -177,7 +177,7 @@ let rec core_type i ppf x =
       list i package_with ppf l;
   | Ptyp_extension (s, arg) ->
       line i ppf "Ptyp_extension \"%s\"\n" s.txt;
-      structure i ppf arg
+      payload i ppf arg
 
 and package_with i ppf (s, t) =
   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;
   | Ppat_extension (s, arg) ->
       line i ppf "Ppat_extension \"%s\"\n" s.txt;
-      structure i ppf arg
+      payload i ppf arg
 
 and expression i ppf x =
   line i ppf "expression %a\n" fmt_location x.pexp_loc;
@@ -352,7 +352,7 @@ and expression i ppf x =
       expression i ppf e
   | Pexp_extension (s, arg) ->
       line i ppf "Pexp_extension \"%s\"\n" s.txt;
-      structure i ppf arg
+      payload 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;
@@ -386,10 +386,15 @@ and attributes i ppf l =
   List.iter
     (fun (s, arg) ->
       line i ppf "attribute \"%s\"\n" s.txt;
-      structure (i + 1) ppf arg;
+      payload (i + 1) ppf arg;
     )
     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 =
   match x with
   | Ptype_abstract ->
@@ -418,7 +423,7 @@ and class_type i ppf x =
       class_type i ppf cl;
   | Pcty_extension (s, arg) ->
       line i ppf "Pcty_extension \"%s\"\n" s.txt;
-      structure i ppf arg
+      payload i ppf arg
 
 and class_signature i ppf cs =
   line i ppf "class_signature\n";
@@ -446,7 +451,7 @@ and class_type_field i ppf x =
       core_type (i+1) ppf ct2;
   | Pctf_extension (s, arg) ->
       line i ppf "Pctf_extension \"%s\"\n" s.txt;
-      structure i ppf arg
+     payload i ppf arg
 
 and class_description i ppf x =
   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;
   | Pcl_extension (s, arg) ->
       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 } =
   line i ppf "class_structure\n";
@@ -534,7 +539,7 @@ and class_field i ppf x =
       expression (i+1) ppf e;
   | Pcf_extension (s, arg) ->
       line i ppf "Pcf_extension \"%s\"\n" s.txt;
-      structure i ppf arg
+      payload i ppf arg
 
 and class_field_kind i ppf = function
   | Cfk_concrete (o, e) ->
@@ -577,7 +582,7 @@ and module_type i ppf x =
       module_expr i ppf m;
   | Pmty_extension (s, arg) ->
       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
 
@@ -623,10 +628,10 @@ and signature_item i ppf x =
   | Psig_extension ((s, arg), attrs) ->
       line i ppf "Psig_extension \"%s\"\n" s.txt;
       attributes i ppf attrs;
-      structure i ppf arg
+      payload i ppf arg
   | Psig_attribute (s, arg) ->
       line i ppf "Psig_attribute \"%s\"\n" s.txt;
-      structure i ppf arg
+      payload i ppf arg
 
 and modtype_declaration i ppf = function
   | None -> line i ppf "#abstract"
@@ -675,7 +680,7 @@ and module_expr i ppf x =
       expression i ppf e;
   | Pmod_extension (s, arg) ->
       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
 
@@ -732,10 +737,10 @@ and structure_item i ppf x =
   | Pstr_extension ((s, arg), attrs) ->
       line i ppf "Pstr_extension \"%s\"\n" s.txt;
       attributes i ppf attrs;
-      structure i ppf arg
+      payload i ppf arg
   | Pstr_attribute (s, arg) ->
       line i ppf "Pstr_attribute \"%s\"\n" s.txt;
-      structure i ppf arg
+      payload i ppf arg
 
 and module_declaration i ppf pmd =
   string_loc i ppf pmd.pmd_name;
diff --git a/parsing/printast.mli b/parsing/printast.mli
index bca2820ba4..8523e71c92 100644
--- a/parsing/printast.mli
+++ b/parsing/printast.mli
@@ -19,3 +19,4 @@ val top_phrase : formatter -> toplevel_phrase -> unit;;
 
 val expression: int -> formatter -> expression -> unit
 val structure: int -> formatter -> structure -> unit
+val payload: int -> formatter -> payload -> unit