diff options
| -rw-r--r-- | VERSION | 2 | ||||
| -rw-r--r-- | testsuite/tests/typing-gadts/test.ml | 71 | ||||
| -rw-r--r-- | testsuite/tests/typing-gadts/test.ml.principal.reference | 32 | ||||
| -rw-r--r-- | testsuite/tests/typing-gadts/test.ml.reference | 43 | ||||
| -rw-r--r-- | typing/parmatch.ml | 17 | ||||
| -rw-r--r-- | typing/printtyp.ml | 2 | ||||
| -rw-r--r-- | typing/typecore.ml | 67 |
7 files changed, 199 insertions, 35 deletions
@@ -1,4 +1,4 @@ -3.13.0-gadt (2010-10-22) +3.13.0-gadt (2011-06-15) # The version string is the first line of this file. # It must be in the format described in stdlib/sys.mli diff --git a/testsuite/tests/typing-gadts/test.ml b/testsuite/tests/typing-gadts/test.ml index a3de7ae6f..e79361acf 100644 --- a/testsuite/tests/typing-gadts/test.ml +++ b/testsuite/tests/typing-gadts/test.ml @@ -237,3 +237,74 @@ let f (type a) (x : a t) y = let f (type a) (x : a t) (y : a) = match x with Int -> y ;; + +(* Pattern matching *) + +type 'a t = + A of int | B of bool | C of float | D of 'a + +type _ ty = + | TE : 'a ty -> 'a array ty + | TA : int ty + | TB : bool ty + | TC : float ty + | TD : string -> bool ty + +let f : type a. a ty -> a t -> int = fun x y -> + match x, y with + | _, A z -> z + | _, B z -> if z then 1 else 2 + | _, C z -> truncate z + | TE TC, D [|1.0|] -> 14 + | TA, D 0 -> -1 + | TA, D z -> z + | TD "bye", D false -> 13 + | TD "hello", D true -> 12 + (* | TB, D z -> if z then 1 else 2 *) + | TC, D z -> truncate z + | _, D _ -> 0 +;; + +let f : type a. a ty -> a t -> int = fun x y -> + match x, y with + | _, A z -> z + | _, B z -> if z then 1 else 2 + | _, C z -> truncate z + | TE TC, D [|1.0|] -> 14 + | TA, D 0 -> -1 + | TA, D z -> z +;; (* warn *) + +let f : type a. a ty -> a t -> int = fun x y -> + match y, x with + | A z, _ -> z + | B z, _ -> if z then 1 else 2 + | C z, _ -> truncate z + | D [|1.0|], TE TC -> 14 + | D 0, TA -> -1 + | D z, TA -> z +;; (* fail *) + +type ('a,'b) pair = {right:'a; left:'b} + +let f : type a. a ty -> a t -> int = fun x y -> + match {left=x; right=y} with + | {left=_; right=A z} -> z + | {left=_; right=B z} -> if z then 1 else 2 + | {left=_; right=C z} -> truncate z + | {left=TE TC; right=D [|1.0|]} -> 14 + | {left=TA; right=D 0} -> -1 + | {left=TA; right=D z} -> z +;; (* fail *) + +type ('a,'b) pair = {left:'a; right:'b} + +let f : type a. a ty -> a t -> int = fun x y -> + match {left=x; right=y} with + | {left=_; right=A z} -> z + | {left=_; right=B z} -> if z then 1 else 2 + | {left=_; right=C z} -> truncate z + | {left=TE TC; right=D [|1.0|]} -> 14 + | {left=TA; right=D 0} -> -1 + | {left=TA; right=D z} -> z +;; (* warn *) diff --git a/testsuite/tests/typing-gadts/test.ml.principal.reference b/testsuite/tests/typing-gadts/test.ml.principal.reference index fae7dca83..6db24e1a5 100644 --- a/testsuite/tests/typing-gadts/test.ml.principal.reference +++ b/testsuite/tests/typing-gadts/test.ml.principal.reference @@ -128,4 +128,36 @@ Error: This expression has type int but an expression was expected of type a # val f : 'a t -> 'a -> 'a = <fun> # val f : 'a t -> 'a -> 'a = <fun> # val f : 'a t -> 'a -> int = <fun> +# type 'a t = A of int | B of bool | C of float | D of 'a +type 'a ty = + TE : 'b ty -> 'b array ty + | TA : int ty + | TB : bool ty + | TC : float ty + | TD : string -> bool ty +val f : 'a ty -> 'a t -> int = <fun> +# Characters 51-202: + ..match x, y with + | _, A z -> z + | _, B z -> if z then 1 else 2 + | _, C z -> truncate z + | TE TC, D [|1.0|] -> 14 + | TA, D 0 -> -1 + | TA, D z -> z +Warning 8: this pattern-matching is not exhaustive. +Here is an example of a value that is not matched: +(TE TC, D [| |]) +val f : 'a ty -> 'a t -> int = <fun> +# Characters 147-154: + | D [|1.0|], TE TC -> 14 + ^^^^^^^ +Error: This pattern matches values of type 'a array + but a pattern was expected which matches values of type a +# Characters 259-266: + | {left=TE TC; right=D [|1.0|]} -> 14 + ^^^^^^^ +Error: This pattern matches values of type 'a array + but a pattern was expected which matches values of type a +# type ('a, 'b) pair = { left : 'a; right : 'b; } +val f : 'a ty -> 'a t -> int = <fun> # diff --git a/testsuite/tests/typing-gadts/test.ml.reference b/testsuite/tests/typing-gadts/test.ml.reference index 810280759..95cd0cc76 100644 --- a/testsuite/tests/typing-gadts/test.ml.reference +++ b/testsuite/tests/typing-gadts/test.ml.reference @@ -117,4 +117,47 @@ Error: This expression has type int but an expression was expected of type a # val f : 'a t -> 'a -> 'a = <fun> # val f : 'a t -> 'a -> 'a = <fun> # val f : 'a t -> 'a -> 'a = <fun> +# type 'a t = A of int | B of bool | C of float | D of 'a +type 'a ty = + TE : 'b ty -> 'b array ty + | TA : int ty + | TB : bool ty + | TC : float ty + | TD : string -> bool ty +val f : 'a ty -> 'a t -> int = <fun> +# Characters 51-202: + ..match x, y with + | _, A z -> z + | _, B z -> if z then 1 else 2 + | _, C z -> truncate z + | TE TC, D [|1.0|] -> 14 + | TA, D 0 -> -1 + | TA, D z -> z +Warning 8: this pattern-matching is not exhaustive. +Here is an example of a value that is not matched: +(TE TC, D [| |]) +val f : 'a ty -> 'a t -> int = <fun> +# Characters 147-154: + | D [|1.0|], TE TC -> 14 + ^^^^^^^ +Error: This pattern matches values of type 'a array + but a pattern was expected which matches values of type a +# Characters 259-266: + | {left=TE TC; right=D [|1.0|]} -> 14 + ^^^^^^^ +Error: This pattern matches values of type 'a array + but a pattern was expected which matches values of type a +# Characters 92-334: + ..match {left=x; right=y} with + | {left=_; right=A z} -> z + | {left=_; right=B z} -> if z then 1 else 2 + | {left=_; right=C z} -> truncate z + | {left=TE TC; right=D [|1.0|]} -> 14 + | {left=TA; right=D 0} -> -1 + | {left=TA; right=D z} -> z +Warning 8: this pattern-matching is not exhaustive. +Here is an example of a value that is not matched: +{left=TE (TE _); right=D [| _ |]} +type ('a, 'b) pair = { left : 'a; right : 'b; } +val f : 'a ty -> 'a t -> int = <fun> # diff --git a/typing/parmatch.ml b/typing/parmatch.ml index e7f743c54..400246ba5 100644 --- a/typing/parmatch.ml +++ b/typing/parmatch.ml @@ -51,16 +51,19 @@ let is_absent_pat p = match p.pat_desc with | Tpat_variant (tag, _, row) -> is_absent tag row | _ -> false +(* let sort_fields args = Sort.list (fun (lbl1,_) (lbl2,_) -> lbl1.lbl_pos <= lbl2.lbl_pos) args +*) let records_args l1 l2 = - let l1 = sort_fields l1 - and l2 = sort_fields l2 in + (* let l1 = sort_fields l1 + and l2 = sort_fields l2 in *) + (* Invariant: fields are already sorted by Typecore.type_label_a_list *) let rec combine r1 r2 l1 l2 = match l1,l2 with - | [],[] -> r1,r2 + | [],[] -> List.rev r1, List.rev r2 | [],(_,p2)::rem2 -> combine (omega::r1) (p2::r2) [] rem2 | (_,p1)::rem1,[] -> combine (p1::r1) (omega::r2) rem1 [] | (lbl1,p1)::rem1, (lbl2,p2)::rem2 -> @@ -311,12 +314,14 @@ let extract_fields omegas arg = +(* let sort_record p = match p.pat_desc with | Tpat_record args -> make_pat (Tpat_record (sort_fields args)) p.pat_type p.pat_env | _ -> p +*) let all_record_args lbls = match lbls with | ({lbl_all=lbl_all},_)::_ -> @@ -411,7 +416,7 @@ let discr_pat q pss = match normalize_pat q with | {pat_desc= (Tpat_any | Tpat_record _)} as q -> - sort_record (acc_pat q pss) + (*sort_record*) (acc_pat q pss) | q -> q (* @@ -1565,7 +1570,7 @@ with | Empty -> lub p2 q and record_lubs l1 l2 = - let l1 = sort_fields l1 and l2 = sort_fields l2 in + (* let l1 = sort_fields l1 and l2 = sort_fields l2 in *) let rec lub_rec l1 l2 = match l1,l2 with | [],_ -> l2 | _,[] -> l1 @@ -1957,7 +1962,7 @@ let check_unused tdefs casel = p.pat_loc Warnings.Unused_pat) ps | Used -> () - with e -> assert false + with Empty | Not_an_adt | Not_found | NoGuard -> assert false end ; if has_guard act then diff --git a/typing/printtyp.ml b/typing/printtyp.ml index 868bfddce..6b02e1b91 100644 --- a/typing/printtyp.ml +++ b/typing/printtyp.ml @@ -431,7 +431,7 @@ and tree_of_typobject sch fi nm = | _ -> l) fields [] in let sorted_fields = - Sort.list (fun (n, _) (n', _) -> n <= n') present_fields in + List.sort (fun (n, _) (n', _) -> compare n n') present_fields in tree_of_typfields sch rest sorted_fields in let (fields, rest) = pr_fields fi in Otyp_object (fields, rest) diff --git a/typing/typecore.ml b/typing/typecore.ml index e6b85bc01..43af94b7b 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -405,21 +405,39 @@ let build_or_pat env loc lid = pat pats in (rp { r with pat_loc = loc },ty) +(* Records *) + let rec find_record_qual = function | [] -> None | (Longident.Ldot (modname, _), _) :: _ -> Some modname | _ :: rest -> find_record_qual rest -let type_label_a_list type_lid_a lid_a_list = - match find_record_qual lid_a_list with - | None -> List.map type_lid_a lid_a_list - | Some modname -> - List.map - (function - | (Longident.Lident id), sarg -> - type_lid_a (Longident.Ldot (modname, id), sarg) - | lid_a -> type_lid_a lid_a) - lid_a_list +let type_label_a_list ?labels env loc type_lbl_a lid_a_list = + let record_qual = find_record_qual lid_a_list in + let lbl_a_list = + List.map + (fun (lid, a) -> + match lid, labels, record_qual with + Longident.Lident s, Some labels, _ when Hashtbl.mem labels s -> + Hashtbl.find labels s, a + | Longident.Lident s, _, Some modname -> + Typetexp.find_label env loc (Longident.Ldot (modname, s)), a + | _ -> + Typetexp.find_label env loc lid, a) + lid_a_list in + (* Invariant: records are sorted in the typed tree *) + let lbl_a_list = + List.sort + (fun (lbl1,_) (lbl2,_) -> compare lbl1.lbl_pos lbl2.lbl_pos) + lbl_a_list + in + List.map type_lbl_a lbl_a_list + +let lid_of_label label = + match repr label.lbl_res with + | {desc = Tconstr(Path.Pdot(mpath,_,_),_,_)} -> + Longident.Ldot(lid_of_path mpath, label.lbl_name) + | _ -> Longident.Lident label.lbl_name (* Checks over the labels mentioned in a record pattern: no duplicate definitions (error); properly closed (warning) *) @@ -600,21 +618,15 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty = pat_loc = loc; pat_type = expected_ty; pat_env = !env } - | Ppat_record(lid_sp_list, closed) -> - let type_label_pat (lid, sarg) = - let label = - match lid, labels with - Longident.Lident s, Some labels when Hashtbl.mem labels s -> - Hashtbl.find labels s - | _ -> Typetexp.find_label !env loc lid - in + | Ppat_record(lid_sp_list, closed) -> + let type_label_pat (label, sarg) = begin_def (); let (vars, ty_arg, ty_res) = instance_label false label in if vars = [] then end_def (); begin try unify_pat_types loc !env ty_res expected_ty with Unify trace -> - raise(Error(loc, Label_mismatch(lid, trace))) + raise(Error(loc, Label_mismatch(lid_of_label label, trace))) end; let arg = type_pat sarg ty_arg in if vars <> [] then begin @@ -625,11 +637,12 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty = let tv = expand_head !env tv in tv.desc <> Tvar || tv.level <> generic_level in if List.exists instantiated vars then - raise (Error(loc, Polymorphic_label lid)) + raise (Error(loc, Polymorphic_label (lid_of_label label))) end; (label, arg) in - let lbl_pat_list = type_label_a_list type_label_pat lid_sp_list in + let lbl_pat_list = + type_label_a_list ?labels !env loc type_label_pat lid_sp_list in check_recordpat_labels loc lbl_pat_list closed; rp { pat_desc = Tpat_record lbl_pat_list; @@ -1484,7 +1497,7 @@ and type_expect ?in_function env sexp ty_expected = end | Pexp_record(lid_sexp_list, opt_sexp) -> let lbl_exp_list = - type_label_a_list (type_label_exp true env loc ty_expected) + type_label_a_list env loc (type_label_exp true env loc ty_expected) lid_sexp_list in let rec check_duplicates seen_pos lid_sexp lbl_exp = match (lid_sexp, lbl_exp) with @@ -1553,8 +1566,9 @@ and type_expect ?in_function env sexp ty_expected = exp_env = env } | Pexp_setfield(srecord, lid, snewval) -> let record = type_exp env srecord in + let label = Typetexp.find_label env loc lid in let (label, newval) = - type_label_exp false env loc record.exp_type (lid, snewval) in + type_label_exp false env loc record.exp_type (label, snewval) in if label.lbl_mut = Immutable then raise(Error(loc, Label_not_mutable lid)); rue { @@ -2042,9 +2056,8 @@ and type_expect ?in_function env sexp ty_expected = | Pexp_open (lid, e) -> type_expect (!type_open env sexp.pexp_loc lid) e ty_expected -and type_label_exp create env loc ty_expected (lid, sarg) = +and type_label_exp create env loc ty_expected (label, sarg) = (* Here also ty_expected may be at generic_level *) - let label = Typetexp.find_label env sarg.pexp_loc lid in begin_def (); if !Clflags.principal then (begin_def (); begin_def ()) ; let (vars, ty_arg, ty_res) = instance_label true label in @@ -2057,7 +2070,7 @@ and type_label_exp create env loc ty_expected (lid, sarg) = begin try unify env (instance ty_res) (instance ty_expected) with Unify trace -> - raise(Error(loc , Label_mismatch(lid, trace))) + raise(Error(loc , Label_mismatch(lid_of_label label, trace))) end; (* Instantiate so that we can generalize internal nodes *) let ty_arg = instance ty_arg in @@ -2068,7 +2081,7 @@ and type_label_exp create env loc ty_expected (lid, sarg) = end; if label.lbl_private = Private then raise(Error(loc, if create then Private_type ty_expected - else Private_label (lid, ty_expected))); + else Private_label (lid_of_label label, ty_expected))); let arg = let snap = if vars = [] then None else Some (Btype.snapshot ()) in let arg = type_argument env sarg ty_arg (instance ty_arg) in |