Adding metadata on patterns. Merging-in newfunsyntax branch.

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

6 files changed, 155 insertions, 65 deletions

diff --git a/parsing/parser.mly b/parsing/parser.mly
index bc2c6cf7c6..43a6a4c5cf 100644
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -23,7 +23,7 @@ open Parsetree
 let mktyp d =
   { ptyp_desc = d; ptyp_loc = symbol_rloc() }
 let mkpat d =
-  { ppat_desc = d; ppat_loc = symbol_rloc() }
+  { ppat_desc = d; ppat_loc = symbol_rloc(); ppat_metadata = [] }
 let mkexp d =
   { pexp_desc = d; pexp_loc = symbol_rloc() }
 let mkmty d =
@@ -65,7 +65,7 @@ let mkoperator name pos =
   it must be ghost.
 *)
 let ghexp d = { pexp_desc = d; pexp_loc = symbol_gloc () };;
-let ghpat d = { ppat_desc = d; ppat_loc = symbol_gloc () };;
+let ghpat d = { ppat_desc = d; ppat_loc = symbol_gloc (); ppat_metadata = [] };;
 let ghtyp d = { ptyp_desc = d; ptyp_loc = symbol_gloc () };;
 
 let mkassert e =
@@ -125,8 +125,8 @@ let rec mktailpat = function
                loc_end = pat_pl.ppat_loc.loc_end;
                loc_ghost = true}
       in
-      let arg = {ppat_desc = Ppat_tuple [p1; pat_pl]; ppat_loc = l} in
-      {ppat_desc = Ppat_construct(Lident "::", Some arg, false); ppat_loc = l}
+      let arg = {ppat_desc = Ppat_tuple [p1; pat_pl]; ppat_loc = l; ppat_metadata = [] } in
+      {ppat_desc = Ppat_construct(Lident "::", Some arg, false); ppat_loc = l; ppat_metadata = [] }
 
 let ghstrexp e =
   { pstr_desc = Pstr_eval e; pstr_loc = {e.pexp_loc with loc_ghost = true} }
@@ -695,11 +695,17 @@ virtual_method:
       { if $2 = Override then syntax_error ();
         $5, $4, $7, symbol_rloc () }
 ;
-concrete_method :
-    METHOD override_flag private_flag label strict_binding
-      { $4, $3, $2, ghexp(Pexp_poly ($5, None)), symbol_rloc () }
-  | METHOD override_flag private_flag label COLON poly_type EQUAL seq_expr
-      { $4, $3, $2, ghexp(Pexp_poly($8,Some $6)), symbol_rloc () }
+concrete_method:
+    METHOD override_flag private_flag label fun_binding
+      { let expr, t = $5 in
+        let t = match t with
+        | None
+        | Some ({ptyp_desc=Ptyp_poly _}) -> t
+        | Some t -> Some (ghtyp(Ptyp_poly([], t)))
+        in
+        $4, $3, $2, ghexp(Pexp_poly (expr, t)), symbol_rloc () }
+  | METHOD override_flag private_flag LPAREN label COLON poly_type RPAREN fun_args
+      { $5, $3, $2, ghexp(Pexp_poly ($9, Some $7)), symbol_rloc () }
 ;
 
 /* Class types */
@@ -1050,29 +1056,74 @@ let_bindings:
   | let_bindings AND let_binding                { $3 :: $1 }
 ;
 let_binding:
