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

exhauce PR#6367: introduce Asttypes.arg_label to encode labelled arguments 

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@15737 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
master
Jacques Garrigue 2014-12-22 08:45:55 +00:00
parent c0de696981
commit 158480371a
35 changed files with 245 additions and 219 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
Changes
View File

@ -59,6 +59,9 @@ Bug fixes:
- PR#6650: Cty_constr not handled correctly by Subst
- PR#6651: Failing component lookup
Features wishes:
- PR#6367: introduce Asttypes.arg_label to encode labelled arguments
OCaml 4.02.2:
-------------

BIN
boot/ocamlc
View File

Binary file not shown.

BIN
boot/ocamldep
View File

Binary file not shown.

BIN
boot/ocamllex
View File

Binary file not shown.

2
bytecomp/translcore.mli
View File

@ -18,7 +18,7 @@ open Typedtree
open Lambda
val transl_exp: expression -> lambda
val transl_apply: lambda -> (label * expression option * optional) list
val transl_apply: lambda -> (arg_label * expression option * optional) list
-> Location.t -> lambda
val transl_let: rec_flag -> value_binding list -> lambda -> lambda
val transl_primitive: Location.t -> Primitive.description -> Env.t

4
ocamldoc/odoc_info.mli
View File

@ -780,11 +780,11 @@ val create_index_lists : 'a list -> ('a -> string) -> 'a list list
val remove_option : Types.type_expr -> Types.type_expr
(** Return [true] if the given label is optional.*)
val is_optional : string -> bool
val is_optional : Asttypes.arg_label -> bool
(** Return the label name for the given label,
i.e. removes the beginning '?' if present.*)
val label_name : string -> string
val label_name : Asttypes.arg_label -> string
(** Return the given name where the module name or
part of it was removed, according to the list of modules

4
ocamldoc/odoc_misc.mli
View File

@ -107,8 +107,8 @@ val search_string_backward : pat: string -> s: string -> int
val remove_option : Types.type_expr -> Types.type_expr
(** Return [true] if the given label is optional.*)
val is_optional : string -> bool
val is_optional : Asttypes.arg_label -> bool
(** Return the label name for the given label,
i.e. removes the beginning '?' if present.*)
val label_name : string -> string
val label_name : Asttypes.arg_label -> string

4
ocamldoc/odoc_str.ml
View File

@ -148,8 +148,8 @@ let string_of_class_params c =
Printf.bprintf b "%s%s%s%s -> "
(
match label with
"" -> ""
| s -> s^":"
Asttypes.Nolabel -> ""
| s -> Printtyp.string_of_label s ^":"
)
(if parent then "(" else "")
(Odoc_print.string_of_type_expr

14
ocamldoc/odoc_value.ml
View File

@ -95,22 +95,16 @@ let parameter_list_from_arrows typ =
so there is nothing to merge. With this dummy list we can merge the
parameter names from the .ml and the type from the .mli file. *)
let dummy_parameter_list typ =
let normal_name s =
match s with
"" -> s
| _ ->
match s.[0] with
'?' -> String.sub s 1 ((String.length s) - 1)
| _ -> s
in
let normal_name = Odoc_misc.label_name in
Printtyp.mark_loops typ;
let liste_param = parameter_list_from_arrows typ in
let rec iter (label, t) =
match t.Types.desc with
| Types.Ttuple l ->
if label = "" then
let open Asttypes in
if label = Nolabel then
Odoc_parameter.Tuple
(List.map (fun t2 -> iter ("", t2)) l, t)
(List.map (fun t2 -> iter (Nolabel, t2)) l, t)
else
(* if there is a label, then we don't want to decompose the tuple *)
Odoc_parameter.Simple_name

17
parsing/ast_helper.mli
View File

@ -38,7 +38,7 @@ module Typ :
val any: ?loc:loc -> ?attrs:attrs -> unit -> core_type
val var: ?loc:loc -> ?attrs:attrs -> string -> core_type
val arrow: ?loc:loc -> ?attrs:attrs -> label -> core_type -> core_type
val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> core_type
-> core_type
val tuple: ?loc:loc -> ?attrs:attrs -> core_type list -> core_type
val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type
@ -93,11 +93,11 @@ module Exp:
val constant: ?loc:loc -> ?attrs:attrs -> constant -> expression
val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list
-> expression -> expression
val fun_: ?loc:loc -> ?attrs:attrs -> label -> expression option -> pattern
val fun_: ?loc:loc -> ?attrs:attrs -> arg_label -> expression option -> pattern
-> expression -> expression
val function_: ?loc:loc -> ?attrs:attrs -> case list -> expression
val apply: ?loc:loc -> ?attrs:attrs -> expression
-> (label * expression) list -> expression
-> (arg_label * expression) list -> expression
val match_: ?loc:loc -> ?attrs:attrs -> expression -> case list
-> expression
val try_: ?loc:loc -> ?attrs:attrs -> expression -> case list -> expression
@ -293,7 +293,7 @@ module Cty:
val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_type
val signature: ?loc:loc -> ?attrs:attrs -> class_signature -> class_type
val arrow: ?loc:loc -> ?attrs:attrs -> label -> core_type -> class_type -> class_type
val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> class_type -> class_type
val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type
end
@ -319,9 +319,12 @@ module Cl:
val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_expr
val structure: ?loc:loc -> ?attrs:attrs -> class_structure -> class_expr
val fun_: ?loc:loc -> ?attrs:attrs -> label -> expression option -> pattern -> class_expr -> class_expr
val apply: ?loc:loc -> ?attrs:attrs -> class_expr -> (label * expression) list -> class_expr
val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list -> class_expr -> class_expr
val fun_: ?loc:loc -> ?attrs:attrs -> arg_label -> expression option -> pattern ->
class_expr -> class_expr
val apply:
?loc:loc -> ?attrs:attrs -> class_expr -> (arg_label * expression) list -> class_expr
val let_:
?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list -> class_expr -> class_expr
val constraint_: ?loc:loc -> ?attrs:attrs -> class_expr -> class_type -> class_expr
val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_expr
end

5
parsing/asttypes.mli
View File

@ -37,6 +37,11 @@ type closed_flag = Closed | Open
type label = string
type arg_label =
Nolabel
| Labelled of string (* label:T -> ... *)
| Optional of string (* ?label:T -> ... *)
type 'a loc = 'a Location.loc = {
txt : 'a;
loc : Location.t;

80
parsing/parser.mly
View File

@ -73,7 +73,7 @@ let ghunit () =
ghexp (Pexp_construct (mknoloc (Lident "()"), None))
let mkinfix arg1 name arg2 =
mkexp(Pexp_apply(mkoperator name 2, ["", arg1; "", arg2]))
mkexp(Pexp_apply(mkoperator name 2, [Nolabel, arg1; Nolabel, arg2]))
let neg_float_string f =
if String.length f > 0 && f.[0] = '-'
@ -93,7 +93,7 @@ let mkuminus name arg =
| ("-" | "-."), Pexp_constant(Const_float f) ->
mkexp(Pexp_constant(Const_float(neg_float_string f)))
| _ ->
mkexp(Pexp_apply(mkoperator ("~" ^ name) 1, ["", arg]))
mkexp(Pexp_apply(mkoperator ("~" ^ name) 1, [Nolabel, arg]))
let mkuplus name arg =
let desc = arg.pexp_desc in
@ -104,7 +104,7 @@ let mkuplus name arg =
| "+", Pexp_constant(Const_nativeint _)
| ("+" | "+."), Pexp_constant(Const_float _) -> mkexp desc
| _ ->
mkexp(Pexp_apply(mkoperator ("~" ^ name) 1, ["", arg]))
mkexp(Pexp_apply(mkoperator ("~" ^ name) 1, [Nolabel, arg]))
let mkexp_cons consloc args loc =
Exp.mk ~loc (Pexp_construct(mkloc (Lident "::") consloc, Some args))
@ -186,34 +186,34 @@ let bigarray_get arr arg =
match bigarray_untuplify arg with
[c1] ->
mkexp(Pexp_apply(ghexp(Pexp_ident(get 1)),
["", arr; "", c1]))
[Nolabel, arr; Nolabel, c1]))
| [c1;c2] ->
mkexp(Pexp_apply(ghexp(Pexp_ident(get 2)),
["", arr; "", c1; "", c2]))
[Nolabel, arr; Nolabel, c1; Nolabel, c2]))
| [c1;c2;c3] ->
mkexp(Pexp_apply(ghexp(Pexp_ident(get 3)),
["", arr; "", c1; "", c2; "", c3]))
[Nolabel, arr; Nolabel, c1; Nolabel, c2; Nolabel, c3]))
| coords ->
mkexp(Pexp_apply(ghexp(Pexp_ident(get 0)),
["", arr; "", ghexp(Pexp_array coords)]))
[Nolabel, arr; Nolabel, ghexp(Pexp_array coords)]))
let bigarray_set arr arg newval =
let set order = bigarray_function order true in
match bigarray_untuplify arg with
[c1] ->
mkexp(Pexp_apply(ghexp(Pexp_ident(set 1)),
["", arr; "", c1; "", newval]))
[Nolabel, arr; Nolabel, c1; Nolabel, newval]))
| [c1;c2] ->
mkexp(Pexp_apply(ghexp(Pexp_ident(set 2)),
["", arr; "", c1; "", c2; "", newval]))
[Nolabel, arr; Nolabel, c1; Nolabel, c2; Nolabel, newval]))
| [c1;c2;c3] ->
mkexp(Pexp_apply(ghexp(Pexp_ident(set 3)),
["", arr; "", c1; "", c2; "", c3; "", newval]))
[Nolabel, arr; Nolabel, c1; Nolabel, c2; Nolabel, c3; Nolabel, newval]))
| coords ->
mkexp(Pexp_apply(ghexp(Pexp_ident(set 0)),
["", arr;
"", ghexp(Pexp_array coords);
"", newval]))
[Nolabel, arr;
Nolabel, ghexp(Pexp_array coords);
Nolabel, newval]))
let lapply p1 p2 =
if !Clflags.applicative_functors
@ -948,13 +948,13 @@ class_type:
{ $1 }
| QUESTION LIDENT COLON simple_core_type_or_tuple_no_attr MINUSGREATER
class_type
{ mkcty(Pcty_arrow("?" ^ $2 , mkoption $4, $6)) }
{ mkcty(Pcty_arrow(Optional $2 , mkoption $4, $6)) }
| OPTLABEL simple_core_type_or_tuple_no_attr MINUSGREATER class_type
{ mkcty(Pcty_arrow("?" ^ $1, mkoption $2, $4)) }
{ mkcty(Pcty_arrow(Optional $1, mkoption $2, $4)) }
| LIDENT COLON simple_core_type_or_tuple_no_attr MINUSGREATER class_type
{ mkcty(Pcty_arrow($1, $3, $5)) }
{ mkcty(Pcty_arrow(Labelled $1, $3, $5)) }
| simple_core_type_or_tuple_no_attr MINUSGREATER class_type
{ mkcty(Pcty_arrow("", $1, $3)) }
{ mkcty(Pcty_arrow(Nolabel, $1, $3)) }
;
class_signature:
LBRACKET core_type_comma_list RBRACKET clty_longident
@ -1051,21 +1051,21 @@ seq_expr:
;
labeled_simple_pattern:
QUESTION LPAREN label_let_pattern opt_default RPAREN
{ ("?" ^ fst $3, $4, snd $3) }
{ (Optional (fst $3), $4, snd $3) }
| QUESTION label_var
{ ("?" ^ fst $2, None, snd $2) }
{ (Optional (fst $2), None, snd $2) }
| OPTLABEL LPAREN let_pattern opt_default RPAREN
{ ("?" ^ $1, $4, $3) }
{ (Optional $1, $4, $3) }
| OPTLABEL pattern_var
{ ("?" ^ $1, None, $2) }
{ (Optional $1, None, $2) }
| TILDE LPAREN label_let_pattern RPAREN
{ (fst $3, None, snd $3) }
{ (Labelled (fst $3), None, snd $3) }
| TILDE label_var
{ (fst $2, None, snd $2) }
{ (Labelled (fst $2), None, snd $2) }
| LABEL simple_pattern
{ ($1, None, $2) }
{ (Labelled $1, None, $2) }
| simple_pattern
{ ("", None, $1) }
{ (Nolabel, None, $1) }
;
pattern_var:
LIDENT { mkpat(Ppat_var (mkrhs $1 1)) }
@ -1181,10 +1181,10 @@ expr:
{ mkexp(Pexp_setfield($1, mkrhs $3 3, $5)) }
| simple_expr DOT LPAREN seq_expr RPAREN LESSMINUS expr
{ mkexp(Pexp_apply(ghexp(Pexp_ident(array_function ".()" true)),
["",$1; "",$4; "",$7])) }
[Nolabel,$1; Nolabel,$4; Nolabel,$7])) }
| simple_expr DOT LBRACKET seq_expr RBRACKET LESSMINUS expr
{ mkexp(Pexp_apply(ghexp(Pexp_ident(array_function ".[]" true)),
["",$1; "",$4; "",$7])) }
[Nolabel,$1; Nolabel,$4; Nolabel,$7])) }
| simple_expr DOT LBRACE expr RBRACE LESSMINUS expr
{ bigarray_set $1 $4 $7 }
| label LESSMINUS expr
@ -1230,12 +1230,12 @@ simple_expr:
{ unclosed "(" 3 ")" 5 }
| simple_expr DOT LPAREN seq_expr RPAREN
{ mkexp(Pexp_apply(ghexp(Pexp_ident(array_function ".()" false)),
["",$1; "",$4])) }
[Nolabel,$1; Nolabel,$4])) }
| simple_expr DOT LPAREN seq_expr error
{ unclosed "(" 3 ")" 5 }
| simple_expr DOT LBRACKET seq_expr RBRACKET
{ mkexp(Pexp_apply(ghexp(Pexp_ident(array_function ".[]" false)),
["",$1; "",$4])) }
[Nolabel,$1; Nolabel,$4])) }
| simple_expr DOT LBRACKET seq_expr error
{ unclosed "[" 3 "]" 5 }
| simple_expr DOT LBRACE expr RBRACE
@ -1272,9 +1272,9 @@ simple_expr:
| mod_longident DOT LBRACKET expr_semi_list opt_semi error
{ unclosed "[" 3 "]" 6 }
| PREFIXOP simple_expr
{ mkexp(Pexp_apply(mkoperator $1 1, ["",$2])) }
{ mkexp(Pexp_apply(mkoperator $1 1, [Nolabel,$2])) }
| BANG simple_expr
{ mkexp(Pexp_apply(mkoperator "!" 1, ["",$2])) }
{ mkexp(Pexp_apply(mkoperator "!" 1, [Nolabel,$2])) }
| NEW ext_attributes class_longident
{ mkexp_attrs (Pexp_new(mkrhs $3 3)) $2 }
| LBRACELESS field_expr_list GREATERRBRACE
@ -1313,19 +1313,19 @@ simple_labeled_expr_list:
;
labeled_simple_expr:
simple_expr %prec below_SHARP
{ ("", $1) }
{ (Nolabel, $1) }
| label_expr
{ $1 }
;
label_expr:
LABEL simple_expr %prec below_SHARP
{ ($1, $2) }
{ (Labelled $1, $2) }
| TILDE label_ident
{ $2 }
{ (Labelled (fst $2), snd $2) }
| QUESTION label_ident
{ ("?" ^ fst $2, snd $2) }
{ (Optional (fst $2), snd $2) }
| OPTLABEL simple_expr %prec below_SHARP
{ ("?" ^ $1, $2) }
{ (Optional $1, $2) }
;
label_ident:
LIDENT { ($1, mkexp(Pexp_ident(mkrhs (Lident $1) 1))) }
@ -1794,13 +1794,13 @@ core_type2:
simple_core_type_or_tuple
{ $1 }
| QUESTION LIDENT COLON core_type2 MINUSGREATER core_type2
{ mktyp(Ptyp_arrow("?" ^ $2 , mkoption $4, $6)) }
{ mktyp(Ptyp_arrow(Optional $2 , mkoption $4, $6)) }
| OPTLABEL core_type2 MINUSGREATER core_type2
{ mktyp(Ptyp_arrow("?" ^ $1 , mkoption $2, $4)) }
{ mktyp(Ptyp_arrow(Optional $1 , mkoption $2, $4)) }
| LIDENT COLON core_type2 MINUSGREATER core_type2
{ mktyp(Ptyp_arrow($1, $3, $5)) }
{ mktyp(Ptyp_arrow(Labelled $1, $3, $5)) }
| core_type2 MINUSGREATER core_type2
{ mktyp(Ptyp_arrow("", $1, $3)) }
{ mktyp(Ptyp_arrow(Nolabel, $1, $3)) }
;
simple_core_type:

