Polymorphic parameters

Author: lpw25

boot/menhir/menhirLib.ml

@@ -1241,7 +1241,6 @@ and transl_let ~scopes ?(add_regions=false) ?(in_structure=false)
         List.map
           (fun {vb_pat=pat} -> match pat.pat_desc with
               Tpat_var (id,_) -> id
-            | Tpat_alias ({pat_desc=Tpat_any}, id,_) -> id
             | _ -> assert false)
         pat_expr_list in
       let transl_case {vb_expr=expr; vb_attributes; vb_loc; vb_pat} id =

boot/menhir/menhirLib.mli

@@ -2299,6 +2299,12 @@ labeled_simple_pattern:
       { (Nolabel, None, $1) }
   | LPAREN LOCAL let_pattern RPAREN
       { (Nolabel, None, mkpat_stack $3 (make_loc $loc($2))) }
+  | LABEL LPAREN poly_pattern RPAREN
+      { (Labelled $1, None, $3) }
+  | LABEL LPAREN LOCAL poly_pattern RPAREN
+      { (Labelled $1, None, mkpat_stack $4 (make_loc $loc($2))) }
+  | LPAREN poly_pattern RPAREN
+      { (Nolabel, None, $2) }
 ;
 
 pattern_var:
@@ -2319,6 +2325,11 @@ label_let_pattern:
       { let lab, pat = x in
         lab,
         mkpat ~loc:$sloc (Ppat_constraint (pat, cty)) }
+  | x = label_var COLON
+          cty = mktyp (vars = typevar_list DOT ty = core_type { Ptyp_poly(vars, ty) })
+      { let lab, pat = x in
+        lab,
+        mkpat ~loc:$sloc (Ppat_constraint (pat, cty)) }
 ;
 %inline label_var:
     mkrhs(LIDENT)
@@ -2330,6 +2341,17 @@ let_pattern:
   | mkpat(pattern COLON core_type
       { Ppat_constraint($1, $3) })
       { $1 }
+  | poly_pattern
+      { $1 }
+;
+%inline poly_pattern:
+    mkpat(
+      pat = pattern
+      COLON
+      cty = mktyp(vars = typevar_list DOT ty = core_type
+              { Ptyp_poly(vars, ty) })
+        { Ppat_constraint(pat, cty) })
+      { $1 }
 ;
 
 %inline indexop_expr(dot, index, right):