-    val_ident fun_binding
-      { ({ppat_desc = Ppat_var $1; ppat_loc = rhs_loc 1}, $2) }
-  | val_ident COLON typevar_list DOT core_type EQUAL seq_expr
-      { (ghpat(Ppat_constraint({ppat_desc = Ppat_var $1; ppat_loc = rhs_loc 1},
-                               ghtyp(Ptyp_poly($3,$5)))),
-         $7) }
-  | pattern EQUAL seq_expr
-      { ($1, $3) }
-;
-fun_binding:
-    strict_binding
+    pattern0 fun_binding {
+      let pat = $1 in
+      let expr, t = $2 in
+      let pat, expr = match t with
+      | None -> pat, expr
+      | Some t -> ghpat(Ppat_constraint(pat, t)), expr
+      in
+      (* extra hack to allow: let A x = .... and let `A x = ...
+         Some care is taken to reject: let A = fun x -> ...
+       *)
+      match pat, expr with
+      | {ppat_desc = Ppat_variant(v, None)},
+        {pexp_desc = Pexp_function("", None, [pat, expr]);
+         pexp_loc = {loc_ghost = true}} ->
+          {pat with ppat_desc = Ppat_variant(v, Some pat)}, expr
+      | {ppat_desc = Ppat_construct(v, None, false)},
+        {pexp_desc = Pexp_function("", None, [pat, expr]);
+         pexp_loc = {loc_ghost = true}} ->
+           {pat with ppat_desc = Ppat_construct(v, Some pat, false)}, expr
+      | _ ->
+          pat, expr
+     }
+;
+
+/* same as pattern, without (A p) and (`A p) */
+pattern0:
+    simple_pattern
       { $1 }
-  | type_constraint EQUAL seq_expr
-      { let (t, t') = $1 in ghexp(Pexp_constraint($3, t, t')) }
+  | pattern0 AS val_ident
+      { mkpat(Ppat_alias($1, $3)) }
+  | pattern0_comma_list  %prec below_COMMA
+      { mkpat(Ppat_tuple(List.rev $1)) }
+  | pattern0 COLONCOLON pattern0
+      { mkpat(Ppat_construct(Lident "::", Some(ghpat(Ppat_tuple[$1;$3])),
+                             false)) }
+  | LPAREN COLONCOLON RPAREN LPAREN pattern COMMA pattern RPAREN
+      { mkpat(Ppat_construct(Lident "::", Some(ghpat(Ppat_tuple[$5;$7])),
+                             false)) }
+  | pattern0 BAR pattern0
+      { mkpat(Ppat_or($1, $3)) }
+  | LAZY simple_pattern
+      { mkpat(Ppat_lazy $2) }
 ;
-strict_binding:
-    EQUAL seq_expr
-      { $2 }
-  | labeled_simple_pattern fun_binding
+
+pattern0_comma_list:
+    pattern0_comma_list COMMA pattern0            { $3 :: $1 }
+  | pattern0 COMMA pattern0                       { [$3; $1] }
+;
+
+fun_binding:
+  fun_args
+      {
+       match $1 with
+       | {pexp_desc = Pexp_constraint(expr, Some t, None)} -> expr, Some t
+       | expr -> expr, None
+      }
+;
+fun_args:
+    labeled_simple_pattern fun_args
       { let (l, o, p) = $1 in ghexp(Pexp_function(l, o, [p, $2])) }
-  | LPAREN TYPE LIDENT RPAREN fun_binding
+  | LPAREN TYPE LIDENT RPAREN fun_args
       { mkexp(Pexp_newtype($3, $5)) }
+  | EQUAL seq_expr
+      { $2 }
+  | type_constraint EQUAL seq_expr
+      { let (t, t') = $1 in ghexp(Pexp_constraint($3, t, t')) }
 ;
+
 match_cases:
     pattern match_action                        { [$1, $2] }
   | match_cases BAR pattern match_action        { ($3, $4) :: $1 }
@@ -1117,7 +1168,7 @@ expr_semi_list:
   | expr_semi_list SEMI expr                    { $3 :: $1 }
 ;
 type_constraint:
-    COLON core_type                             { (Some $2, None) }
+    COLON opt_poly_type                         { (Some $2, None) }
   | COLON core_type COLONGREATER core_type      { (Some $2, Some $4) }
   | COLONGREATER core_type                      { (None, Some $2) }
   | COLON error                                 { syntax_error() }
@@ -1181,10 +1232,12 @@ simple_pattern:
       { reloc_pat $2 }
   | LPAREN pattern error
       { unclosed "(" 1 ")" 3 }