42
parsing/parsetree.mli
View File

@ -54,10 +54,10 @@ and core_type_desc =
(* _ *)
| Ptyp_var of string
(* 'a *)
| Ptyp_arrow of label * core_type * core_type
(* T1 -> T2 (label = "")
~l:T1 -> T2 (label = "l")
?l:T1 -> T2 (label = "?l")
| Ptyp_arrow of arg_label * core_type * core_type
(* T1 -> T2 Simple
~l:T1 -> T2 Labelled
?l:T1 -> T2 Otional
*)
| Ptyp_tuple of core_type list
(* T1 * ... * Tn
@ -219,18 +219,18 @@ and expression_desc =
*)
| Pexp_function of case list
(* function P1 -> E1 | ... | Pn -> En *)
| Pexp_fun of label * expression option * pattern * expression
(* fun P -> E1 (lab = "", None)
fun ~l:P -> E1 (lab = "l", None)
fun ?l:P -> E1 (lab = "?l", None)
fun ?l:(P = E0) -> E1 (lab = "?l", Some E0)
| Pexp_fun of arg_label * expression option * pattern * expression
(* fun P -> E1 (Simple, None)
fun ~l:P -> E1 (Labelled l, None)
fun ?l:P -> E1 (Optional l, None)
fun ?l:(P = E0) -> E1 (Optional l, Some E0)
Notes:
- If E0 is provided, lab must start with '?'.
- If E0 is provided, only Optional is allowed.
- "fun P1 P2 .. Pn -> E1" is represented as nested Pexp_fun.
- "let f P = E" is represented using Pexp_fun.
*)
| Pexp_apply of expression * (label * expression) list
| Pexp_apply of expression * (arg_label * expression) list
(* E0 ~l1:E1 ... ~ln:En
li can be empty (non labeled argument) or start with '?'
(optional argument).
@ -464,10 +464,10 @@ and class_type_desc =
['a1, ..., 'an] c *)
| Pcty_signature of class_signature
(* object ... end *)
| Pcty_arrow of label * core_type * class_type
(* T -> CT (label = "")
~l:T -> CT (label = "l")
?l:T -> CT (label = "?l")
| Pcty_arrow of arg_label * core_type * class_type
(* T -> CT Simple
~l:T -> CT Labelled l
?l:T -> CT Optional l
*)
| Pcty_extension of extension
(* [%id] *)
@ -540,13 +540,13 @@ and class_expr_desc =
['a1, ..., 'an] c *)
| Pcl_structure of class_structure
(* object ... end *)
| Pcl_fun of label * expression option * pattern * class_expr
(* fun P -> CE (lab = "", None)
fun ~l:P -> CE (lab = "l", None)
fun ?l:P -> CE (lab = "?l", None)
fun ?l:(P = E0) -> CE (lab = "?l", Some E0)
| Pcl_fun of arg_label * expression option * pattern * class_expr
(* fun P -> CE (Simple, None)
fun ~l:P -> CE (Labelled l, None)
fun ?l:P -> CE (Optional l, None)
fun ?l:(P = E0) -> CE (Optional l, Some E0)
*)
| Pcl_apply of class_expr * (label * expression) list
| Pcl_apply of class_expr * (arg_label * expression) list
(* CE ~l1:E1 ... ~ln:En
li can be empty (non labeled argument) or start with '?'
(optional argument).

56
parsing/pprintast.ml
View File

@ -220,15 +220,15 @@ class printer ()= object(self:'self)
method type_with_label f (label,({ptyp_desc;_}as c) ) =
match label with
| "" -> self#core_type1 f c (* otherwise parenthesize *)
| s ->
if s.[0]='?' then
match ptyp_desc with
| Ptyp_constr ({txt;_}, l) ->
assert (is_predef_option txt);
pp f "%s:%a" s (self#list self#core_type1) l
| _ -> failwith "invalid input in print_type_with_label"
else pp f "%s:%a" s self#core_type1 c
| Nolabel -> self#core_type1 f c (* otherwise parenthesize *)
| Labelled s -> pp f "%s:%a" s self#core_type1 c
| Optional s ->
begin match ptyp_desc with
| Ptyp_constr ({txt;_}, l) ->
assert (is_predef_option txt);
pp f "?%s:%a" s (self#list self#core_type1) l
| _ -> failwith "invalid input in print_type_with_label"
end
method core_type f x =
if x.ptyp_attributes <> [] then begin
pp f "((%a)%a)" self#core_type {x with ptyp_attributes=[]}
@ -401,13 +401,11 @@ class printer ()= object(self:'self)
| _ -> self#paren true self#pattern f x
method label_exp f (l,opt,p) =
if l = "" then
match l with
| Nolabel ->
pp f "%a@ " self#simple_pattern p (*single case pattern parens needed here *)
else
if l.[0] = '?' then
let len = String.length l - 1 in
let rest = String.sub l 1 len in begin
match p.ppat_desc with
| Optional rest ->
begin match p.ppat_desc with
| Ppat_var {txt;_} when txt = rest ->
(match opt with
| Some o -> pp f "?(%s=@;%a)@;" rest self#expression o
@ -415,10 +413,10 @@ class printer ()= object(self:'self)
| _ ->
(match opt with
| Some o ->
pp f "%s:(%a=@;%a)@;" l self#pattern1 p self#expression o
| None -> pp f "%s:%a@;" l self#simple_pattern p)
pp f "?%s:(%a=@;%a)@;" rest self#pattern1 p self#expression o
| None -> pp f "?%s:%a@;" rest self#simple_pattern p)
end
else
| Labelled l ->
(match p.ppat_desc with
| Ppat_var {txt;_} when txt = l ->
pp f "~%s@;" l
@ -1058,7 +1056,7 @@ class printer ()= object(self:'self)
if x.pexp_attributes <> [] then pp f "=@;%a" self#expression x
else match x.pexp_desc with
| Pexp_fun (label, eo, p, e) ->
if label="" then
if label=Nolabel then
pp f "%a@ %a" self#simple_pattern p pp_print_pexp_function e
else
pp f "%a@ %a" self#label_exp (label,eo,p) pp_print_pexp_function e
@ -1353,19 +1351,17 @@ class printer ()= object(self:'self)
self#pattern pc_lhs (self#option self#expression ~first:"@;when@;") pc_guard self#under_pipe#expression pc_rhs in
self#list aux f l ~sep:""
method label_x_expression_param f (l,e) =
match l with
| "" -> self#expression2 f e ; (* level 2*)
| lbl ->
let simple_name = match e.pexp_desc with
| Pexp_ident {txt=Lident l;_} -> Some l
| _ -> None in
if lbl.[0] = '?' then
let str = String.sub lbl 1 (String.length lbl-1) in
let simple_name = match e.pexp_desc with
| Pexp_ident {txt=Lident l;_} -> Some l
| _ -> None
in match l with
| Nolabel -> self#expression2 f e ; (* level 2*)
| Optional str ->
if Some str = simple_name then
pp f "%s" lbl
pp f "?%s" str
else
pp f "%s:%a" lbl self#simple_expr e
else
pp f "?%s:%a" str self#simple_expr e
| Labelled lbl ->
if Some lbl = simple_name then
pp f "~%s" lbl
else

6
parsing/pprintast.mli
View File

@ -53,10 +53,10 @@ class printer :
Format.formatter -> Parsetree.extension_constructor -> unit
method label_exp :
Format.formatter ->
Asttypes.label * Parsetree.expression option * Parsetree.pattern ->
Asttypes.arg_label * Parsetree.expression option * Parsetree.pattern ->
unit
method label_x_expression_param :
Format.formatter -> Asttypes.label * Parsetree.expression -> unit
Format.formatter -> Asttypes.arg_label * Parsetree.expression -> unit
method list :
?sep:space_formatter ->
?first:space_formatter ->
@ -113,7 +113,7 @@ class printer :
method type_params :
Format.formatter -> (Parsetree.core_type * Asttypes.variance) list -> unit
method type_with_label :
Format.formatter -> Asttypes.label * Parsetree.core_type -> unit
Format.formatter -> Asttypes.arg_label * Parsetree.core_type -> unit
method tyvar : Format.formatter -> string -> unit
method under_pipe : 'b
method under_semi : 'b

18
parsing/printast.ml
View File

@ -130,6 +130,11 @@ let string i ppf s = line i ppf "\"%s\"\n" s;;
let string_loc i ppf s = line i ppf "%a\n" fmt_string_loc s;;
let bool i ppf x = line i ppf "%s\n" (string_of_bool x);;
let label i ppf x = line i ppf "label=\"%s\"\n" x;;
let arg_label i ppf = function
| Nolabel -> line i ppf "Nolabel\n"
| Optional s -> line i ppf "Optional \"%s\"\n" s
| Labelled s -> line i ppf "Labelled \"%s\"\n" s
;;
let rec core_type i ppf x =
line i ppf "core_type %a\n" fmt_location x.ptyp_loc;
@ -140,7 +145,7 @@ let rec core_type i ppf x =
| Ptyp_var (s) -> line i ppf "Ptyp_var %s\n" s;
| Ptyp_arrow (l, ct1, ct2) ->
line i ppf "Ptyp_arrow\n";
string i ppf l;
arg_label i ppf l;
core_type i ppf ct1;
core_type i ppf ct2;
| Ptyp_tuple l ->
@ -250,7 +255,8 @@ and expression i ppf x =
line i ppf "Pexp_function\n";
list i case ppf l;
| Pexp_fun (l, eo, p, e) ->
line i ppf "Pexp_fun \"%s\"\n" l;
line i ppf "Pexp_fun\n";
arg_label i ppf l;
option i expression ppf eo;
pattern i ppf p;
expression i ppf e;
@ -457,7 +463,8 @@ and class_type i ppf x =
line i ppf "Pcty_signature\n";
class_signature i ppf cs;
| Pcty_arrow (l, co, cl) ->
line i ppf "Pcty_arrow \"%s\"\n" l;
line i ppf "Pcty_arrow\n";
arg_label i ppf l;
core_type i ppf co;
class_type i ppf cl;
| Pcty_extension (s, arg) ->
@ -531,7 +538,7 @@ and class_expr i ppf x =
class_structure i ppf cs;
| Pcl_fun (l, eo, p, e) ->
line i ppf "Pcl_fun\n";
label i ppf l;
arg_label i ppf l;
option i expression ppf eo;
pattern i ppf p;
class_expr i ppf e;
@ -852,7 +859,8 @@ and longident_x_expression i ppf (li, e) =
expression (i+1) ppf e;
and label_x_expression i ppf (l,e) =
line i ppf "<label> \"%s\"\n" l;
line i ppf "<arg>\n";
arg_label i ppf l;
expression (i+1) ppf e;
and label_x_bool_x_core_type_list i ppf x =

8
tools/untypeast.ml
View File

@ -270,7 +270,7 @@ and untype_expression exp =
untype_expression exp)
| Texp_function (label, [{c_lhs=p; c_guard=None; c_rhs=e}], _) ->
Pexp_fun (label, None, untype_pattern p, untype_expression e)
| Texp_function ("", cases, _) ->
| Texp_function (Nolabel, cases, _) ->
Pexp_function (untype_cases cases)
| Texp_function _ ->
assert false
@ -623,14 +623,16 @@ and untype_class_field cf =
Pcf_method (lab, priv, Cfk_virtual (untype_core_type cty))
| Tcf_method (lab, priv, Tcfk_concrete (o, exp)) ->
let remove_fun_self = function
| { exp_desc = Texp_function("", [case], _) } when is_self_pat case.c_lhs && case.c_guard = None -> case.c_rhs
| { exp_desc = Texp_function(Nolabel, [case], _) }
when is_self_pat case.c_lhs && case.c_guard = None -> case.c_rhs
| e -> e
in
let exp = remove_fun_self exp in
Pcf_method (lab, priv, Cfk_concrete (o, untype_expression exp))
| Tcf_initializer exp ->
let remove_fun_self = function
| { exp_desc = Texp_function("", [case], _) } when is_self_pat case.c_lhs && case.c_guard = None -> case.c_rhs
| { exp_desc = Texp_function(Nolabel, [case], _) }
when is_self_pat case.c_lhs && case.c_guard = None -> case.c_rhs
| e -> e
in
let exp = remove_fun_self exp in

2
toplevel/topdirs.ml
View File

@ -236,7 +236,7 @@ let match_generic_printer_type ppf desc path args printer_type =
List.map (fun ty_var -> Ctype.newconstr printer_type [ty_var]) args in
let ty_expected =
List.fold_right
(fun ty_arg ty -> Ctype.newty (Tarrow ("", ty_arg, ty, Cunknown)))
(fun ty_arg ty -> Ctype.newty (Tarrow (Asttypes.Nolabel, ty_arg, ty, Cunknown)))
ty_args (Ctype.newconstr printer_type [ty_target]) in
Ctype.unify !toplevel_env
ty_expected

3
toplevel/trace.ml
View File

@ -52,7 +52,8 @@ let set_code_pointer cls ptr = Obj.set_field cls 0 ptr
let invoke_traced_function codeptr env arg =
Meta.invoke_traced_function codeptr env arg
let print_label ppf l = if l <> "" then fprintf ppf "%s:" l
let print_label ppf l =
if l <> Asttypes.Nolabel then fprintf ppf "%s:" (Printtyp.string_of_label l)
(* If a function returns a functional value, wrap it into a trace code *)

17
typing/btype.ml
View File

@ -13,6 +13,7 @@
(* Basic operations on core types *)
open Misc
open Asttypes
open Types
(**** Sets, maps and hashtables of types ****)
@ -561,15 +562,17 @@ let check_memorized_abbrevs () =
(* Utilities for labels *)
(**********************************)
let is_optional l =
String.length l > 0 && l.[0] = '?'
let is_optional = function Optional _ -> true | _ -> false
let label_name l =
if is_optional l then String.sub l 1 (String.length l - 1)
else l
let label_name = function
Nolabel -> ""
| Labelled s
| Optional s -> s
let prefixed_label_name l =
if is_optional l then l else "~" ^ l
let prefixed_label_name = function
Nolabel -> ""
| Labelled s -> "~" ^ s
| Optional s -> "?" ^ s
let rec extract_label_aux hd l = function
[] -> raise Not_found

10
typing/btype.mli
View File

@ -162,15 +162,15 @@ val forget_abbrev:
(**** Utilities for labels ****)
val is_optional : label -> bool
val label_name : label -> label
val is_optional : arg_label -> bool
val label_name : arg_label -> label
(* Returns the label name with first character '?' or '~' as appropriate. *)
val prefixed_label_name : label -> label
val prefixed_label_name : arg_label -> label
val extract_label :
label -> (label * 'a) list ->
label * 'a * (label * 'a) list * (label * 'a) list
label -> (arg_label * 'a) list ->
arg_label * 'a * (arg_label * 'a) list * (arg_label * 'a) list
(* actual label, value, before list, after list *)
(**** Utilities for backtracking ****)

4
typing/ctype.ml
View File

@ -2848,7 +2848,7 @@ let filter_arrow env t l =
link_type t t';
(t1, t2)
| Tarrow(l', t1, t2, _)
when l = l' || !Clflags.classic && l = "" && not (is_optional l') ->
when l = l' || !Clflags.classic && l = Nolabel && not (is_optional l') ->
(t1, t2)
| _ ->
raise (Unify [])
@ -3656,7 +3656,7 @@ let match_class_declarations env patt_params patt_type subj_params subj_type =
(* Use moregeneral for class parameters, need to recheck everything to
keeps relationships (PR#4824) *)
let clty_params =
List.fold_right (fun ty cty -> Cty_arrow ("*",ty,cty)) in
List.fold_right (fun ty cty -> Cty_arrow (Labelled "*",ty,cty)) in
match_class_types ~trace:false env
(clty_params patt_params patt_type)
(clty_params subj_params subj_type)

2
typing/ctype.mli
View File

@ -161,7 +161,7 @@ val unify_gadt: newtype_level:int -> Env.t ref -> type_expr -> type_expr -> unit
val unify_var: Env.t -> type_expr -> type_expr -> unit
(* Same as [unify], but allow free univars when first type
is a variable. *)
val filter_arrow: Env.t -> type_expr -> label -> type_expr * type_expr
val filter_arrow: Env.t -> type_expr -> arg_label -> type_expr * type_expr
(* A special case of unification (with l:'a -> 'b). *)
val filter_method: Env.t -> string -> private_flag -> type_expr -> type_expr
(* A special case of unification (with {m : 'a; 'b}). *)

5
typing/mtype.ml
View File

@ -44,9 +44,8 @@ and strengthen_sig env sg p pos =
match sg with
[] -> []
| (Sig_value(id, desc) as sigelt) :: rem ->
let pos =
match desc with {val_kind = Val_prim _} -> pos | _ -> pos+1 in
sigelt :: strengthen_sig env rem p pos
let nextpos = match desc.val_kind with Val_prim _ -> pos | _ -> pos+1 in
sigelt :: strengthen_sig env rem p nextpos
| Sig_type(id, decl, rs) :: rem ->
let newdecl =
match decl.type_manifest, decl.type_private, decl.type_kind with

15
typing/printtyp.ml
View File

@ -122,6 +122,11 @@ let print_name ppf = function
None -> fprintf ppf "None"
| Some name -> fprintf ppf "\"%s\"" name
let string_of_label = function
Nolabel -> ""
| Labelled s -> s
| Optional s -> "?"^s
let visited = ref []
let rec raw_type ppf ty =
let ty = safe_repr [] ty in
@ -134,8 +139,8 @@ and raw_type_list tl = raw_list raw_type tl
and raw_type_desc ppf = function
Tvar name -> fprintf ppf "Tvar %a" print_name name
| Tarrow(l,t1,t2,c) ->
fprintf ppf "@[<hov1>Tarrow(%s,@,%a,@,%a,@,%s)@]"
l raw_type t1 raw_type t2
fprintf ppf "@[<hov1>Tarrow(\"%s\",@,%a,@,%a,@,%s)@]"
(string_of_label l) raw_type t1 raw_type t2
(safe_commu_repr [] c)
| Ttuple tl ->
fprintf ppf "@[<1>Ttuple@,%a@]" raw_type_list tl
@ -525,7 +530,7 @@ let reset_and_mark_loops_list tyl =
(* Disabled in classic mode when printing an unification error *)
let print_labels = ref true
let print_label ppf l =
if !print_labels && l <> "" || is_optional l then fprintf ppf "%s:" l
if !print_labels && l <> Nolabel || is_optional l then fprintf ppf "%s:" (string_of_label l)
let rec tree_of_typexp sch ty =
let ty = repr ty in
@ -541,7 +546,7 @@ let rec tree_of_typexp sch ty =
| Tarrow(l, ty1, ty2, _) ->
let pr_arrow l ty1 ty2 =
let lab =
if !print_labels && l <> "" || is_optional l then l else ""
if !print_labels || is_optional l then string_of_label l else ""
in
let t1 =
if is_optional l then
@ -1040,7 +1045,7 @@ let rec tree_of_class_type sch params =
in
Octy_signature (self_ty, List.rev csil)
| Cty_arrow (l, ty, cty) ->
let lab = if !print_labels && l <> "" || is_optional l then l else "" in
let lab = if !print_labels || is_optional l then string_of_label l else "" in
let ty =
if is_optional l then
match (repr ty).desc with

1
typing/printtyp.mli
View File

@ -22,6 +22,7 @@ val tree_of_path: Path.t -> out_ident
val path: formatter -> Path.t -> unit
val string_of_path: Path.t -> string
val raw_type_expr: formatter -> type_expr -> unit
val string_of_label: Asttypes.arg_label -> string
val wrap_printing_env: Env.t -> (unit -> 'a) -> 'a
(* Call the function using the environment for type path shortening *)

19
typing/printtyped.ml
View File

@ -135,6 +135,11 @@ let string i ppf s = line i ppf "\"%s\"\n" s;;
let string_loc i ppf s = line i ppf "\"%s\"\n" s.txt;;
let bool i ppf x = line i ppf "%s\n" (string_of_bool x);;
let label i ppf x = line i ppf "label=\"%s\"\n" x;;
let arg_label i ppf = function
| Nolabel -> line i ppf "Nolabel\n"
| Optional s -> line i ppf "Optional \"%s\"\n" s
| Labelled s -> line i ppf "Labelled \"%s\"\n" s
;;
let attributes i ppf l =
let i = i + 1 in
@ -154,7 +159,7 @@ let rec core_type i ppf x =
| Ttyp_var (s) -> line i ppf "Ttyp_var %s\n" s;
| Ttyp_arrow (l, ct1, ct2) ->
line i ppf "Ttyp_arrow\n";
string i ppf l;
arg_label i ppf l;
core_type i ppf ct1;
core_type i ppf ct2;
| Ttyp_tuple l ->
@ -282,8 +287,8 @@ and expression i ppf x =
list i value_binding ppf l;
expression i ppf e;
| Texp_function (p, l, _partial) ->
line i ppf "Texp_function \"%s\"\n" p;
(* option i expression ppf eo; *)
line i ppf "Texp_function\n";
arg_label i ppf p;
list i case ppf l;
| Texp_apply (e, l) ->
line i ppf "Texp_apply\n";
@ -449,7 +454,8 @@ and class_type i ppf x =
line i ppf "Tcty_signature\n";
class_signature i ppf cs;
| Tcty_arrow (l, co, cl) ->
line i ppf "Tcty_arrow \"%s\"\n" l;
line i ppf "Tcty_arrow\n";
arg_label i ppf l;
core_type i ppf co;
class_type i ppf cl;
@ -515,7 +521,7 @@ and class_expr i ppf x =
class_structure i ppf cs;
| Tcl_fun (l, p, _, ce, _) ->
line i ppf "Tcl_fun\n";
label i ppf l;
arg_label i ppf l;
pattern i ppf p;
class_expr i ppf ce
| Tcl_apply (ce, l) ->
@ -821,7 +827,8 @@ and longident_x_expression i ppf (li, _, e) =
expression (i+1) ppf e;
and label_x_expression i ppf (l, e, _) =
line i ppf "<label> \"%s\"\n" l;
line i ppf "<arg>\n";
arg_label (i+1) ppf l;
(match e with None -> () | Some e -> expression (i+1) ppf e)
and ident_x_loc_x_expression_def i ppf (l,_, e) =

22
typing/typeclass.ml
View File

@ -23,7 +23,7 @@ type error =
| Field_type_mismatch of string * string * (type_expr * type_expr) list
| Structure_expected of class_type
| Cannot_apply of class_type
| Apply_wrong_label of label
| Apply_wrong_label of arg_label
| Pattern_type_clash of type_expr
| Repeated_parameter
| Unbound_class_2 of Longident.t
@ -352,7 +352,7 @@ let type_constraint val_env sty sty' loc =
let make_method loc cl_num expr =
let open Ast_helper in
let mkid s = mkloc s loc in
Exp.fun_ ~loc:expr.pexp_loc "" None
Exp.fun_ ~loc:expr.pexp_loc Nolabel None
(Pat.alias ~loc (Pat.var ~loc (mkid "self-*")) (mkid ("self-" ^ cl_num)))
expr
@ -673,7 +673,7 @@ let rec class_field self_loc cl_num self_type meths vars
let field =
lazy begin
let meth_type =
Btype.newgenty (Tarrow("", self_type, ty, Cok)) in
Btype.newgenty (Tarrow(Nolabel, self_type, ty, Cok)) in
Ctype.raise_nongen_level ();
vars := vars_local;
let texp = type_expect met_env meth_expr meth_type in
@ -698,7 +698,7 @@ let rec class_field self_loc cl_num self_type meths vars
Ctype.raise_nongen_level ();
let meth_type =
Ctype.newty
(Tarrow ("", self_type,
(Tarrow (Nolabel, self_type,
Ctype.instance_def Predef.type_unit, Cok)) in
vars := vars_local;
let texp = type_expect met_env expr meth_type in
@ -988,8 +988,8 @@ and class_expr cl_num val_env met_env scl =
!Clflags.classic ||
let labels = nonopt_labels [] cl.cl_type in
List.length labels = List.length sargs &&
List.for_all (fun (l,_) -> l = "") sargs &&
List.exists (fun l -> l <> "") labels &&
List.for_all (fun (l,_) -> l = Nolabel) sargs &&
List.exists (fun l -> l <> Nolabel) labels &&
begin
Location.prerr_warning cl.cl_loc Warnings.Labels_omitted;
true
@ -1008,7 +1008,7 @@ and class_expr cl_num val_env met_env scl =
(l', sarg0)::_, _ ->
raise(Error(sarg0.pexp_loc, val_env, Apply_wrong_label l'))
| _, (l', sarg0)::more_sargs ->
if l <> l' && l' <> "" then
if l <> l' && l' <> Nolabel then
raise(Error(sarg0.pexp_loc, val_env,
Apply_wrong_label l'))
else ([], more_sargs,
@ -1028,7 +1028,7 @@ and class_expr cl_num val_env met_env scl =
in
if optional = Required && Btype.is_optional l' then
Location.prerr_warning sarg0.pexp_loc
(Warnings.Nonoptional_label l);
(Warnings.Nonoptional_label (Printtyp.string_of_label l));
sargs, more_sargs,
if optional = Required || Btype.is_optional l' then
Some (type_argument val_env sarg0 ty ty0)
@ -1040,7 +1040,7 @@ and class_expr cl_num val_env met_env scl =
with Not_found ->
sargs, more_sargs,
if Btype.is_optional l &&
(List.mem_assoc "" sargs || List.mem_assoc "" more_sargs)
(List.mem_assoc Nolabel sargs || List.mem_assoc Nolabel more_sargs)
then
Some (option_none ty0 Location.none)
else None
@ -1704,8 +1704,8 @@ let report_error env ppf = function
"This class expression is not a class function, it cannot be applied"
| Apply_wrong_label l ->
let mark_label = function
| "" -> "out label"
| l -> sprintf " label ~%s" l in
| Nolabel -> "out label"
| l -> sprintf " label %s" (Btype.prefixed_label_name l) in
fprintf ppf "This argument cannot be applied with%s" (mark_label l)
| Pattern_type_clash ty ->
(* XXX Trace *)

2
typing/typeclass.mli
View File

@ -81,7 +81,7 @@ type error =
| Field_type_mismatch of string * string * (type_expr * type_expr) list
| Structure_expected of class_type
| Cannot_apply of class_type
| Apply_wrong_label of label
| Apply_wrong_label of arg_label
| Pattern_type_clash of type_expr
| Repeated_parameter
| Unbound_class_2 of Longident.t

61
typing/typecore.ml
View File

@ -30,7 +30,7 @@ type error =
| Orpat_vars of Ident.t * Ident.t list
| Expr_type_clash of (type_expr * type_expr) list
| Apply_non_function of type_expr
| Apply_wrong_label of label * type_expr
| Apply_wrong_label of arg_label * type_expr
| Label_multiply_defined of string
| Label_missing of Ident.t list
| Label_not_mutable of Longident.t
@ -51,7 +51,7 @@ type error =
| Coercion_failure of
type_expr * type_expr * (type_expr * type_expr) list * bool
| Too_many_arguments of bool * type_expr
| Abstract_wrong_label of label * type_expr
| Abstract_wrong_label of arg_label * type_expr
| Scoping_let_module of string * type_expr
| Masked_instance_variable of Longident.t
| Not_a_variant_type of Longident.t
@ -1528,12 +1528,11 @@ let rec approx_type env sty =
let rec type_approx env sexp =
match sexp.pexp_desc with
Pexp_let (_, _, e) -> type_approx env e
| Pexp_fun (p, _, _, e) when is_optional p ->
newty (Tarrow(p, type_option (newvar ()), type_approx env e, Cok))
| Pexp_fun (p,_,_, e) ->
newty (Tarrow(p, newvar (), type_approx env e, Cok))
| Pexp_fun (p, _, _, e) ->
let ty = if is_optional p then type_option (newvar ()) else newvar () in
newty (Tarrow(p, ty, type_approx env e, Cok))
| Pexp_function ({pc_rhs=e}::_) ->
newty (Tarrow("", newvar (), type_approx env e, Cok))
newty (Tarrow(Nolabel, newvar (), type_approx env e, Cok))
| Pexp_match (_, {pc_rhs=e}::_) -> type_approx env e
| Pexp_try (e, _) -> type_approx env e
| Pexp_tuple l -> newty (Ttuple(List.map (type_approx env) l))
@ -1919,7 +1918,7 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
l [{pc_lhs=spat; pc_guard=None; pc_rhs=sexp}]
| Pexp_function caselist ->
type_function ?in_function
loc sexp.pexp_attributes env ty_expected "" caselist
loc sexp.pexp_attributes env ty_expected Nolabel caselist
| Pexp_apply(sfunct, sargs) ->
if sargs = [] then
Syntaxerr.ill_formed_ast loc "Function application with no argument.";
@ -2393,7 +2392,7 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
filter_self_method env met Private meths privty
in
let method_type = newvar () in
let (obj_ty, res_ty) = filter_arrow env method_type "" in
let (obj_ty, res_ty) = filter_arrow env method_type Nolabel in
unify env obj_ty desc.val_type;
unify env res_ty (instance env typ);
let exp =
@ -2407,13 +2406,13 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
exp_type = method_type;
exp_attributes = []; (* check *)
exp_env = env},
["",
[ Nolabel,
Some {exp_desc = Texp_ident(path, lid, desc);
exp_loc = obj.exp_loc; exp_extra = [];
exp_type = desc.val_type;
exp_attributes = []; (* check *)
exp_env = env},
Required])
Required ])
in
(Tmeth_name met, Some (re {exp_desc = exp;
exp_loc = loc; exp_extra = [];
@ -3106,7 +3105,7 @@ and type_argument ?recarg env sarg ty_expected' ty_expected =
(* ty_expected' may be generic *)
let no_labels ty =
let ls, tvar = list_labels env ty in
not tvar && List.for_all ((=) "") ls
not tvar && List.for_all ((=) Nolabel) ls
in
let rec is_inferred sexp =
match sexp.pexp_desc with
@ -3117,7 +3116,7 @@ and type_argument ?recarg env sarg ty_expected' ty_expected =
| _ -> false
in
match expand_head env ty_expected' with
{desc = Tarrow("",ty_arg,ty_res,_); level = lv} when is_inferred sarg ->
{desc = Tarrow(Nolabel,ty_arg,ty_res,_); level = lv} when is_inferred sarg ->
(* apply optional arguments when expected type is "" *)
(* we must be very careful about not breaking the semantics *)
if !Clflags.principal then begin_def ();
@ -3131,7 +3130,7 @@ and type_argument ?recarg env sarg ty_expected' ty_expected =
| Tarrow (l,ty_arg,ty_fun,_) when is_optional l ->
let ty = option_none (instance env ty_arg) sarg.pexp_loc in
make_args ((l, Some ty, Optional) :: args) ty_fun
| Tarrow (l,_,ty_res',_) when l = "" || !Clflags.classic ->
| Tarrow (l,_,ty_res',_) when l = Nolabel || !Clflags.classic ->
List.rev args, ty_fun, no_labels ty_res'
| Tvar _ -> List.rev args, ty_fun, false
| _ -> [], texp.exp_type, false
@ -3167,13 +3166,14 @@ and type_argument ?recarg env sarg ty_expected' ty_expected =
{texp with exp_type = ty_res; exp_desc =
Texp_apply
(texp,
args @ ["", Some eta_var, Required])}
args @ [Nolabel, Some eta_var, Required])}
in
{ texp with exp_type = ty_fun; exp_desc =
Texp_function("", [case eta_pat e], Total) }
Texp_function(Nolabel, [case eta_pat e], Total) }
in
Location.prerr_warning texp.exp_loc
(Warnings.Eliminated_optional_arguments (List.map (fun (l, _, _) -> l) args));
(Warnings.Eliminated_optional_arguments
(List.map (fun (l, _, _) -> Printtyp.string_of_label l) args));
if warn then Location.prerr_warning texp.exp_loc
(Warnings.Without_principality "eliminated optional argument");
if is_nonexpansive texp then func texp else
@ -3205,7 +3205,7 @@ and type_application env funct sargs =
let ignored = ref [] in
let rec type_unknown_args
(args :
(Asttypes.label * (unit -> Typedtree.expression) option *
(Asttypes.arg_label * (unit -> Typedtree.expression) option *
Typedtree.optional) list)
omitted ty_fun = function
[] ->
@ -3231,7 +3231,7 @@ and type_application env funct sargs =
unify env ty_fun (newty (Tarrow(l1,t1,t2,Clink(ref Cunknown))));
(t1, t2)
| Tarrow (l,t1,t2,_) when l = l1
|| !Clflags.classic && l1 = "" && not (is_optional l) ->
|| !Clflags.classic && l1 = Nolabel && not (is_optional l) ->
(t1, t2)
| td ->
let ty_fun =
@ -3264,8 +3264,8 @@ and type_application env funct sargs =
not tvar &&
let labels = List.filter (fun l -> not (is_optional l)) ls in
List.length labels = List.length sargs &&
List.for_all (fun (l,_) -> l = "") sargs &&
List.exists (fun l -> l <> "") labels &&
List.for_all (fun (l,_) -> l = Nolabel) sargs &&
List.exists (fun l -> l <> Nolabel) labels &&
(Location.prerr_warning funct.exp_loc Warnings.Labels_omitted;
true)
end
@ -3293,7 +3293,7 @@ and type_application env funct sargs =
raise(Error(sarg0.pexp_loc, env,
Apply_wrong_label(l', ty_old)))
| _, (l', sarg0) :: more_sargs ->
if l <> l' && l' <> "" then
if l <> l' && l' <> Nolabel then
raise(Error(sarg0.pexp_loc, env,
Apply_wrong_label(l', ty_fun')))
else
@ -3319,7 +3319,7 @@ and type_application env funct sargs =
in
if optional = Required && is_optional l' then
Location.prerr_warning sarg0.pexp_loc
(Warnings.Nonoptional_label l);
(Warnings.Nonoptional_label (Printtyp.string_of_label l));
sargs, more_sargs,
if optional = Required || is_optional l' then
Some (fun () -> type_argument env sarg0 ty ty0)
@ -3333,7 +3333,7 @@ and type_application env funct sargs =
with Not_found ->
sargs, more_sargs,
if optional = Optional &&
(List.mem_assoc "" sargs || List.mem_assoc "" more_sargs)
(List.mem_assoc Nolabel sargs || List.mem_assoc Nolabel more_sargs)
then begin
may_warn funct.exp_loc
(Warnings.Without_principality "eliminated optional argument");
@ -3362,8 +3362,8 @@ and type_application env funct sargs =
match funct.exp_desc, sargs with
(* Special case for ignore: avoid discarding warning *)
Texp_ident (_, _, {val_kind=Val_prim{Primitive.prim_name="%ignore"}}),
["", sarg] ->
let ty_arg, ty_res = filter_arrow env (instance env funct.exp_type) "" in
[Nolabel, sarg] ->
let ty_arg, ty_res = filter_arrow env (instance env funct.exp_type) Nolabel in
let exp = type_expect env sarg ty_arg in
begin match (expand_head env exp.exp_type).desc with
| Tarrow _ ->
@ -3372,7 +3372,7 @@ and type_application env funct sargs =
add_delayed_check (fun () -> check_application_result env false exp)
| _ -> ()
end;
(["", Some exp, Required], ty_res)
([Nolabel, Some exp, Required], ty_res)
| _ ->
let ty = funct.exp_type in
if ignore_labels then
@ -3897,7 +3897,7 @@ let report_error env ppf = function
end
| Apply_wrong_label (l, ty) ->
let print_label ppf = function
| "" -> fprintf ppf "without label"
| Nolabel -> fprintf ppf "without label"
| l ->
fprintf ppf "with label %s" (prefixed_label_name l)
in
@ -3999,9 +3999,8 @@ let report_error env ppf = function
end
| Abstract_wrong_label (l, ty) ->
let label_mark = function
| "" -> "but its first argument is not labelled"
| l -> sprintf "but its first argument is labelled %s"
(prefixed_label_name l) in
| Nolabel -> "but its first argument is not labelled"
| l -> sprintf "but its first argument is labelled %s" (prefixed_label_name l) in
reset_and_mark_loops ty;
fprintf ppf "@[<v>@[<2>This function should have type@ %a@]@,%s@]"
type_expr ty (label_mark l)

6
typing/typecore.mli
View File

@ -31,7 +31,7 @@ val type_let:
val type_expression:
Env.t -> Parsetree.expression -> Typedtree.expression
val type_class_arg_pattern:
string -> Env.t -> Env.t -> label -> Parsetree.pattern ->
string -> Env.t -> Env.t -> arg_label -> Parsetree.pattern ->
Typedtree.pattern * (Ident.t * string loc * Ident.t * type_expr) list *
Env.t * Env.t
val type_self_pattern:
@ -72,7 +72,7 @@ type error =
| Orpat_vars of Ident.t * Ident.t list
| Expr_type_clash of (type_expr * type_expr) list
| Apply_non_function of type_expr
| Apply_wrong_label of label * type_expr
| Apply_wrong_label of arg_label * type_expr
| Label_multiply_defined of string
| Label_missing of Ident.t list
| Label_not_mutable of Longident.t
@ -93,7 +93,7 @@ type error =
| Coercion_failure of
type_expr * type_expr * (type_expr * type_expr) list * bool
| Too_many_arguments of bool * type_expr
| Abstract_wrong_label of label * type_expr
| Abstract_wrong_label of arg_label * type_expr
| Scoping_let_module of string * type_expr
| Masked_instance_variable of Longident.t
| Not_a_variant_type of Longident.t

12
typing/typedtree.ml
View File

@ -74,8 +74,8 @@ and expression_desc =
Texp_ident of Path.t * Longident.t loc * Types.value_description
| Texp_constant of constant
| Texp_let of rec_flag * value_binding list * expression
| Texp_function of label * case list * partial
| Texp_apply of expression * (label * expression option * optional) list
| Texp_function of arg_label * case list * partial
| Texp_apply of expression * (arg_label * expression option * optional) list
| Texp_match of expression * case list * case list * partial
| Texp_try of expression * case list
| Texp_tuple of expression list
@ -132,9 +132,9 @@ and class_expr_desc =
Tcl_ident of Path.t * Longident.t loc * core_type list
| Tcl_structure of class_structure
| Tcl_fun of
label * pattern * (Ident.t * string loc * expression) list * class_expr *
arg_label * pattern * (Ident.t * string loc * expression) list * class_expr *
partial
| Tcl_apply of class_expr * (label * expression option * optional) list
| Tcl_apply of class_expr * (arg_label * expression option * optional) list
| Tcl_let of rec_flag * value_binding list *
(Ident.t * string loc * expression) list * class_expr
| Tcl_constraint of
@ -353,7 +353,7 @@ and core_type =
and core_type_desc =
Ttyp_any
| Ttyp_var of string
| Ttyp_arrow of label * core_type * core_type
| Ttyp_arrow of arg_label * core_type * core_type
| Ttyp_tuple of core_type list
| Ttyp_constr of Path.t * Longident.t loc * core_type list
| Ttyp_object of (string * attributes * core_type) list * closed_flag
@ -463,7 +463,7 @@ and class_type =
and class_type_desc =
Tcty_constr of Path.t * Longident.t loc * core_type list
| Tcty_signature of class_signature
| Tcty_arrow of label * core_type * class_type
| Tcty_arrow of arg_label * core_type * class_type
and class_signature = {
csig_self : core_type;

12
typing/typedtree.mli
View File

@ -73,8 +73,8 @@ and expression_desc =
Texp_ident of Path.t * Longident.t loc * Types.value_description
| Texp_constant of constant
| Texp_let of rec_flag * value_binding list * expression
| Texp_function of label * case list * partial
| Texp_apply of expression * (label * expression option * optional) list
| Texp_function of arg_label * case list * partial
| Texp_apply of expression * (arg_label * expression option * optional) list
| Texp_match of expression * case list * case list * partial
| Texp_try of expression * case list
| Texp_tuple of expression list
@ -131,9 +131,9 @@ and class_expr_desc =
Tcl_ident of Path.t * Longident.t loc * core_type list
| Tcl_structure of class_structure
| Tcl_fun of
label * pattern * (Ident.t * string loc * expression) list * class_expr *
arg_label * pattern * (Ident.t * string loc * expression) list * class_expr *
partial
| Tcl_apply of class_expr * (label * expression option * optional) list
| Tcl_apply of class_expr * (arg_label * expression option * optional) list
| Tcl_let of rec_flag * value_binding list *
(Ident.t * string loc * expression) list * class_expr
| Tcl_constraint of
@ -351,7 +351,7 @@ and core_type =
and core_type_desc =
Ttyp_any
| Ttyp_var of string
| Ttyp_arrow of label * core_type * core_type
| Ttyp_arrow of arg_label * core_type * core_type
| Ttyp_tuple of core_type list
| Ttyp_constr of Path.t * Longident.t loc * core_type list
| Ttyp_object of (string * attributes * core_type) list * closed_flag
@ -462,7 +462,7 @@ and class_type =
and class_type_desc =
Tcty_constr of Path.t * Longident.t loc * core_type list
| Tcty_signature of class_signature
| Tcty_arrow of label * core_type * class_type
| Tcty_arrow of arg_label * core_type * class_type
and class_signature = {
csig_self : core_type;

4
typing/types.ml
View File

@ -23,7 +23,7 @@ type type_expr =
and type_desc =
Tvar of string option
| Tarrow of label * type_expr * type_expr * commutable
| Tarrow of arg_label * type_expr * type_expr * commutable
| Ttuple of type_expr list
| Tconstr of Path.t * type_expr list * abbrev_memo ref
| Tobject of type_expr * (Path.t * type_expr list) option ref
@ -202,7 +202,7 @@ module Concr = Set.Make(OrderedString)
type class_type =
Cty_constr of Path.t * type_expr list * class_type
| Cty_signature of class_signature
| Cty_arrow of label * type_expr * class_type
| Cty_arrow of arg_label * type_expr * class_type
and class_signature =
{ csig_self: type_expr;

4
typing/types.mli
View File

@ -23,7 +23,7 @@ type type_expr =
and type_desc =
Tvar of string option
| Tarrow of label * type_expr * type_expr * commutable
| Tarrow of arg_label * type_expr * type_expr * commutable
| Ttuple of type_expr list
| Tconstr of Path.t * type_expr list * abbrev_memo ref
| Tobject of type_expr * (Path.t * type_expr list) option ref
@ -192,7 +192,7 @@ module Concr : Set.S with type elt = string
type class_type =
Cty_constr of Path.t * type_expr list * class_type
| Cty_signature of class_signature
| Cty_arrow of label * type_expr * class_type
| Cty_arrow of arg_label * type_expr * class_type
and class_signature =
{ csig_self: type_expr;