Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Add injectivity annotations (#9500)

master
Jacques Garrigue 2020-06-15 13:51:50 +02:00 committed by GitHub
parent 5a9c5dd5b0
commit 603506aa34
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
20 changed files with 1664 additions and 964 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
Changes
View File

@ -3,6 +3,16 @@ Working version
### Language features:
* #9500: Injectivity annotations
One can now mark type parameters as injective, which is useful for
abstract types:
module Vec : sig type !'a t end = struct type 'a t = 'a array end
On non-abstract types, this can be used to check the injectivity of
parameters. Since all parameters of record and sum types are by definition
injective, this only makes sense for type abbreviations:
type !'a t = 'a list
(Jacques Garrigue, review by Jeremy Yallop and Leo White)
### Runtime system:
- #1795, #9543: modernize signal handling on Linux i386, PowerPC, and s390x,

2053
boot/menhir/parser.ml
View File

File diff suppressed because one or more lines are too long

24
manual/manual/refman/typedecl.etex
View File

@ -36,12 +36,18 @@ type-params:
| '(' type-param { "," type-param } ')'
;
type-param:
[variance] "'" ident
[ext-variance] "'" ident
;
ext-variance:
variance [injectivity]
| injectivity [variance]
;
variance:
'+'
| '-'
;
injectivity: '!'
;
record-decl:
'{' field-decl { ';' field-decl } [';'] '}'
;
@ -88,7 +94,9 @@ for type constructors with one parameter, or a list of type variables
@"('"ident_1,\ldots,"'"ident_n")"@, for type constructors with several
parameters. Each type parameter may be prefixed by a variance
constraint @"+"@ (resp. @"-"@) indicating that the parameter is
covariant (resp. contravariant). These type parameters can appear in
covariant (resp. contravariant), and an injectivity annotation @"!"@
indicating that the parameter can be deduced from the whole type.
These type parameters can appear in
the type expressions of the right-hand side of the definition,
optionally restricted by a variance constraint ; {\em i.e.\/} a
covariant parameter may only appear on the right side of a functional
@ -200,6 +208,18 @@ constraints, the variance properties of the type constructor
are inferred from its definition, and the variance annotations are
only checked for conformance with the definition.
Injectivity annotations are only necessary for abstract types and
private row types, since they can otherwise be deduced from the type
declaration: all parameters are injective for record and variant type
declarations (including extensible types); for type abbreviations a
parameter is injective if it has an injective occurrence in its
defining equation (be it private or not). For constrained type
parameters in type abbreviations, they are injective if either they
appear at an injective position in the body, or if all their type
variables are injective; in particular, if a constrained type
parameter contains a variable that doesn't appear in the body, it
cannot be injective.
\ikwd{constraint\@\texttt{constraint}}
The construct @ 'constraint' "'" ident '=' typexpr @ allows the
specification of

9
parsing/ast_helper.mli
View File

@ -204,7 +204,7 @@ module Val:
module Type:
sig
val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text ->
?params:(core_type * variance) list ->
?params:(core_type * (variance * injectivity)) list ->
?cstrs:(core_type * core_type * loc) list ->
?kind:type_kind -> ?priv:private_flag -> ?manifest:core_type -> str ->
type_declaration
@ -220,8 +220,8 @@ module Type:
module Te:
sig
val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs ->
?params:(core_type * variance) list -> ?priv:private_flag ->
lid -> extension_constructor list -> type_extension
?params:(core_type * (variance * injectivity)) list ->
?priv:private_flag -> lid -> extension_constructor list -> type_extension
val mk_exception: ?loc:loc -> ?attrs:attrs -> ?docs:docs ->
extension_constructor -> type_exception
@ -454,7 +454,8 @@ module Cf:
module Ci:
sig
val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text ->
?virt:virtual_flag -> ?params:(core_type * variance) list ->
?virt:virtual_flag ->
?params:(core_type * (variance * injectivity)) list ->
str -> 'a -> 'a class_infos
end

6
parsing/asttypes.mli
View File

@ -60,4 +60,8 @@ type 'a loc = 'a Location.loc = {
type variance =
| Covariant
| Contravariant
| Invariant
| NoVariance
type injectivity =
| Injective
| NoInjectivity

17
parsing/parser.mly
View File

@ -2942,9 +2942,20 @@ type_variable:
;
type_variance:
/* empty */ { Invariant }
| PLUS { Covariant }
| MINUS { Contravariant }
/* empty */ { NoVariance, NoInjectivity }
| PLUS { Covariant, NoInjectivity }
| MINUS { Contravariant, NoInjectivity }
| BANG { NoVariance, Injective }
| PLUS BANG | BANG PLUS { Covariant, Injective }
| MINUS BANG | BANG MINUS { Contravariant, Injective }
| INFIXOP2
{ if $1 = "+!" then Covariant, Injective else
if $1 = "-!" then Contravariant, Injective else
expecting $loc($1) "type_variance" }
| PREFIXOP
{ if $1 = "!+" then Covariant, Injective else
if $1 = "!-" then Contravariant, Injective else
expecting $loc($1) "type_variance" }
;
(* A sequence of constructor declarations is either a single BAR, which

6
parsing/parsetree.mli
View File

@ -429,7 +429,7 @@ and value_description =
and type_declaration =
{
ptype_name: string loc;
ptype_params: (core_type * variance) list;
ptype_params: (core_type * (variance * injectivity)) list;
(* ('a1,...'an) t; None represents _*)
ptype_cstrs: (core_type * core_type * Location.t) list;
(* ... constraint T1=T1' ... constraint Tn=Tn' *)
@ -497,7 +497,7 @@ and constructor_arguments =
and type_extension =
{
ptyext_path: Longident.t loc;
ptyext_params: (core_type * variance) list;
ptyext_params: (core_type * (variance * injectivity)) list;
ptyext_constructors: extension_constructor list;
ptyext_private: private_flag;
ptyext_loc: Location.t;
@ -598,7 +598,7 @@ and class_type_field_desc =
and 'a class_infos =
{
pci_virt: virtual_flag;
pci_params: (core_type * variance) list;
pci_params: (core_type * (variance * injectivity)) list;
pci_name: string loc;
pci_expr: 'a;
pci_loc: Location.t;

10
parsing/pprintast.ml
View File

@ -118,10 +118,14 @@ let override = function
(* variance encoding: need to sync up with the [parser.mly] *)
let type_variance = function
| Invariant -> ""
| NoVariance -> ""
| Covariant -> "+"
| Contravariant -> "-"
let type_injectivity = function
| NoInjectivity -> ""
| Injective -> "!"
type construct =
[ `cons of expression list
| `list of expression list
@ -1434,8 +1438,8 @@ and structure_item ctxt f x =
item_extension ctxt f e;
item_attributes ctxt f a
and type_param ctxt f (ct, a) =
pp f "%s%a" (type_variance a) (core_type ctxt) ct
and type_param ctxt f (ct, (a,b)) =
pp f "%s%s%a" (type_variance a) (type_injectivity b) (core_type ctxt) ct
and type_params ctxt f = function
| [] -> ()

4
testsuite/tests/printing-types/disambiguation.ml
View File

@ -6,14 +6,14 @@ type 'a x = private [> `x] as 'a;;
[%%expect {|
Line 1:
Error: Type declarations do not match:
type 'a x = private [> `x ] constraint 'a = 'a x
type !'a x = private [> `x ] constraint 'a = 'a x
is not included in
type 'a x
Their constraints differ.
|}, Principal{|
Line 1:
Error: Type declarations do not match:
type 'a x = private 'a constraint 'a = [> `x ]
type !'a x = private 'a constraint 'a = [> `x ]
is not included in
type 'a x
Their constraints differ.

375
testsuite/tests/typing-misc/injectivity.ml Normal file
View File

@ -0,0 +1,375 @@
(* TEST
* expect
*)
(* Syntax *)
type ! 'a t = private 'a ref
type +! 'a t = private 'a
type -!'a t = private 'a -> unit
type + !'a t = private 'a
type - ! 'a t = private 'a -> unit
type !+ 'a t = private 'a
type !-'a t = private 'a -> unit
type ! +'a t = private 'a
type ! -'a t = private 'a -> unit
[%%expect{|
type 'a t = private 'a ref
type +'a t = private 'a
type -'a t = private 'a -> unit
type +'a t = private 'a
type -'a t = private 'a -> unit
type +'a t = private 'a
type -'a t = private 'a -> unit
type +'a t = private 'a
type -'a t = private 'a -> unit
|}]
(* Expect doesn't support syntax errors
type -+ 'a t
[%%expect]
type -!! 'a t
[%%expect]
*)
(* Define an injective abstract type, and use it in a GADT
and a constrained type *)
module M : sig type +!'a t end = struct type 'a t = 'a list end
[%%expect{|
module M : sig type +!'a t end
|}]
type _ t = M : 'a -> 'a M.t t (* OK *)
type 'a u = 'b constraint 'a = 'b M.t
[%%expect{|
type _ t = M : 'a -> 'a M.t t
type 'a u = 'b constraint 'a = 'b M.t
|}]
(* Without the injectivity annotation, the cannot be defined *)
module N : sig type +'a t end = struct type 'a t = 'a list end
[%%expect{|
module N : sig type +'a t end
|}]
type _ t = N : 'a -> 'a N.t t (* KO *)
[%%expect{|
Line 1, characters 0-29:
1 | type _ t = N : 'a -> 'a N.t t (* KO *)
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: In this definition, a type variable cannot be deduced
from the type parameters.
|}]
type 'a u = 'b constraint 'a = 'b N.t
[%%expect{|
Line 1, characters 0-37:
1 | type 'a u = 'b constraint 'a = 'b N.t
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: In this definition, a type variable cannot be deduced
from the type parameters.
|}]
(* Of course, the internal type should be injective in this parameter *)
module M : sig type +!'a t end = struct type 'a t = int end (* KO *)
[%%expect{|
Line 1, characters 33-59:
1 | module M : sig type +!'a t end = struct type 'a t = int end (* KO *)
^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: Signature mismatch:
Modules do not match:
sig type 'a t = int end
is not included in
sig type +!'a t end
Type declarations do not match:
type 'a t = int
is not included in
type +!'a t
Their variances do not agree.
|}]
(* Annotations in type abbreviations allow to check injectivity *)
type !'a t = 'a list
type !'a u = int
[%%expect{|
type 'a t = 'a list
Line 2, characters 0-16:
2 | type !'a u = int
^^^^^^^^^^^^^^^^
Error: In this definition, expected parameter variances are not satisfied.
The 1st type parameter was expected to be injective invariant,
but it is unrestricted.
|}]
type !'a t = private 'a list
type !'a t = private int
[%%expect{|
type 'a t = private 'a list
Line 2, characters 0-24:
2 | type !'a t = private int
^^^^^^^^^^^^^^^^^^^^^^^^
Error: In this definition, expected parameter variances are not satisfied.
The 1st type parameter was expected to be injective invariant,
but it is unrestricted.
|}]
(* Can also use to add injectivity in private row types *)
module M : sig type !'a t = private < m : int ; .. > end =
struct type 'a t = < m : int ; n : 'a > end
type 'a u = M : 'a -> 'a M.t u
[%%expect{|
module M : sig type !'a t = private < m : int; .. > end
type 'a u = M : 'a -> 'a M.t u
|}]
module M : sig type 'a t = private < m : int ; .. > end =
struct type 'a t = < m : int ; n : 'a > end
type 'a u = M : 'a -> 'a M.t u
[%%expect{|
module M : sig type 'a t = private < m : int; .. > end
Line 3, characters 0-30:
3 | type 'a u = M : 'a -> 'a M.t u
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: In this definition, a type variable cannot be deduced
from the type parameters.
|}]
module M : sig type !'a t = private < m : int ; .. > end =
struct type 'a t = < m : int > end
[%%expect{|
Line 2, characters 2-36:
2 | struct type 'a t = < m : int > end
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: Signature mismatch:
Modules do not match:
sig type 'a t = < m : int > end
is not included in
sig type !'a t = private < m : int; .. > end
Type declarations do not match:
type 'a t = < m : int >
is not included in
type !'a t
Their variances do not agree.
|}]
(* Injectivity annotations are inferred correctly for constrained parameters *)
type 'a t = 'b constraint 'a = <b:'b>
type !'b u = <b:'b> t
[%%expect{|
type 'a t = 'b constraint 'a = < b : 'b >
type 'b u = < b : 'b > t
|}]
(* Ignore injectivity for nominal types *)
type !_ t = X
[%%expect{|
type _ t = X
|}]
(* Beware of constrained parameters *)
type (_,_) eq = Refl : ('a,'a) eq
type !'a t = private 'b constraint 'a = < b : 'b > (* OK *)
[%%expect{|
type (_, _) eq = Refl : ('a, 'a) eq
type 'a t = private 'b constraint 'a = < b : 'b >
|}]
type !'a t = private 'b constraint 'a = < b : 'b; c : 'c > (* KO *)
module M : sig type !'a t constraint 'a = < b : 'b; c : 'c > end =
struct type nonrec 'a t = 'a t end
let inj_t : type a b. (<b:_; c:a> M.t, <b:_; c:b> M.t) eq -> (a, b) eq =
fun Refl -> Refl
[%%expect{|
Line 1, characters 0-58:
1 | type !'a t = private 'b constraint 'a = < b : 'b; c : 'c > (* KO *)
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: In this definition, expected parameter variances are not satisfied.
The 1st type parameter was expected to be injective invariant,
but it is unrestricted.
|}]
(* One cannot assume that abstract types are not injective *)
module F(X : sig type 'a t end) = struct
type 'a u = unit constraint 'a = 'b X.t
type _ x = G : 'a -> 'a u x
end
module M = F(struct type 'a t = 'a end)
let M.G (x : bool) = M.G 3
[%%expect{|
Line 3, characters 2-29:
3 | type _ x = G : 'a -> 'a u x
^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: In this definition, a type variable cannot be deduced
from the type parameters.
|}]
(* Try to be clever *)
type 'a t = unit
type !'a u = int constraint 'a = 'b t
[%%expect{|
type 'a t = unit
type 'a u = int constraint 'a = 'b t
|}]
module F(X : sig type 'a t end) = struct
type !'a u = 'b constraint 'a = <b : 'b> constraint 'b = _ X.t
end
[%%expect{|
module F :
functor (X : sig type 'a t end) ->
sig type 'a u = 'b X.t constraint 'a = < b : 'b X.t > end
|}]
(* But not too clever *)
module F(X : sig type 'a t end) = struct
type !'a u = 'b X.t constraint 'a = <b : 'b X.t>
end
[%%expect{|
Line 2, characters 2-50:
2 | type !'a u = 'b X.t constraint 'a = <b : 'b X.t>
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: In this definition, expected parameter variances are not satisfied.
The 1st type parameter was expected to be injective invariant,
but it is unrestricted.
|}]
module F(X : sig type 'a t end) = struct
type !'a u = 'b constraint 'a = <b : _ X.t as 'b>
end
[%%expect{|
module F :
functor (X : sig type 'a t end) ->
sig type 'a u = 'b X.t constraint 'a = < b : 'b X.t > end
|}, Principal{|
Line 2, characters 2-51:
2 | type !'a u = 'b constraint 'a = <b : _ X.t as 'b>
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: In this definition, expected parameter variances are not satisfied.
The 1st type parameter was expected to be injective invariant,
but it is unrestricted.
|}]
(* Motivating examples with GADTs *)
type (_,_) eq = Refl : ('a,'a) eq
module Vec : sig
type +!'a t
val make : int -> (int -> 'a) -> 'a t
val get : 'a t -> int -> 'a
end = struct
type 'a t = Vec of Obj.t array
let make n f = Vec (Obj.magic Array.init n f)
let get (Vec v) n = Obj.obj (Array.get v n)
end
type _ ty =
| Int : int ty
| Fun : 'a ty * 'b ty -> ('a -> 'b) ty
| Vec : 'a ty -> 'a Vec.t ty
type dyn = Dyn : 'a ty * 'a -> dyn
let rec eq_ty : type a b. a ty -> b ty -> (a,b) eq option =
fun t1 t2 -> match t1, t2 with
| Int, Int -> Some Refl
| Fun (t11, t12), Fun (t21, t22) ->
begin match eq_ty t11 t21, eq_ty t12 t22 with
| Some Refl, Some Refl -> Some Refl
| _ -> None
end
| Vec t1, Vec t2 ->
begin match eq_ty t1 t2 with
| Some Refl -> Some Refl
| None -> None
end
| _ -> None
let undyn : type a. a ty -> dyn -> a option =
fun t1 (Dyn (t2, v)) ->
match eq_ty t1 t2 with
| Some Refl -> Some v
| None -> None
let v = Vec.make 3 (fun n -> Vec.make n (fun m -> (m*n)))
let int_vec_vec = Vec (Vec Int)
let d = Dyn (int_vec_vec, v)
let Some v' = undyn int_vec_vec d
[%%expect{|
type (_, _) eq = Refl : ('a, 'a) eq
module Vec :
sig
type +!'a t
val make : int -> (int -> 'a) -> 'a t
val get : 'a t -> int -> 'a
end
type _ ty =
Int : int ty
| Fun : 'a ty * 'b ty -> ('a -> 'b) ty
| Vec : 'a ty -> 'a Vec.t ty
type dyn = Dyn : 'a ty * 'a -> dyn
val eq_ty : 'a ty -> 'b ty -> ('a, 'b) eq option = <fun>
val undyn : 'a ty -> dyn -> 'a option = <fun>
val v : int Vec.t Vec.t = <abstr>
val int_vec_vec : int Vec.t Vec.t ty = Vec (Vec Int)
val d : dyn = Dyn (Vec (Vec Int), <poly>)
Line 47, characters 4-11:
47 | let Some v' = undyn int_vec_vec d
^^^^^^^
Warning 8: this pattern-matching is not exhaustive.
Here is an example of a case that is not matched:
None
val v' : int Vec.t Vec.t = <abstr>
|}]
(* Break it (using magic) *)
module Vec : sig
type +!'a t
val eqt : ('a t, 'b t) eq
end = struct
type 'a t = 'a
let eqt = Obj.magic Refl (* Never do that! *)
end
type _ ty =
| Int : int ty
| Vec : 'a ty -> 'a Vec.t ty
let coe : type a b. (a,b) eq -> a ty -> b ty =
fun Refl x -> x
let eq_int_any : type a. (int, a) eq =
let vec_ty : a Vec.t ty = coe Vec.eqt (Vec Int) in
let Vec Int = vec_ty in Refl
[%%expect{|
module Vec : sig type +!'a t val eqt : ('a t, 'b t) eq end
type _ ty = Int : int ty | Vec : 'a ty -> 'a Vec.t ty
val coe : ('a, 'b) eq -> 'a ty -> 'b ty = <fun>
Line 17, characters 2-30:
17 | let Vec Int = vec_ty in Refl
^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Warning 8: this pattern-matching is not exhaustive.
Here is an example of a case that is not matched:
Vec (Vec Int)
val eq_int_any : (int, 'a) eq = Refl
|}]
(* Not directly related: injectivity and constraints *)
type 'a t = 'b constraint 'a = <b : 'b>
class type ['a] ct = object method m : 'b constraint 'a = < b : 'b > end
[%%expect{|
type 'a t = 'b constraint 'a = < b : 'b >
class type ['a] ct = object constraint 'a = < b : 'b > method m : 'b end
|}]
type _ u = M : 'a -> 'a t u (* OK *)
[%%expect{|
type _ u = M : < b : 'a > -> < b : 'a > t u
|}]
type _ v = M : 'a -> 'a ct v (* OK *)
[%%expect{|
type _ v = M : < b : 'a > -> < b : 'a > ct v
|}]
type 'a t = 'b constraint 'a = <b : 'b; c : 'c>
type _ u = M : 'a -> 'a t u (* KO *)
[%%expect{|
type 'a t = 'b constraint 'a = < b : 'b; c : 'c >
Line 2, characters 0-27:
2 | type _ u = M : 'a -> 'a t u (* KO *)
^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: In this definition, a type variable cannot be deduced
from the type parameters.
|}]

2
testsuite/tests/typing-private/private.compilers.principal.reference
View File

@ -114,7 +114,7 @@ type t = private < x : int >
type t = private < x : int >
Line 1:
Error: Type declarations do not match:
type 'a t = private 'a constraint 'a = < x : int; .. >
type !'a t = private 'a constraint 'a = < x : int; .. >
is not included in
type 'a t
Their constraints differ.

2
testsuite/tests/typing-private/private.compilers.reference
View File

@ -114,7 +114,7 @@ type t = private < x : int >
type t = private < x : int >
Line 1:
Error: Type declarations do not match:
type 'a t = private < x : int; .. > constraint 'a = 'a t
type !'a t = private < x : int; .. > constraint 'a = 'a t
is not included in
type 'a t
Their constraints differ.

8
typing/oprint.ml
View File

@ -400,9 +400,11 @@ let out_type = ref print_out_type
let print_type_parameter ppf s =
if s = "_" then fprintf ppf "_" else pr_var ppf s
let type_parameter ppf (ty, (co, cn)) =
fprintf ppf "%s%a"
(if not cn then "+" else if not co then "-" else "")
let type_parameter ppf (ty, (var, inj)) =
let open Asttypes in
fprintf ppf "%s%s%a"
(match var with Covariant -> "+" | Contravariant -> "-" | NoVariance -> "")
(match inj with Injective -> "!" | NoInjectivity -> "")
print_type_parameter ty
let print_out_class_params ppf =

8
typing/outcometree.mli
View File

@ -56,6 +56,8 @@ type out_value =
| Oval_tuple of out_value list
| Oval_variant of string * out_value option
type out_type_param = string * (Asttypes.variance * Asttypes.injectivity)
type out_type =
| Otyp_abstract
| Otyp_open
@ -97,10 +99,10 @@ type out_module_type =
| Omty_alias of out_ident
and out_sig_item =
| Osig_class of
bool * string * (string * (bool * bool)) list * out_class_type *
bool * string * out_type_param list * out_class_type *
out_rec_status
| Osig_class_type of
bool * string * (string * (bool * bool)) list * out_class_type *
bool * string * out_type_param list * out_class_type *
out_rec_status
| Osig_typext of out_extension_constructor * out_ext_status
| Osig_modtype of string * out_module_type
@ -110,7 +112,7 @@ and out_sig_item =
| Osig_ellipsis
and out_type_decl =
{ otype_name: string;
otype_params: (string * (bool * bool)) list;
otype_params: out_type_param list;
otype_type: out_type;
otype_private: Asttypes.private_flag;
otype_immediate: Type_immediacy.t;

25
typing/printtyp.ml
View File

@ -1229,8 +1229,20 @@ let rec tree_of_type_decl id decl =
let vari =
List.map2
(fun ty v ->
if abstr || not (is_Tvar (repr ty)) then Variance.get_upper v
else (true,true))
let is_var = is_Tvar (repr ty) in
if abstr || not is_var then
let inj =
decl.type_kind = Type_abstract && Variance.mem Inj v &&
match decl.type_manifest with
| None -> true
| Some ty -> (* only abstract or private row types *)
decl.type_private = Private &&
Btype.is_constr_row ~allow_ident:true (Btype.row_of_type ty)
and (co, cn) = Variance.get_upper v in
(if not cn then Covariant else
if not co then Contravariant else NoVariance),
(if inj then Injective else NoInjectivity)
else (NoVariance, NoInjectivity))
decl.type_params decl.type_variance
in
(Ident.name id,
@ -1503,10 +1515,15 @@ let tree_of_class_param param variance =
(match tree_of_typexp true param with
Otyp_var (_, s) -> s
| _ -> "?"),
if is_Tvar (repr param) then (true, true) else variance
if is_Tvar (repr param) then Asttypes.(NoVariance, NoInjectivity)
else variance
let class_variance =
List.map Variance.(fun v -> mem May_pos v, mem May_neg v)
let open Variance in let open Asttypes in
List.map (fun v ->
(if not (mem May_pos v) then Contravariant else
if not (mem May_neg v) then Covariant else NoVariance),
NoInjectivity)
let tree_of_class_declaration id cl rs =
let params = filter_params cl.cty_params in

48
typing/typedecl_variance.ml
View File

@ -131,10 +131,16 @@ let make p n i =
let open Variance in
set May_pos p (set May_neg n (set May_weak n (set Inj i null)))
let injective = Variance.(set Inj true null)
let compute_variance_type env ~check (required, loc) decl tyl =
(* Requirements *)
let check_injectivity = decl.type_kind = Type_abstract in
let required =
List.map (fun (c,n,i) -> if c || n then (c,n,i) else (true,true,i))
List.map
(fun (c,n,i) ->
let i = if check_injectivity then i else false in
if c || n then (c,n,i) else (true,true,i))
required
in
(* Prepare *)
@ -146,6 +152,32 @@ let compute_variance_type env ~check (required, loc) decl tyl =
(fun (cn,ty) ->
compute_variance env tvl (if cn then full else covariant) ty)
tyl;
(* Infer injectivity of constrained parameters *)
if check_injectivity then
List.iter
(fun ty ->
if Btype.is_Tvar ty || mem Inj (get_variance ty tvl) then () else
let visited = ref TypeSet.empty in
let rec check ty =
let ty = Ctype.repr ty in
if TypeSet.mem ty !visited then () else begin
visited := TypeSet.add ty !visited;
if mem Inj (get_variance ty tvl) then () else
match ty.desc with
| Tvar _ -> raise Exit
| Tconstr _ ->
begin try
Btype.iter_type_expr check ty
with Exit ->
let ty' = Ctype.expand_head_opt env ty in
if ty == ty' then raise Exit else check ty'
end
| _ -> Btype.iter_type_expr check ty
end
in
try check ty; compute_variance env tvl injective ty
with Exit -> ())
params;
if check then begin
(* Check variance of parameters *)
let pos = ref 0 in
@ -154,7 +186,7 @@ let compute_variance_type env ~check (required, loc) decl tyl =
incr pos;
let var = get_variance ty tvl in
let (co,cn) = get_upper var and ij = mem Inj var in
if Btype.is_Tvar ty && (co && not c || cn && not n || not ij && i)
if Btype.is_Tvar ty && (co && not c || cn && not n) || not ij && i
then raise (Error(loc, Bad_variance
(Variance_not_satisfied !pos,
(co,cn,ij),
@ -350,10 +382,14 @@ let property : (prop, req) Typedecl_properties.property =
check;
}
let transl_variance : Asttypes.variance -> _ = function
| Covariant -> (true, false, false)
| Contravariant -> (false, true, false)
| Invariant -> (false, false, false)
let transl_variance (v, i) =
let co, cn =
match v with
| Covariant -> (true, false)
| Contravariant -> (false, true)
| NoVariance -> (false, false)
in
(co, cn, match i with Injective -> true | NoInjectivity -> false)
let variance_of_params ptype_params =
List.map transl_variance (List.map snd ptype_params)

3
typing/typedecl_variance.mli
View File

@ -20,7 +20,8 @@ open Typedecl_properties
type surface_variance = bool * bool * bool
val variance_of_params :
(Parsetree.core_type * Asttypes.variance) list -> surface_variance list
(Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list ->
surface_variance list
val variance_of_sdecl :
Parsetree.type_declaration -> surface_variance list

6
typing/typedtree.ml
View File

@ -483,7 +483,7 @@ and value_description =
and type_declaration =
{ typ_id: Ident.t;
typ_name: string loc;
typ_params: (core_type * variance) list;
typ_params: (core_type * (variance * injectivity)) list;
typ_type: Types.type_declaration;
typ_cstrs: (core_type * core_type * Location.t) list;
typ_kind: type_kind;
@ -527,7 +527,7 @@ and type_extension =
{
tyext_path: Path.t;
tyext_txt: Longident.t loc;
tyext_params: (core_type * variance) list;
tyext_params: (core_type * (variance * injectivity)) list;
tyext_constructors: extension_constructor list;
tyext_private: private_flag;
tyext_loc: Location.t;
@ -600,7 +600,7 @@ and class_type_declaration =
and 'a class_infos =
{ ci_virt: virtual_flag;
ci_params: (core_type * variance) list;
ci_params: (core_type * (variance * injectivity)) list;
ci_id_name: string loc;
ci_id_class: Ident.t;
ci_id_class_type: Ident.t;

6
typing/typedtree.mli
View File

@ -622,7 +622,7 @@ and type_declaration =
{
typ_id: Ident.t;
typ_name: string loc;
typ_params: (core_type * variance) list;
typ_params: (core_type * (variance * injectivity)) list;
typ_type: Types.type_declaration;
typ_cstrs: (core_type * core_type * Location.t) list;
typ_kind: type_kind;
@ -666,7 +666,7 @@ and type_extension =
{
tyext_path: Path.t;
tyext_txt: Longident.t loc;
tyext_params: (core_type * variance) list;
tyext_params: (core_type * (variance * injectivity)) list;
tyext_constructors: extension_constructor list;
tyext_private: private_flag;
tyext_loc: Location.t;
@ -739,7 +739,7 @@ and class_type_declaration =
and 'a class_infos =
{ ci_virt: virtual_flag;
ci_params: (core_type * variance) list;
ci_params: (core_type * (variance * injectivity)) list;
ci_id_name : string loc;
ci_id_class: Ident.t;
ci_id_class_type : Ident.t;

6
typing/typemod.ml
View File

@ -477,14 +477,14 @@ let merge_constraint initial_env remove_aliases loc sg constr =
type_manifest = None;
type_variance =
List.map
(fun (_, v) ->
(fun (_, (v, i)) ->
let (c, n) =
match v with
| Covariant -> true, false
| Contravariant -> false, true
| Invariant -> false, false
| NoVariance -> false, false
in
make_variance (not n) (not c) false
make_variance (not n) (not c) (i = Injective)
)
sdecl.ptype_params;
type_separability =