-  | LPAREN pattern COLON core_type RPAREN
+  | LPAREN pattern COLON opt_poly_type RPAREN
       { mkpat(Ppat_constraint($2, $4)) }
   | LPAREN pattern COLON core_type error
       { unclosed "(" 1 ")" 5 }
+/*  | LPAREN simple_pattern AMPERSAND metadata RPAREN { let p = $2 in {p with ppat_metadata = p.ppat_metadata @ $4 } } */
+  | LPAREN BACKQUOTE STRING pattern RPAREN { let p = $4 in {p with ppat_metadata = $3 :: p.ppat_metadata} }
 ;
 
 pattern_comma_list:
@@ -1347,6 +1400,12 @@ poly_type:
       | typevar_list DOT core_type
           { mktyp(Ptyp_poly(List.rev $1, $3)) }
 ;
+opt_poly_type:
+        core_type
+          { $1 }
+      | typevar_list DOT core_type
+          { mktyp(Ptyp_poly(List.rev $1, $3)) }
+;
 
 /* Core types */
 
diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
index 39f4737b9b..130cb0dab7 100644
--- a/parsing/parsetree.mli
+++ b/parsing/parsetree.mli
@@ -63,7 +63,9 @@ type 'a class_infos =
 
 type pattern =
   { ppat_desc: pattern_desc;
-    ppat_loc: Location.t }
+    ppat_loc: Location.t;
+    ppat_metadata: metadata;
+   }
 
 and pattern_desc =
     Ppat_any
diff --git a/parsing/printast.ml b/parsing/printast.ml
index f63e21b879..f0e4c89d74 100644
--- a/parsing/printast.ml
+++ b/parsing/printast.ml
@@ -169,9 +169,15 @@ and core_field_type i ppf x =
       core_type i ppf ct;
   | Pfield_var -> line i ppf "Pfield_var\n";
 
+
+and metadata i ppf = function
+  | [] -> ()
+  | l -> List.iter (fun s -> line i ppf "`%S\n" s) l
+
 and pattern i ppf x =
   line i ppf "pattern %a\n" fmt_location x.ppat_loc;
   let i = i+1 in
+  metadata i ppf x.ppat_metadata;
   match x.ppat_desc with
   | Ppat_any -> line i ppf "Ppat_any\n";
   | Ppat_var (s) -> line i ppf "Ppat_var \"%s\"\n" s;
diff --git a/typing/typeclass.ml b/typing/typeclass.ml
index 54840b1fe9..44dc776b50 100644
--- a/typing/typeclass.ml
+++ b/typing/typeclass.ml
@@ -316,7 +316,7 @@ let type_constraint val_env sty sty' loc =
   try Ctype.unify val_env ty ty' with Ctype.Unify trace ->
     raise(Error(loc, Unconsistent_constraint trace))
 
