Add injectivity annotations (#9500)
parent
5a9c5dd5b0
commit
603506aa34
10
Changes
10
Changes
|
@ -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,
|
||||
|
|
File diff suppressed because one or more lines are too long
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -60,4 +60,8 @@ type 'a loc = 'a Location.loc = {
|
|||
type variance =
|
||||
| Covariant
|
||||
| Contravariant
|
||||
| Invariant
|
||||
| NoVariance
|
||||
|
||||
type injectivity =
|
||||
| Injective
|
||||
| NoInjectivity
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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;
|
||||
|
|
|
@ -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
|
||||
| [] -> ()
|
||||
|
|
|
@ -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.
|
||||
|
|
|
@ -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.
|
||||
|}]
|
|
@ -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.
|
||||
|
|
|
@ -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.
|
||||
|
|
|
@ -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 =
|
||||
|
|
|
@ -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;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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;
|
||||
|
|
|
@ -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;
|
||||
|
|
|
@ -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 =
|
||||
|
|
Loading…
Reference in New Issue