@@ -3508,7 +3530,7 @@ strict_function_type:
   | mktyp(
       label = arg_label
       local = optional_local
-      domain = extra_rhs(tuple_type)
+      domain = extra_rhs(param_type)
       MINUSGREATER
       codomain = strict_function_type
         { Ptyp_arrow(label, mktyp_local_if local domain $loc(local), codomain) }
@@ -3517,7 +3539,7 @@ strict_function_type:
   | mktyp(
       label = arg_label
       arg_local = optional_local
-      domain = extra_rhs(tuple_type)
+      domain = extra_rhs(param_type)
       MINUSGREATER
       ret_local = optional_local
       codomain = tuple_type
@@ -3543,6 +3565,15 @@ strict_function_type:
   | LOCAL
     { true }
 ;
+%inline param_type:
+  | mktyp(
+    LPAREN vars = typevar_list DOT ty = core_type RPAREN
+      { Ptyp_poly(vars, ty) }
+    )
+    { $1 }
+  | ty = tuple_type
+    { ty }
+;
 (* Tuple types include:
    - atomic types (see below);
    - proper tuple types:                  int * int * int list

boot/menhir/parser.ml

@@ -74,18 +74,18 @@ Error: Uninterpreted extension 'ext'.
 
 let rec f x = ( (), () : _ -> _ -> _ )
 [%%expect{|
-Line 3, characters 14-38:
+Line 3, characters 16-22:
 3 | let rec f x = ( (), () : _ -> _ -> _ )
-                  ^^^^^^^^^^^^^^^^^^^^^^^^
+                    ^^^^^^
 Error: This expression has type 'a * 'b
        but an expression was expected of type 'c -> 'd -> 'e
 |}]
 
 let rec g x = ( ((), ()) : _ -> _ :> _ )
 [%%expect{|
-Line 1, characters 14-40:
+Line 1, characters 16-24:
 1 | let rec g x = ( ((), ()) : _ -> _ :> _ )
-                  ^^^^^^^^^^^^^^^^^^^^^^^^^^
+                    ^^^^^^^^
 Error: This expression has type 'a * 'b
        but an expression was expected of type 'c -> 'd
 |}]

lambda/translcore.ml

@@ -541,10 +541,7 @@ Error: Type
            < cmp : int_comparable2 -> int; set_x : int -> unit; x : int >
        is not a subtype of
          int_comparable = < cmp : int_comparable -> int; x : int >
-       Type int_comparable = < cmp : int_comparable -> int; x : int >
-       is not a subtype of
-         int_comparable2 =
-           < cmp : int_comparable2 -> int; set_x : int -> unit; x : int >
+       Type int_comparable is not a subtype of int_comparable2
        The first object type has no method set_x
 |}];;      (* Fail : 'a comp2 is not a subtype *)
 (new sorted_list ())#add c2;;

parsing/parser.mly

@@ -199,7 +199,13 @@ let rec extract_last_arrow desc =
       try extract_last_arrow r
       with Bad_printing_function -> res
 
-let extract_target_type ty = fst (extract_last_arrow ty)
+let extract_target_type ty =
+  let ty = fst (extract_last_arrow ty) in
+  match Ctype.filter_mono ty with
+  | exception Ctype.Filter_mono_failed ->
+      raise Bad_printing_function
+  | ty -> ty
+
 let extract_target_parameters ty =
   let ty = extract_target_type ty |> Ctype.expand_head !toplevel_env in
   match get_desc ty with
@@ -246,10 +252,12 @@ let match_generic_printer_type desc path args printer_type =
     List.map (fun ty_var -> Ctype.newconstr printer_type [ty_var]) args in
   let ty_expected =
     List.fold_right
-      (fun ty_arg ty -> Ctype.newty
-         (Tarrow ((Asttypes.Nolabel,Alloc_mode.global,Alloc_mode.global),
-                  ty_arg, ty,
-                  commu_var ())))
+      (fun ty_arg ty ->
+         let arrow_desc =
+           Asttypes.Nolabel,Alloc_mode.global,Alloc_mode.global
+         in
+         Ctype.newty
+           (Tarrow (arrow_desc, Ctype.newmono ty_arg, ty, commu_var ())))
       ty_args (Ctype.newconstr printer_type [ty_target]) in
   begin try
     Ctype.unify !toplevel_env

testsuite/tests/typing-misc/typecore_errors.ml

@@ -124,6 +124,7 @@ let newmarkedgenvar () =
 let is_Tvar ty = match get_desc ty with Tvar _ -> true | _ -> false
 let is_Tunivar ty = match get_desc ty with Tunivar _ -> true | _ -> false
 let is_Tconstr ty = match get_desc ty with Tconstr _ -> true | _ -> false
+let is_Tpoly ty = match get_desc ty with Tpoly _ -> true | _ -> false
 
 let dummy_method = "*dummy method*"
 
@@ -601,6 +602,7 @@ let rec signature_of_class_type =
   | Cty_signature sign     -> sign
   | Cty_arrow (_, _, cty)   -> signature_of_class_type cty
 
+
 let rec class_body cty =
   match cty with
     Cty_constr _ ->
@@ -702,6 +704,26 @@ let instance_variable_type label sign =
   | (_, _, ty) -> ty
   | exception Not_found -> assert false
 
+                  (********************************)
+                  (*  Utilities for poly types    *)
+                  (********************************)
+
+let tpoly_is_mono ty =
+  match get_desc ty with
+  | Tpoly(_, []) -> true
+  | Tpoly(_, _ :: _) -> false
+  | _ -> assert false
+
+let tpoly_get_poly ty =
+  match get_desc ty with
+  | Tpoly(ty, vars) -> (ty, vars)
+  | _ -> assert false
+
+let tpoly_get_mono ty =
+  match get_desc ty with
+  | Tpoly(ty, []) -> ty
+  | _ -> assert false
+
                   (**********************************)
                   (*  Utilities for level-marking   *)
                   (**********************************)

testsuite/tests/typing-objects/Exemples.ml

@@ -76,6 +76,8 @@ val newmarkedgenvar: unit -> type_expr
 val is_Tvar: type_expr -> bool
 val is_Tunivar: type_expr -> bool
 val is_Tconstr: type_expr -> bool
+val is_Tpoly: type_expr -> bool
+
 val dummy_method: label
 
 (**** polymorphic variants ****)
@@ -105,6 +107,13 @@ val proxy: type_expr -> type_expr
         (* Return the proxy representative of the type: either itself
            or a row variable *)
 
+(* Poly types. *)
+
+(* These three functions can only be called on [Tpoly] nodes. *)
+val tpoly_is_mono : type_expr -> bool
+val tpoly_get_mono : type_expr -> type_expr
+val tpoly_get_poly : type_expr -> type_expr * type_expr list
+
 (**** Utilities for private abbreviations with fixed rows ****)
 val row_of_type: type_expr -> type_expr
 val has_constr_row: type_expr -> bool