-let mkpat d = { ppat_desc = d; ppat_loc = Location.none }
+let mkpat d = { ppat_desc = d; ppat_loc = Location.none; ppat_metadata = [] }
 let make_method cl_num expr =
   { pexp_desc =
       Pexp_function ("", None,
@@ -786,11 +786,17 @@ and class_expr cl_num val_env met_env scl =
       let scases =
         [{ppat_loc = loc; ppat_desc =
           Ppat_construct(Longident.Lident"Some",
-                         Some{ppat_loc = loc; ppat_desc = Ppat_var"*sth*"},
-                         false)},
+                         Some{ppat_loc = loc; ppat_desc = Ppat_var "*sth*";
+                              ppat_metadata = [];
+                             },
+                         false);
+          ppat_metadata = [];
+         },
          {pexp_loc = loc; pexp_desc = Pexp_ident(Longident.Lident"*sth*")};
-         {ppat_loc = loc; ppat_desc =
-          Ppat_construct(Longident.Lident"None", None, false)},
+         {ppat_loc = loc;
+          ppat_desc = Ppat_construct(Longident.Lident"None", None, false);
+          ppat_metadata = [];
+         },
          default] in
       let smatch =
         {pexp_loc = loc; pexp_desc =
@@ -799,7 +805,10 @@ and class_expr cl_num val_env met_env scl =
                     scases)} in
       let sfun =
         {pcl_loc = scl.pcl_loc; pcl_desc =
-         Pcl_fun(l, None, {ppat_loc = loc; ppat_desc = Ppat_var"*opt*"},
+         Pcl_fun(l, None, {ppat_loc = loc;
+                           ppat_desc = Ppat_var "*opt*";
+                           ppat_metadata = [];
+                          },
                  {pcl_loc = scl.pcl_loc; pcl_desc =
                   Pcl_let(Default, [spat, smatch], sbody)})}
       in
diff --git a/typing/typecore.ml b/typing/typecore.ml
index 8059bfb9fb..ff297a1093 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -62,6 +62,7 @@ type error =
   | Not_a_variant_type of Longident.t
   | Incoherent_label_order
   | Less_general of string * (type_expr * type_expr) list
+  | Polymorphic_type_not_allowed
 
 exception Error of Location.t * error
 
@@ -199,7 +200,7 @@ let has_variants p =
 
 
 (* pattern environment *)
-let pattern_variables = ref ([]: (Ident.t * type_expr * Location.t) list)
+let pattern_variables = ref ([]: (Ident.t * type_expr * Location.t * metadata) list)
 let pattern_force = ref ([] : (unit -> unit) list)
 let pattern_scope = ref (None : Annot.ident option);;
 let reset_pattern scope =
@@ -208,11 +209,11 @@ let reset_pattern scope =
   pattern_scope := scope;
 ;;
 
-let enter_variable loc name ty =
-  if List.exists (fun (id, _, _) -> Ident.name id = name) !pattern_variables
+let enter_variable loc name ty metadata =
+  if List.exists (fun (id, _, _, _) -> Ident.name id = name) !pattern_variables
   then raise(Error(loc, Multiply_bound_variable name));
   let id = Ident.create name in
-  pattern_variables := (id, ty, loc) :: !pattern_variables;
+  pattern_variables := (id, ty, loc, metadata) :: !pattern_variables;
   begin match !pattern_scope with
   | None -> ()
   | Some s -> Stypes.record (Stypes.An_ident (loc, name, s));
@@ -221,7 +222,7 @@ let enter_variable loc name ty =
 
 let sort_pattern_variables vs =
   List.sort
-    (fun (x,_,_) (y,_,_) -> Pervasives.compare (Ident.name x) (Ident.name y))
+    (fun (x,_,_,_) (y,_,_,_) -> Pervasives.compare (Ident.name x) (Ident.name y))
     vs
 
 let enter_orpat_variables loc env  p1_vs p2_vs =
@@ -231,7 +232,7 @@ let enter_orpat_variables loc env  p1_vs p2_vs =
   and p2_vs = sort_pattern_variables p2_vs in
 
   let rec unify_vars p1_vs p2_vs = match p1_vs, p2_vs with
-      | (x1,t1,l1)::rem1, (x2,t2,l2)::rem2 when Ident.equal x1 x2 ->
+      | (x1,t1,l1,m1)::rem1, (x2,t2,l2,m2)::rem2 when Ident.equal x1 x2 ->
           if x1==x2 then
             unify_vars rem1 rem2
           else begin
@@ -244,9 +245,9 @@ let enter_orpat_variables loc env  p1_vs p2_vs =
           (x2,x1)::unify_vars rem1 rem2
           end
       | [],[] -> []
-      | (x,_,_)::_, [] -> raise (Error (loc, Orpat_vars x))
-      | [],(x,_,_)::_  -> raise (Error (loc, Orpat_vars x))
-      | (x,_,_)::_, (y,_,_)::_ ->
+      | (x,_,_,_)::_, [] -> raise (Error (loc, Orpat_vars x))
+      | [],(x,_,_,_)::_  -> raise (Error (loc, Orpat_vars x))
+      | (x,_,_,_)::_, (y,_,_,_)::_ ->
           let min_var =
             if Ident.name x < Ident.name y then x
             else y in
@@ -400,7 +401,7 @@ let check_recordpat_labels loc lbl_pat_list closed =
 
 (* Typing of patterns *)
 
-let rec type_pat env sp =
+let rec type_pat ?(allow_poly = false) env sp =
   let loc = sp.ppat_loc in
   match sp.ppat_desc with
     Ppat_any ->
@@ -411,12 +412,14 @@ let rec type_pat env sp =
         pat_env = env }
   | Ppat_var name ->
       let ty = newvar() in
