summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--.depend24
-rw-r--r--otherlibs/labltk/browser/searchpos.ml3
-rw-r--r--parsing/lexer.mll5
-rw-r--r--parsing/parser.mly69
-rw-r--r--parsing/parsetree.mli4
-rw-r--r--parsing/printast.ml5
-rw-r--r--tools/ocamldep.ml2
-rw-r--r--typing/printtyp.ml46
-rw-r--r--typing/typeclass.ml8
-rw-r--r--typing/typedecl.ml63
-rw-r--r--typing/typedecl.mli5
11 files changed, 130 insertions, 104 deletions
diff --git a/.depend b/.depend
index 778a39c9b3..c87e43a159 100644
--- a/.depend
+++ b/.depend
@@ -173,15 +173,15 @@ typing/typeclass.cmo: parsing/asttypes.cmi typing/btype.cmi utils/clflags.cmo \
parsing/location.cmi parsing/longident.cmi utils/misc.cmi \
typing/parmatch.cmi parsing/parsetree.cmi typing/path.cmi \
typing/predef.cmi typing/printtyp.cmi typing/typecore.cmi \
- typing/typedtree.cmi typing/types.cmi typing/typetexp.cmi \
- utils/warnings.cmi typing/typeclass.cmi
+ typing/typedecl.cmi typing/typedtree.cmi typing/types.cmi \
+ typing/typetexp.cmi utils/warnings.cmi typing/typeclass.cmi
typing/typeclass.cmx: parsing/asttypes.cmi typing/btype.cmx utils/clflags.cmx \
typing/ctype.cmx typing/env.cmx typing/ident.cmx typing/includeclass.cmx \
parsing/location.cmx parsing/longident.cmx utils/misc.cmx \
typing/parmatch.cmx parsing/parsetree.cmi typing/path.cmx \
typing/predef.cmx typing/printtyp.cmx typing/typecore.cmx \
- typing/typedtree.cmx typing/types.cmx typing/typetexp.cmx \
- utils/warnings.cmx typing/typeclass.cmi
+ typing/typedecl.cmx typing/typedtree.cmx typing/types.cmx \
+ typing/typetexp.cmx utils/warnings.cmx typing/typeclass.cmi
typing/typecore.cmo: parsing/asttypes.cmi typing/btype.cmi utils/clflags.cmo \
typing/ctype.cmi typing/env.cmi typing/ident.cmi parsing/location.cmi \
parsing/longident.cmi utils/misc.cmi typing/parmatch.cmi \
@@ -194,17 +194,17 @@ typing/typecore.cmx: parsing/asttypes.cmi typing/btype.cmx utils/clflags.cmx \
parsing/parsetree.cmi typing/path.cmx typing/predef.cmx \
typing/printtyp.cmx typing/typedtree.cmx typing/types.cmx \
typing/typetexp.cmx utils/warnings.cmx typing/typecore.cmi
-typing/typedecl.cmo: typing/btype.cmi utils/clflags.cmo utils/config.cmi \
- typing/ctype.cmi typing/env.cmi typing/ident.cmi typing/includecore.cmi \
- parsing/location.cmi parsing/longident.cmi utils/misc.cmi \
- parsing/parsetree.cmi typing/path.cmi typing/predef.cmi \
+typing/typedecl.cmo: parsing/asttypes.cmi typing/btype.cmi utils/clflags.cmo \
+ utils/config.cmi typing/ctype.cmi typing/env.cmi typing/ident.cmi \
+ typing/includecore.cmi parsing/location.cmi parsing/longident.cmi \
+ utils/misc.cmi parsing/parsetree.cmi typing/path.cmi typing/predef.cmi \
typing/primitive.cmi typing/printtyp.cmi typing/subst.cmi \
typing/typedtree.cmi typing/types.cmi typing/typetexp.cmi \
typing/typedecl.cmi
-typing/typedecl.cmx: typing/btype.cmx utils/clflags.cmx utils/config.cmx \
- typing/ctype.cmx typing/env.cmx typing/ident.cmx typing/includecore.cmx \
- parsing/location.cmx parsing/longident.cmx utils/misc.cmx \
- parsing/parsetree.cmi typing/path.cmx typing/predef.cmx \
+typing/typedecl.cmx: parsing/asttypes.cmi typing/btype.cmx utils/clflags.cmx \
+ utils/config.cmx typing/ctype.cmx typing/env.cmx typing/ident.cmx \
+ typing/includecore.cmx parsing/location.cmx parsing/longident.cmx \
+ utils/misc.cmx parsing/parsetree.cmi typing/path.cmx typing/predef.cmx \
typing/primitive.cmx typing/printtyp.cmx typing/subst.cmx \
typing/typedtree.cmx typing/types.cmx typing/typetexp.cmx \
typing/typedecl.cmi
diff --git a/otherlibs/labltk/browser/searchpos.ml b/otherlibs/labltk/browser/searchpos.ml
index 5ddb852ac4..c224c5fbed 100644
--- a/otherlibs/labltk/browser/searchpos.ml
+++ b/otherlibs/labltk/browser/searchpos.ml
@@ -144,8 +144,7 @@ let search_pos_type_decl td ~pos ~env =
| None -> ()
end;
begin match td.ptype_kind with
- Ptype_abstract None -> ()
- | Ptype_abstract(Some t) -> search_pos_type t ~pos ~env
+ Ptype_abstract -> ()
| Ptype_variant dl ->
List.iter dl
~f:(fun (_, tl) -> List.iter tl ~f:(search_pos_type ~pos ~env))
diff --git a/parsing/lexer.mll b/parsing/lexer.mll
index dd34229231..b031d89bee 100644
--- a/parsing/lexer.mll
+++ b/parsing/lexer.mll
@@ -292,8 +292,9 @@ rule token = parse
| ">}" { GREATERRBRACE }
| "!=" { INFIXOP0 "!=" }
- | "-" { SUBTRACTIVE "-" }
- | "-." { SUBTRACTIVE "-." }
+ | "+" { PLUS }
+ | "-" { MINUS }
+ | "-." { MINUSDOT }
| "!" symbolchar *
{ PREFIXOP(Lexing.lexeme lexbuf) }
diff --git a/parsing/parser.mly b/parsing/parser.mly
index 60c84c2840..b1750473bc 100644
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -257,6 +257,8 @@ let bigarray_set arr arg newval =
%token LPAREN
%token MATCH
%token METHOD
+%token MINUS
+%token MINUSDOT
%token MINUSGREATER
%token MODULE
%token MUTABLE
@@ -267,6 +269,7 @@ let bigarray_set arr arg newval =
%token <string> OPTLABEL
%token OR
%token PARSER
+%token PLUS
%token <string> PREFIXOP
%token PRIVATE
%token QUESTION
@@ -283,7 +286,6 @@ let bigarray_set arr arg newval =
%token STAR
%token <string> STRING
%token STRUCT
-%token <string> SUBTRACTIVE
%token THEN
%token TILDE
%token TO
@@ -316,7 +318,7 @@ let bigarray_set arr arg newval =
%left INFIXOP0 EQUAL LESS GREATER /* = < > etc */
%right INFIXOP1 /* @ ^ etc */
%right COLONCOLON /* :: */
-%left INFIXOP2 SUBTRACTIVE /* + - */
+%left INFIXOP2 PLUS MINUS MINUSDOT /* + - */
%left INFIXOP3 STAR /* * / */
%right INFIXOP4 /* ** */
%right prec_unary_minus /* - unary */
@@ -504,7 +506,9 @@ class_declarations:
;
class_declaration:
virtual_flag class_type_parameters LIDENT class_fun_binding
- { {pci_virt = $1; pci_params = $2; pci_name = $3; pci_expr = $4;
+ { let params, variance = List.split (fst $2) in
+ {pci_virt = $1; pci_params = params, snd $2;
+ pci_name = $3; pci_expr = $4; pci_variance = variance;
pci_loc = symbol_rloc ()} }
;
class_fun_binding:
@@ -689,7 +693,9 @@ class_descriptions:
;
class_description:
virtual_flag class_type_parameters LIDENT COLON class_type
- { {pci_virt = $1; pci_params = $2; pci_name = $3; pci_expr = $5;
+ { let params, variance = List.split (fst $2) in
+ {pci_virt = $1; pci_params = params, snd $2;
+ pci_name = $3; pci_expr = $5; pci_variance = variance;
pci_loc = symbol_rloc ()} }
;
class_type_declarations:
@@ -698,7 +704,9 @@ class_type_declarations:
;
class_type_declaration:
virtual_flag class_type_parameters LIDENT EQUAL class_signature
- { {pci_virt = $1; pci_params = $2; pci_name = $3; pci_expr = $5;
+ { let params, variance = List.split (fst $2) in
+ {pci_virt = $1; pci_params = params, snd $2;
+ pci_name = $3; pci_expr = $5; pci_variance = variance;
pci_loc = symbol_rloc ()} }
;
@@ -800,8 +808,12 @@ expr:
{ mkinfix $1 $2 $3 }
| expr INFIXOP4 expr
{ mkinfix $1 $2 $3 }
- | expr SUBTRACTIVE expr
- { mkinfix $1 $2 $3 }
+ | expr PLUS expr
+ { mkinfix $1 "+" $3 }
+ | expr MINUS expr
+ { mkinfix $1 "-" $3 }
+ | expr MINUSDOT expr
+ { mkinfix $1 "-." $3 }
| expr STAR expr
{ mkinfix $1 "*" $3 }
| expr EQUAL expr
@@ -820,7 +832,7 @@ expr:
{ mkinfix $1 "&&" $3 }
| expr COLONEQUAL expr
{ mkinfix $1 ":=" $3 }
- | SUBTRACTIVE expr %prec prec_unary_minus
+ | subtractive expr %prec prec_unary_minus
{ mkuminus $1 $2 }
| simple_expr DOT label_longident LESSMINUS expr
{ mkexp(Pexp_setfield($1, $3, $5)) }
@@ -1144,11 +1156,13 @@ type_declarations:
;
type_declaration:
type_parameters LIDENT type_kind constraints
- { let (kind, manifest) = $3 in
- ($2, {ptype_params = $1;
+ { let (params, variance) = List.split $1 in
+ let (kind, manifest) = $3 in
+ ($2, {ptype_params = params;
ptype_cstrs = List.rev $4;
ptype_kind = kind;
ptype_manifest = manifest;
+ ptype_variance = variance;
ptype_loc = symbol_rloc()}) }
;
constraints:
@@ -1157,11 +1171,9 @@ constraints:
;
type_kind:
/*empty*/
- { (Ptype_abstract None, None) }
- | AS core_type
- { (Ptype_abstract (Some $2), None) }
+ { (Ptype_abstract, None) }
| EQUAL core_type %prec prec_type_def
- { (Ptype_abstract None, Some $2) }
+ { (Ptype_abstract, Some $2) }
| EQUAL constructor_declarations
{ (Ptype_variant(List.rev $2), None) }
| EQUAL BAR constructor_declarations
@@ -1180,7 +1192,12 @@ type_parameters:
| LPAREN type_parameter_list RPAREN { List.rev $2 }
;
type_parameter:
- QUOTE ident { $2 }
+ type_variance QUOTE ident { $3, $1 }
+;
+type_variance:
+ /* empty */ { false, false }
+ | PLUS { true, false }
+ | MINUS { false, true }
;
type_parameter_list:
type_parameter { [$1] }
@@ -1213,10 +1230,12 @@ with_constraints:
;
with_constraint:
TYPE type_parameters label_longident EQUAL core_type constraints
- { ($3, Pwith_type {ptype_params = $2;
+ { let params, variance = List.split $2 in
+ ($3, Pwith_type {ptype_params = params;
ptype_cstrs = List.rev $6;
- ptype_kind = Ptype_abstract None;
+ ptype_kind = Ptype_abstract;
ptype_manifest = Some $5;
+ ptype_variance = variance;
ptype_loc = symbol_rloc()}) }
/* used label_longident instead of type_longident to disallow
functor applications in type path */
@@ -1229,8 +1248,8 @@ with_constraint:
core_type:
core_type2
{ $1 }
- | core_type2 AS type_parameter
- { mktyp(Ptyp_alias($1, $3)) }
+ | core_type2 AS QUOTE ident
+ { mktyp(Ptyp_alias($1, $4)) }
;
core_type2:
simple_core_type_or_tuple
@@ -1351,8 +1370,8 @@ constant:
;
signed_constant:
constant { $1 }
- | SUBTRACTIVE INT { Const_int(- $2) }
- | SUBTRACTIVE FLOAT { Const_float("-" ^ $2) }
+ | MINUS INT { Const_int(- $2) }
+ | subtractive FLOAT { Const_float("-" ^ $2) }
;
/* Identifiers and long identifiers */
@@ -1376,7 +1395,9 @@ operator:
| INFIXOP2 { $1 }
| INFIXOP3 { $1 }
| INFIXOP4 { $1 }
- | SUBTRACTIVE { $1 }
+ | PLUS { "+" }
+ | MINUS { "-" }
+ | MINUSDOT { "-." }
| STAR { "*" }
| EQUAL { "=" }
| LESS { "<" }
@@ -1481,4 +1502,8 @@ opt_semi:
| /* empty */ { () }
| SEMI { () }
;
+subtractive:
+ | MINUS { "-" }
+ | MINUSDOT { "-." }
+;
%%
diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
index a5cc290d06..cfaf0e3f4f 100644
--- a/parsing/parsetree.mli
+++ b/parsing/parsetree.mli
@@ -48,6 +48,7 @@ type 'a class_infos =
pci_params: string list * Location.t;
pci_name: string;
pci_expr: 'a;
+ pci_variance: (bool * bool) list;
pci_loc: Location.t }
(* Value expressions for the core language *)
@@ -114,10 +115,11 @@ and type_declaration =
ptype_cstrs: (core_type * core_type * Location.t) list;
ptype_kind: type_kind;
ptype_manifest: core_type option;
+ ptype_variance: (bool * bool) list;
ptype_loc: Location.t }
and type_kind =
- Ptype_abstract of core_type option
+ Ptype_abstract
| Ptype_variant of (string * core_type list) list
| Ptype_record of (string * mutable_flag * core_type) list
diff --git a/parsing/printast.ml b/parsing/printast.ml
index 6c1c6caee8..97d2063805 100644
--- a/parsing/printast.ml
+++ b/parsing/printast.ml
@@ -286,9 +286,8 @@ and type_declaration i ppf x =
and type_kind i ppf x =
match x with
- | Ptype_abstract (x) ->
- line i ppf "Ptype_abstract\n";
- option (i+1) core_type ppf x;
+ | Ptype_abstract ->
+ line i ppf "Ptype_abstract\n"
| Ptype_variant (l) ->
line i ppf "Ptype_variant\n";
list (i+1) string_x_core_type_list ppf l;
diff --git a/tools/ocamldep.ml b/tools/ocamldep.ml
index 36c1366f1a..89fe9c1326 100644
--- a/tools/ocamldep.ml
+++ b/tools/ocamldep.ml
@@ -64,7 +64,7 @@ let add_type_declaration bv td =
td.ptype_cstrs;
add_opt add_type bv td.ptype_manifest;
match td.ptype_kind with
- Ptype_abstract _ -> ()
+ Ptype_abstract -> ()
| Ptype_variant cstrs ->
List.iter (fun (c, args) -> List.iter (add_type bv) args) cstrs
| Ptype_record lbls ->
diff --git a/typing/printtyp.ml b/typing/printtyp.ml
index 5adffc9076..2f6f6015ac 100644
--- a/typing/printtyp.ml
+++ b/typing/printtyp.ml
@@ -163,12 +163,12 @@ let print_label ppf l =
let rec print_list_init pr sep ppf = function
| [] -> ()
- | a :: l -> sep (); pr ppf a; print_list_init pr sep ppf l;;
+ | a :: l -> sep ppf; pr ppf a; print_list_init pr sep ppf l;;
let rec print_list pr sep ppf = function
| [] -> ()
| [a] -> pr ppf a
- | a :: l -> pr ppf a; sep (); print_list pr sep ppf l;;
+ | a :: l -> pr ppf a; sep ppf; print_list pr sep ppf l;;
let rec typexp sch prio0 ppf ty =
let ty = repr ty in
@@ -217,7 +217,7 @@ let rec typexp sch prio0 ppf ty =
let all_present = List.length present = List.length fields in
let pr_present =
print_list (fun ppf (s, _) -> fprintf ppf "`%s" s)
- (fun () -> fprintf ppf "@ ")
+ (fun ppf -> fprintf ppf "@ ")
in
begin match row.row_name with
| Some(p, tyl) when namable_row row ->
@@ -245,7 +245,7 @@ let rec typexp sch prio0 ppf ty =
if not all_present then
fprintf ppf "@;<1 -2>> @[<hov>%a@]" pr_present l in
let print_fields =
- print_list (row_field sch) (fun () -> fprintf ppf "@;<1 -2>| ")
+ print_list (row_field sch) (fun ppf -> fprintf ppf "@;<1 -2>| ")
in
fprintf ppf "%s[%s@[<hv>@[<hv>%a@]%a]@]"
@@ -381,29 +381,29 @@ let rec type_decl kwd id ppf decl =
let print_constraints ppf params =
List.iter (constrain ppf) params in
+ let type_parameter ppf (ty,(co,cn)) =
+ fprintf ppf "%s%a"
+ (if not cn then "+" else if not co then "-" else "")
+ type_expr ty
+ in
+ let type_defined ppf decl =
+ if decl.type_kind = Type_abstract && decl.type_manifest = None
+ && List.exists (fun x -> x <> (true, true)) decl.type_variance then
+ fprintf ppf "(@[%a)@]@ %a"
+ (print_list type_parameter (fun ppf -> fprintf ppf ",@ "))
+ (List.combine params decl.type_variance)
+ ident id
+ else
+ type_expr ppf (Btype.newgenty (Tconstr(Pident id, params, ref Mnil)))
+ in
let print_manifest ppf decl =
match decl.type_manifest with
- | None ->
- if decl.type_kind = Type_abstract
- && List.exists (fun p -> p <> (true,true)) decl.type_variance then
- let select f l1 l2 =
- List.fold_right2 (fun x y l -> if f x then y :: l else l) l1 l2 []
- in
- let repres f =
- let l = select f decl.type_variance params in
- if l = [] then Predef.type_unit else Btype.newgenty (Ttuple l)
- in
- let covar = repres fst and convar = repres snd in
- let ty =
- if convar == Predef.type_unit then covar
- else Btype.newgenty (Tarrow ("", convar, covar))
- in
- fprintf ppf " as@ %a" type_expr ty
+ | None -> ()
| Some ty -> fprintf ppf " =@ %a" type_expr ty in
let print_name_args ppf decl =
fprintf ppf "%s%a%a"
- kwd type_expr (Btype.newgenty (Tconstr(Pident id, params, ref Mnil)))
+ kwd type_defined decl
print_manifest decl in
begin match decl.type_kind with
@@ -415,12 +415,12 @@ let rec type_decl kwd id ppf decl =
| Type_variant cstrs ->
fprintf ppf "@[<2>@[<hv 2>%a =@;<1 2>%a@]%a@]"
print_name_args decl
- (print_list constructor (fun () -> fprintf ppf "@ | ")) cstrs
+ (print_list constructor (fun ppf -> fprintf ppf "@ | ")) cstrs
print_constraints params
| Type_record(lbls, rep) ->
fprintf ppf "@[<2>@[<hv 2>%a = {%a@;<1 -2>}@]@ %a@]"
print_name_args decl
- (print_list_init label (fun () -> fprintf ppf "@ ")) lbls
+ (print_list_init label (fun ppf -> fprintf ppf "@ ")) lbls
print_constraints params
end
diff --git a/typing/typeclass.ml b/typing/typeclass.ml
index 33daadf104..4f33485192 100644
--- a/typing/typeclass.ml
+++ b/typing/typeclass.ml
@@ -1023,12 +1023,12 @@ let final_decl define_class
end;
(id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
- arity, pub_meths, expr)
+ arity, pub_meths, expr, (cl.pci_variance, cl.pci_loc))
let extract_type_decls
(id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
- arity, pub_meths, expr) decls =
- (obj_id, obj_abbr) :: (cl_id, cl_abbr) :: decls
+ arity, pub_meths, expr, required) decls =
+ ((obj_id, obj_abbr), required) :: ((cl_id, cl_abbr), required) :: decls
let rec compact = function
[] -> []
@@ -1037,7 +1037,7 @@ let rec compact = function
let merge_type_decls
(id, clty, ty_id, cltydef, _obj_id, _obj_abbr, _cl_id, _cl_abbr,
- arity, pub_meths, expr) ((obj_id, obj_abbr), (cl_id, cl_abbr)) =
+ arity, pub_meths, expr, req) ((obj_id, obj_abbr), (cl_id, cl_abbr)) =
(id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
arity, pub_meths, expr)
diff --git a/typing/typedecl.ml b/typing/typedecl.ml
index 8dd6e628e5..f34c768661 100644
--- a/typing/typedecl.ml
+++ b/typing/typedecl.ml
@@ -38,7 +38,7 @@ type error =
| Unbound_type_var
| Unbound_exception of Longident.t
| Not_an_exception of Longident.t
- | Constructor_in_variance
+ | Bad_variance
exception Error of Location.t * error
@@ -96,7 +96,7 @@ let transl_declaration env (name, sdecl) id =
type_arity = List.length params;
type_kind =
begin match sdecl.ptype_kind with
- Ptype_abstract _ ->
+ Ptype_abstract ->
Type_abstract
| Ptype_variant cstrs ->
let all_constrs = ref StringSet.empty in
@@ -143,15 +143,6 @@ let transl_declaration env (name, sdecl) id =
end;
type_variance = List.map (fun _ -> true, true) params;
} in
- let variance =
- match sdecl.ptype_kind with
- Ptype_abstract(Some sty) ->
- begin try Some (transl_simple_type Env.initial true sty)
- with Typetexp.Error (loc, Unbound_type_constructor lid) ->
- raise (Error(loc, Constructor_in_variance))
- end
- | _ -> None
- in
(* Check constraints *)
List.iter
@@ -163,7 +154,7 @@ let transl_declaration env (name, sdecl) id =
raise(Error(loc, Unconsistent_constraint)))
sdecl.ptype_cstrs;
- ((id, decl), variance)
+ (id, decl)
(* Generalize a type declaration *)
@@ -382,16 +373,17 @@ let compute_variance env tvl nega posi ty =
if TypeSet.mem ty !nvisited then convar := true)
tvl
-let compute_variance_decl env decl abstract =
+let compute_variance_decl env decl (required, loc) =
+ if decl.type_kind = Type_abstract && decl.type_manifest = None then
+ List.map (fun (c, n) -> if c || n then (c, n) else (true, true)) required
+ else
let tvl = List.map (fun ty -> (Btype.repr ty, ref false, ref false))
decl.type_params in
begin match decl.type_kind with
Type_abstract ->
- begin match decl.type_manifest, abstract with
- None, None -> List.iter (fun (_, co, cn) -> co := true; cn := true) tvl
- | Some ty, None -> compute_variance env tvl true false ty
- | None, Some ty -> compute_variance env tvl true false ty
- | _ -> assert false
+ begin match decl.type_manifest with
+ None -> assert false
+ | Some ty -> compute_variance env tvl true false ty
end
| Type_variant tll ->
List.iter
@@ -402,9 +394,13 @@ let compute_variance_decl env decl abstract =
(fun (_, mut, ty) -> compute_variance env tvl true (mut = Mutable) ty)
ftl
end;
- List.map (fun (_, co, cn) -> (!co, !cn)) tvl
+ List.map2
+ (fun (_, co, cn) (c, n) ->
+ if c && !cn || n && !co then raise (Error(loc, Bad_variance));
+ (!co, !cn))
+ tvl required
-let rec compute_variance_fixpoint env decls abstract variances =
+let rec compute_variance_fixpoint env decls required variances =
let new_decls =
List.map2
(fun (id, decl) variance -> id, {decl with type_variance = variance})
@@ -416,7 +412,7 @@ let rec compute_variance_fixpoint env decls abstract variances =
in
let new_variances =
List.map2 (fun (_, decl) -> compute_variance_decl new_env decl)
- new_decls abstract
+ new_decls required
in
let new_variances =
List.map2 (List.map2 (fun (c1,n1) (c2,n2) -> (c1||c2), (n1||n2)))
@@ -424,16 +420,14 @@ let rec compute_variance_fixpoint env decls abstract variances =
if new_variances = variances then
new_decls, new_env
else
- compute_variance_fixpoint env decls abstract new_variances
+ compute_variance_fixpoint env decls required new_variances
(* for typeclass.ml *)
let compute_variance_decls env decls =
+ let decls, required = List.split decls in
let variances =
- List.map
- (fun (_, decl) -> List.map (fun _ -> (false, false)) decl.type_params)
- decls
- and abstract = List.map (fun _ -> None) decls in
- fst (compute_variance_fixpoint env decls abstract variances)
+ List.map (fun (l,_) -> List.map (fun _ -> false, false) l) required in
+ fst (compute_variance_fixpoint env decls required variances)
(* Translate a set of mutually recursive type declarations *)
let transl_type_decl env name_sdecl_list =
@@ -454,7 +448,6 @@ let transl_type_decl env name_sdecl_list =
(* Translate each declaration. *)
let decls =
List.map2 (transl_declaration temp_env) name_sdecl_list id_list in
- let decls, abstract = List.split decls in
(* Build the final env. *)
let newenv =
List.fold_right
@@ -491,8 +484,12 @@ let transl_type_decl env name_sdecl_list =
in
List.iter (check_expansion newenv (List.flatten id_loc_list)) decls;
(* Add variances to the environment *)
+ let required =
+ List.map (fun (_, sdecl) -> sdecl.ptype_variance, sdecl.ptype_loc)
+ name_sdecl_list
+ in
let final_decls, final_env =
- compute_variance_fixpoint env decls abstract
+ compute_variance_fixpoint env decls required
(List.map
(fun (_,decl) -> List.map (fun _ -> (false, false)) decl.type_params)
decls) in
@@ -567,7 +564,8 @@ let transl_with_constraint env sdecl =
}
in
let decl =
- {decl with type_variance = compute_variance_decl env decl None} in
+ {decl with type_variance =
+ compute_variance_decl env decl (sdecl.ptype_variance, sdecl.ptype_loc)} in
Ctype.end_def();
generalize_decl decl;
decl
@@ -627,5 +625,6 @@ let report_error ppf = function
| Not_an_exception lid ->
fprintf ppf "The constructor@ %a@ is not an exception"
Printtyp.longident lid
- | Constructor_in_variance ->
- fprintf ppf "Type constructors are not allowed in variance declarations"
+ | Bad_variance ->
+ fprintf ppf
+ "In this definition, expected parameter variances are not satisfied"
diff --git a/typing/typedecl.mli b/typing/typedecl.mli
index 198398561e..fa25c34c9c 100644
--- a/typing/typedecl.mli
+++ b/typing/typedecl.mli
@@ -35,7 +35,8 @@ val transl_with_constraint:
(* for typeclass.ml *)
val compute_variance_decls:
Env.t ->
- (Ident.t * type_declaration) list -> (Ident.t * type_declaration) list
+ ((Ident.t * type_declaration) * ((bool * bool) list * Location.t)) list ->
+ (Ident.t * type_declaration) list
type error =
Repeated_parameter
@@ -53,7 +54,7 @@ type error =
| Unbound_type_var
| Unbound_exception of Longident.t
| Not_an_exception of Longident.t
- | Constructor_in_variance
+ | Bad_variance
exception Error of Location.t * error
View Lorry Controller Status