Extension nodes and attributes for class types.

git-svn-id: http://caml.inria.fr/svn/ocaml/branches/extension_points@13501 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml

@@ -67,7 +67,7 @@ module Make (Ast : Sig.Camlp4Ast) = struct
   value mksig loc d = {psig_desc = d; psig_loc = mkloc loc};
   value mkmod loc d = {pmod_desc = d; pmod_loc = mkloc loc; pmod_attributes = []};
   value mkstr loc d = {pstr_desc = d; pstr_loc = mkloc loc};
-  value mkcty loc d = {pcty_desc = d; pcty_loc = mkloc loc};
+  value mkcty loc d = {pcty_desc = d; pcty_loc = mkloc loc; pcty_attributes = []};
   value mkcl loc d = {pcl_desc = d; pcl_loc = mkloc loc; pcl_attributes = []};
   value mkcf loc d = { pcf_desc = d; pcf_loc = mkloc loc; pcf_attributes = []};
   value mkctf loc d = { pctf_desc = d; pctf_loc = mkloc loc; pctf_attributes = []};

camlp4/boot/Camlp4.ml

@@ -14185,7 +14185,7 @@ module Struct =
               
             let mkstr loc d = { pstr_desc = d; pstr_loc = mkloc loc; }
               
-            let mkcty loc d = { pcty_desc = d; pcty_loc = mkloc loc; }
+            let mkcty loc d = { pcty_desc = d; pcty_loc = mkloc loc; pcty_attributes = []}
               
             let mkcl loc d = { pcl_desc = d; pcl_loc = mkloc loc; pcl_attributes = []}
               

experimental/frisch/extension_points.txt

@@ -13,7 +13,7 @@ a dots (whitespaces are allowed around the dots).  In the Parsetree,
 the identifier is represented as a single string (without spaces).
 
 Attributes on expressions, type expressions, module expressions, module type expressions,
-patterns, class expressions (TODO: class type expressions):
+patterns, class expressions, class type expressions:
  
   ... [@id expr]
 
@@ -84,7 +84,7 @@ expression (written expr below).
 Two syntaxes exist for extension node:
 
 As expressions, type expressions, module expressions, module type expressions,
-patterns, class expressions (TODO: class type expressions):
+patterns, class expressions, class type expressions:
 
   [%id expr]
 

ocamldoc/odoc_sig.ml

@@ -456,6 +456,7 @@ module Analyser =
                     ic_class = None ;
                     ic_text = text_opt ;
                   }
+              | Parsetree.Pcty_extension _ -> assert false
             in
             let (inher_l, eles) = f (pos_end + maybe_more) q in
             (inh :: inher_l , eles_comments @ eles)

otherlibs/labltk/browser/searchpos.ml

@@ -153,6 +153,7 @@ let rec search_pos_class_type cl ~pos ~env =
     | Pcty_fun (_, ty, cty) ->
         search_pos_type ty ~pos ~env;
         search_pos_class_type cty ~pos ~env
+    | Pcty_extension _ -> ()
     end
 
 let search_pos_type_decl td ~pos ~env =

parsing/ast_helper.ml

@@ -180,11 +180,18 @@ module Cl = struct
 end
 
 module Cty = struct
-  let mk ?(loc = Location.none) d = {pcty_desc = d; pcty_loc = loc}
+  let mk ?(loc = Location.none) ?(attrs = []) d =
+    {
+     pcty_desc = d;
+     pcty_loc = loc;
+     pcty_attributes = attrs;
+    }
+  let attr d a = {d with pcty_attributes = d.pcty_attributes @ [a]}
 
-  let constr ?loc a b = mk ?loc (Pcty_constr (a, b))
-  let signature ?loc a = mk ?loc (Pcty_signature a)
-  let fun_ ?loc a b c = mk ?loc (Pcty_fun (a, b, c))
+  let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcty_constr (a, b))
+  let signature ?loc ?attrs a = mk ?loc ?attrs (Pcty_signature a)
+  let fun_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcty_fun (a, b, c))
+  let extension ?loc ?attrs a = mk ?loc ?attrs (Pcty_extension a)
 end
 
 module Ctf = struct

parsing/ast_helper.mli

@@ -173,11 +173,13 @@ module Cl:
   end
 module Cty:
   sig
-    val mk: ?loc:Location.t -> class_type_desc -> class_type
+    val mk: ?loc:Location.t -> ?attrs:attribute list -> class_type_desc -> class_type
+    val attr: class_type -> attribute -> class_type
 