-      let id = enter_variable loc name ty in
+      let id = enter_variable loc name ty sp.ppat_metadata in
       rp {
         pat_desc = Tpat_var id;
         pat_loc = loc;
         pat_type = ty;
         pat_env = env }
+  | Ppat_constraint(_, {ptyp_desc=Ptyp_poly _; ptyp_loc = loc}) when not allow_poly ->
+      raise (Error (loc, Polymorphic_type_not_allowed))
   | Ppat_constraint({ppat_desc=Ppat_var name; ppat_loc=loc},
                     ({ptyp_desc=Ptyp_poly _} as sty)) ->
       (* explicitly polymorphic type *)
@@ -428,7 +431,7 @@ let rec type_pat env sp =
           let _, ty' = instance_poly false tyl body in
           end_def ();
           generalize ty';
-          let id = enter_variable loc name ty' in
+          let id = enter_variable loc name ty' sp.ppat_metadata in
           rp { pat_desc = Tpat_var id;
                pat_loc = loc;
                pat_type = ty;
@@ -441,7 +444,7 @@ let rec type_pat env sp =
       let ty_var = build_as_type env q in
       end_def ();
       generalize ty_var;
-      let id = enter_variable loc name ty_var in
+      let id = enter_variable loc name ty_var sp.ppat_metadata in
       rp {
         pat_desc = Tpat_alias(q, id);
         pat_loc = loc;
@@ -559,7 +562,7 @@ let rec type_pat env sp =
       unify_pat env p2 p1.pat_type;
       let alpha_env =
         enter_orpat_variables loc env p1_variables p2_variables in
-      pattern_variables := p1_variables ;
+      pattern_variables := p1_variables ; (* todo: merge metadata from p2_variables *)
       rp {
         pat_desc = Tpat_or(p1, alpha_pat alpha_env p2, None);
         pat_loc = loc;
@@ -587,8 +590,8 @@ let get_ref r =
 let add_pattern_variables env =
   let pv = get_ref pattern_variables in
   List.fold_right
-    (fun (id, ty, loc) env ->
-       let e1 = Env.add_value id {val_type = ty; val_kind = Val_reg; val_metadata = []} env in
+    (fun (id, ty, loc, m) env ->
+       let e1 = Env.add_value id {val_type = ty; val_kind = Val_reg; val_metadata = m} env in
        Env.add_annot id (Annot.Iref_internal loc) e1;
     )
     pv env
@@ -601,7 +604,7 @@ let type_pattern env spat scope =
 
 let type_pattern_list env spatl scope =
   reset_pattern scope;
-  let patl = List.map (type_pat env) spatl in
+  let patl = List.map (type_pat ~allow_poly:true env) spatl in
   let new_env = add_pattern_variables env in
   (patl, new_env, get_ref pattern_force)
 
@@ -616,12 +619,12 @@ let type_class_arg_pattern cl_num val_env met_env l spat =
   if is_optional l then unify_pat val_env pat (type_option (newvar ()));
   let (pv, met_env) =
     List.fold_right
-      (fun (id, ty, _loc) (pv, env) ->
+      (fun (id, ty, _loc, m) (pv, env) ->
          let id' = Ident.create (Ident.name id) in
          ((id', id, ty)::pv,
           Env.add_value id' {val_type = ty;
                              val_kind = Val_ivar (Immutable, cl_num);
-                             val_metadata = [];
+                             val_metadata = m;
                             }
             env))
       !pattern_variables ([], met_env)
@@ -629,12 +632,12 @@ let type_class_arg_pattern cl_num val_env met_env l spat =
   let val_env = add_pattern_variables val_env in
   (pat, pv, val_env, met_env)
 
-let mkpat d = { ppat_desc = d; ppat_loc = Location.none }
+let mkpat d = { ppat_desc = d; ppat_loc = Location.none; ppat_metadata = [] }
 
 let type_self_pattern cl_num privty val_env met_env par_env spat =
   let spat =
     mkpat (Ppat_alias (mkpat(Ppat_alias (spat, "selfpat-*")),
-                       "selfpat-" ^ cl_num))
+                       ("selfpat-" ^ cl_num)))
   in
   reset_pattern None;
   let pat = type_pat val_env spat in
@@ -645,19 +648,19 @@ let type_self_pattern cl_num privty val_env met_env par_env spat =
   pattern_variables := [];
   let (val_env, met_env, par_env) =
     List.fold_right
-      (fun (id, ty, _loc) (val_env, met_env, par_env) ->
+      (fun (id, ty, _loc, m) (val_env, met_env, par_env) ->
          (Env.add_value id {val_type = ty;
                             val_kind = Val_unbound;
-                            val_metadata = [];
+                            val_metadata = m;
                            } val_env,
           Env.add_value id {val_type = ty;
                             val_kind = Val_self (meths, vars, cl_num, privty);
-                            val_metadata = [];
+                            val_metadata = m;
                            }
             met_env,
           Env.add_value id {val_type = ty;
                             val_kind = Val_unbound;
-                            val_metadata = [];
+                            val_metadata = m;
                            } par_env))
       pv (val_env, met_env, par_env)
   in
@@ -1356,6 +1359,8 @@ let rec type_exp env sexp =
         exp_loc = loc;
         exp_type = instance Predef.type_unit;
         exp_env = env }
+  | Pexp_constraint(_, Some {ptyp_desc = Ptyp_poly _; ptyp_loc = loc}, _) ->
+      raise (Error (loc, Polymorphic_type_not_allowed))
   | Pexp_constraint(sarg, sty, sty') ->
       let (arg, ty') =
         match (sty, sty') with
@@ -2039,12 +2044,16 @@ and type_expect ?in_function env sexp ty_expected =
           ppat_desc =
             Ppat_construct
               (Longident.Lident "Some",
-               Some {ppat_loc = default_loc; ppat_desc = Ppat_var "*sth*"},
-               false)},
+               Some {ppat_loc = default_loc; ppat_desc = Ppat_var "*sth*"; ppat_metadata = []},
+               false);
+          ppat_metadata = [];
+         },
          {pexp_loc = default_loc;
           pexp_desc = Pexp_ident(Longident.Lident "*sth*")};
          {ppat_loc = default_loc;
-          ppat_desc = Ppat_construct(Longident.Lident "None", None, false)},
+          ppat_desc = Ppat_construct(Longident.Lident "None", None, false);
+          ppat_metadata = [];
+         },
          default;
       ] in
       let smatch = {
@@ -2065,7 +2074,9 @@ and type_expect ?in_function env sexp ty_expected =
            l,
            None,
            [ {ppat_loc = loc;
-              ppat_desc = Ppat_var "*opt*"},
+              ppat_desc = Ppat_var "*opt*";
+              ppat_metadata = [];
+             },
              {pexp_loc = loc;
               pexp_desc =
                 Pexp_let(Default, [spat, smatch], sbody);
@@ -2476,3 +2487,5 @@ let report_error ppf = function
       report_unification_error ppf trace
         (fun ppf -> fprintf ppf "This %s has type" kind)
         (fun ppf -> fprintf ppf "which is less general than")
+  | Polymorphic_type_not_allowed ->
+      fprintf ppf "A polymorphic type is not allowed here."
diff --git a/typing/typecore.mli b/typing/typecore.mli
index a1a9ecd927..5e4be11e90 100644
--- a/typing/typecore.mli
+++ b/typing/typecore.mli
@@ -102,6 +102,7 @@ type error =
   | Not_a_variant_type of Longident.t
   | Incoherent_label_order
   | Less_general of string * (type_expr * type_expr) list
+  | Polymorphic_type_not_allowed
 
 exception Error of Location.t * error