-    val constr: ?loc:Location.t -> Longident.t loc -> core_type list -> class_type
-    val signature: ?loc:Location.t -> class_signature -> class_type
-    val fun_: ?loc:Location.t -> label -> core_type -> class_type -> class_type
+    val constr: ?loc:Location.t -> ?attrs:attribute list -> Longident.t loc -> core_type list -> class_type
+    val signature: ?loc:Location.t -> ?attrs:attribute list -> class_signature -> class_type
+    val fun_: ?loc:Location.t -> ?attrs:attribute list -> label -> core_type -> class_type -> class_type
+    val extension: ?loc:Location.t -> ?attrs:attribute list -> extension -> class_type
   end
 module Ctf:
   sig

parsing/ast_mapper.ml

@@ -76,16 +76,17 @@ end
 module CT = struct
   (* Type expressions for the class language *)
 
-  let map sub {pcty_loc = loc; pcty_desc = desc} =
+  let map sub {pcty_loc = loc; pcty_desc = desc; pcty_attributes = attrs} =
     let open Cty in
     let loc = sub # location loc in
     match desc with
-    | Pcty_constr (lid, tys) -> constr ~loc (map_loc sub lid) (List.map (sub # typ) tys)
-    | Pcty_signature x -> signature ~loc (sub # class_signature x)
+    | Pcty_constr (lid, tys) -> constr ~loc ~attrs (map_loc sub lid) (List.map (sub # typ) tys)
+    | Pcty_signature x -> signature ~loc ~attrs (sub # class_signature x)
     | Pcty_fun (lab, t, ct) ->
-        fun_ ~loc lab
+        fun_ ~loc ~attrs lab
           (sub # typ t)
           (sub # class_type ct)
+    | Pcty_extension x -> extension ~loc ~attrs (sub # extension x)
 
   let map_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs} =
     let open Ctf in

parsing/parser.mly

@@ -773,6 +773,8 @@ class_expr:
       { mkclass(Pcl_let ($2, List.rev $3, $5)) }
   | class_expr attribute
       { Cl.attr $1 $2 }
+  | extension
+      { mkclass(Pcl_extension $1) }
 ;
 class_simple_expr:
     LBRACKET core_type_comma_list RBRACKET class_longident
@@ -877,6 +879,10 @@ class_type:
       { mkcty(Pcty_fun($1, $3, $5)) }
   | simple_core_type_or_tuple_no_attr MINUSGREATER class_type
       { mkcty(Pcty_fun("", $1, $3)) }
+  | class_type attribute
+      { Cty.attr $1 $2 }
+  | extension
+      { mkcty(Pcty_extension $1) }
 ;
 class_signature:
     LBRACKET core_type_comma_list RBRACKET clty_longident

parsing/parsetree.mli

@@ -176,13 +176,17 @@ and constructor_declaration =
 (* Type expressions for the class language *)
 
 and class_type =
-  { pcty_desc: class_type_desc;
-    pcty_loc: Location.t }
+    {
+     pcty_desc: class_type_desc;
+     pcty_loc: Location.t;
+     pcty_attributes: attribute list;
+    }
 
 and class_type_desc =
     Pcty_constr of Longident.t loc * core_type list
   | Pcty_signature of class_signature
   | Pcty_fun of label * core_type * class_type
+  | Pcty_extension of extension
 
 and class_signature = {
     pcsig_self: core_type;

parsing/pprintast.ml

@@ -738,6 +738,7 @@ class printer  ()= object(self:'self)
     | Pcty_fun (l, co, cl) ->
         pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *)
           self#type_with_label (l,co) self#class_type cl
+    | Pcty_extension _ -> assert false
 
     
   (* [class type a = object end] *)  

parsing/printast.ml

@@ -402,6 +402,7 @@ and type_kind i ppf x =
 
 and class_type i ppf x =
   line i ppf "class_type %a\n" fmt_location x.pcty_loc;
+  attributes i ppf x.pcty_attributes;
   let i = i+1 in
   match x.pcty_desc with
   | Pcty_constr (li, l) ->
@@ -414,6 +415,9 @@ and class_type i ppf x =
       line i ppf "Pcty_fun \"%s\"\n" l;
       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
 
 and class_signature i ppf cs =
   line i ppf "class_signature %a\n" fmt_location cs.pcsig_loc;

tools/depend.ml

@@ -88,6 +88,7 @@ let rec add_class_type bv cty =
       List.iter (add_class_type_field bv) fieldl
   | Pcty_fun(_, ty1, cty2) ->
       add_type bv ty1; add_class_type bv cty2
+  | Pcty_extension _ -> ()
 
 and add_class_type_field bv pctf =
   match pctf.pctf_desc with

tools/untypeast.ml

@@ -456,7 +456,9 @@ and untype_class_type ct =
         Pcty_fun (label, untype_core_type ct, untype_class_type cl)
   in
   { pcty_desc = desc;
-    pcty_loc = ct.cltyp_loc }
+    pcty_loc = ct.cltyp_loc;
+    pcty_attributes = ct.cltyp_attributes;
+   }
 
 and untype_class_signature cs =
   {

typing/printtyped.ml

@@ -416,6 +416,7 @@ and type_kind i ppf x =
 
 and class_type i ppf x =
   line i ppf "class_type %a\n" fmt_location x.cltyp_loc;
+  attributes i ppf x.cltyp_attributes;
   let i = i+1 in
   match x.cltyp_desc with
   | Tcty_constr (li, _, l) ->

typing/typeclass.ml

@@ -53,9 +53,6 @@ open Typedtree
 
 let ctyp desc typ env loc =
   { ctyp_desc = desc; ctyp_type = typ; ctyp_loc = loc; ctyp_env = env; ctyp_attributes = [] }
-let cltyp desc typ env loc =
-  { cltyp_desc = desc; cltyp_type = typ; cltyp_loc = loc; cltyp_env = env }
-
 
                        (**********************)
                        (*  Useful constants  *)
@@ -442,7 +439,15 @@ and class_signature env sty sign loc =
     }
 
 and class_type env scty =
-  let loc = scty.pcty_loc in
+  let cltyp desc typ =
+    {
+     cltyp_desc = desc;
+     cltyp_type = typ;
+     cltyp_loc = scty.pcty_loc;
+     cltyp_env = env;
+     cltyp_attributes = scty.pcty_attributes;
+    }
+  in
   match scty.pcty_desc with
     Pcty_constr (lid, styl) ->
       let (path, decl) = Typetexp.find_class_type env scty.pcty_loc lid.txt in
@@ -467,20 +472,22 @@ and class_type env scty =
         )       styl params
       in
       let typ = Cty_constr (path, params, clty) in
-      cltyp (Tcty_constr ( path, lid , ctys)) typ env loc
+      cltyp (Tcty_constr ( path, lid , ctys)) typ
 
   | Pcty_signature pcsig ->
       let clsig = class_signature env
         pcsig.pcsig_self pcsig.pcsig_fields pcsig.pcsig_loc in
       let typ = Cty_signature clsig.csig_type in
-      cltyp (Tcty_signature clsig) typ env loc
+      cltyp (Tcty_signature clsig) typ
 
   | Pcty_fun (l, sty, scty) ->
       let cty = transl_simple_type env false sty in
       let ty = cty.ctyp_type in
       let clty = class_type env scty in
       let typ = Cty_fun (l, ty, clty.cltyp_type) in
-      cltyp (Tcty_fun (l, cty, clty)) typ env loc
+      cltyp (Tcty_fun (l, cty, clty)) typ
+  | Pcty_extension (s, _arg) ->
+      raise (Error (scty.pcty_loc, env, Extension s))
 
 let class_type env scty =
   delayed_meth_specs := [];
@@ -827,7 +834,7 @@ and class_expr cl_num val_env met_env scl =
           cl_loc = scl.pcl_loc;
           cl_type = clty';
           cl_env = val_env;
-          cl_attributes = scl.pcl_attributes;
+          cl_attributes = []; (* attributes are kept on the inner cl node *)
          }
   | Pcl_structure cl_str ->
       let (desc, ty) =

typing/typedtree.ml

@@ -380,10 +380,13 @@ and constructor_declaration =
     }
 
 and class_type =
-  { cltyp_desc: class_type_desc;
-    cltyp_type : Types.class_type;
-    cltyp_env : Env.t; (* BINANNOT ADDED *)
-    cltyp_loc: Location.t }
+    {
+     cltyp_desc: class_type_desc;
+     cltyp_type: Types.class_type;
+     cltyp_env: Env.t;
+     cltyp_loc: Location.t;
+     cltyp_attributes: attribute list;
+    }
 
 and class_type_desc =
     Tcty_constr of Path.t * Longident.t loc * core_type list

typing/typedtree.mli

@@ -380,10 +380,13 @@ and constructor_declaration =
     }
 
 and class_type =
-  { cltyp_desc: class_type_desc;
-    cltyp_type : Types.class_type;
-    cltyp_env : Env.t; (* BINANNOT ADDED *)
-    cltyp_loc: Location.t }
+    {
+     cltyp_desc: class_type_desc;
+     cltyp_type: Types.class_type;
+     cltyp_env: Env.t;
+     cltyp_loc: Location.t;
+     cltyp_attributes: attribute list;
+    }
 
 and class_type_desc =
     Tcty_constr of Path.t * Longident.t loc * core_type list