Skip to content

Commit aec6fde

Browse files
lpw25stedolan
lpw25
authored and
stedolan
committed
Interpret arrow types in "local positions" differently
1 parent c4f3319 commit aec6fde

File tree

11 files changed

+5940
-5323
lines changed

11 files changed

+5940
-5323
lines changed

‎boot/menhir/parser.ml‎

Lines changed: 5581 additions & 5189 deletions
Large diffs are not rendered by default.

‎parsing/parser.mly‎

Lines changed: 52 additions & 28 deletions
Original file line numberDiff line numberDiff line change
@@ -175,9 +175,21 @@ let mkpat_stack pat =
175175
let mktyp_stack typ =
176176
{typ with ptyp_attributes = stack_attr :: typ.ptyp_attributes}
177177

178+
let wrap_exp_stack exp =
179+
{exp with pexp_attributes = stack_attr :: exp.pexp_attributes}
180+
181+
let mkexp_stack_if p ~loc exp =
182+
if p then mkexp_stack ~loc exp else exp
183+
184+
let mkpat_stack_if p pat =
185+
if p then mkpat_stack pat else pat
186+
178187
let mktyp_stack_if p typ =
179188
if p then mktyp_stack typ else typ
180189

190+
let wrap_exp_stack_if p exp =
191+
if p then wrap_exp_stack exp else exp
192+
181193
let curry_attr =
182194
Attr.mk ~loc:Location.none (mknoloc "curry") (PStr [])
183195

@@ -2158,22 +2170,16 @@ seq_expr:
21582170
mkexp ~loc:$sloc (Pexp_extension ($4, payload)) }
21592171
;
21602172
labeled_simple_pattern:
2161-
QUESTION LPAREN label_let_pattern opt_default RPAREN
2162-
{ (Optional (fst $3), $4, snd $3) }
2163-
| QUESTION LPAREN LOCAL label_let_pattern opt_default RPAREN
2164-
{ (Optional (fst $4), $5, mkpat_stack (snd $4)) }
2173+
QUESTION LPAREN optional_local label_let_pattern opt_default RPAREN
2174+
{ (Optional (fst $4), $5, mkpat_stack_if $3 (snd $4)) }
21652175
| QUESTION label_var
21662176
{ (Optional (fst $2), None, snd $2) }
2167-
| OPTLABEL LPAREN let_pattern opt_default RPAREN
2168-
{ (Optional $1, $4, $3) }
2169-
| OPTLABEL LPAREN LOCAL let_pattern opt_default RPAREN
2170-
{ (Optional $1, $5, mkpat_stack $4) }
2177+
| OPTLABEL LPAREN optional_local let_pattern opt_default RPAREN
2178+
{ (Optional $1, $5, mkpat_stack_if $3 $4) }
21712179
| OPTLABEL pattern_var
21722180
{ (Optional $1, None, $2) }
2173-
| TILDE LPAREN label_let_pattern RPAREN
2174-
{ (Labelled (fst $3), None, snd $3) }
2175-
| TILDE LPAREN LOCAL label_let_pattern RPAREN
2176-
{ (Labelled (fst $4), None, mkpat_stack (snd $4)) }
2181+
| TILDE LPAREN optional_local label_let_pattern RPAREN
2182+
{ (Labelled (fst $4), None, mkpat_stack_if $3 (snd $4)) }
21772183
| TILDE label_var
21782184
{ (Labelled (fst $2), None, snd $2) }
21792185
| LABEL simple_pattern
@@ -2506,28 +2512,38 @@ labeled_simple_expr:
25062512
let_binding_body:
25072513
let_ident strict_binding
25082514
{ ($1, $2) }
2509-
| let_ident type_constraint EQUAL seq_expr
2510-
{ let v = $1 in (* PR#7344 *)
2515+
| optional_local let_ident type_constraint EQUAL seq_expr
2516+
{ let v = $2 in (* PR#7344 *)
25112517
let t =
2512-
match $2 with
2518+
match $3 with
25132519
Some t, None -> t
25142520
| _, Some t -> t
25152521
| _ -> assert false
25162522
in
25172523
let loc = Location.(t.ptyp_loc.loc_start, t.ptyp_loc.loc_end) in
25182524
let typ = ghtyp ~loc (Ptyp_poly([],t)) in
2519-
let patloc = ($startpos($1), $endpos($2)) in
2520-
(ghpat ~loc:patloc (Ppat_constraint(v, typ)),
2521-
mkexp_constraint ~loc:$sloc $4 $2) }
2522-
| let_ident COLON typevar_list DOT core_type EQUAL seq_expr
2525+
let patloc = ($startpos($2), $endpos($3)) in
2526+
let pat =
2527+
mkpat_stack_if $1 (ghpat ~loc:patloc (Ppat_constraint(v, typ)))
2528+
in
2529+
let exp =
2530+
mkexp_stack_if $1 ~loc:$sloc
2531+
(wrap_exp_stack_if $1 (mkexp_constraint ~loc:$sloc $5 $3))
2532+
in
2533+
(pat, exp) }
2534+
| optional_local let_ident COLON typevar_list DOT core_type EQUAL seq_expr
25232535
(* TODO: could replace [typevar_list DOT core_type]
25242536
with [mktyp(poly(core_type))]
25252537
and simplify the semantic action? *)
2526-
{ let typloc = ($startpos($3), $endpos($5)) in
2527-
let patloc = ($startpos($1), $endpos($5)) in
2528-
(ghpat ~loc:patloc
2529-
(Ppat_constraint($1, ghtyp ~loc:typloc (Ptyp_poly($3,$5)))),
2530-
$7) }
2538+
{ let typloc = ($startpos($4), $endpos($6)) in
2539+
let patloc = ($startpos($2), $endpos($6)) in
2540+
let pat =
2541+
mkpat_stack_if $1
2542+
(ghpat ~loc:patloc
2543+
(Ppat_constraint($2, ghtyp ~loc:typloc (Ptyp_poly($4,$6)))))
2544+
in
2545+
let exp = mkexp_stack_if $1 ~loc:$sloc $8 in
2546+
(pat, exp) }
25312547
| let_ident COLON TYPE lident_list DOT core_type EQUAL seq_expr
25322548
{ let exp, poly =
25332549
wrap_type_annotation ~loc:$sloc $4 $6 $8 in
@@ -2538,7 +2554,7 @@ let_binding_body:
25382554
| simple_pattern_not_ident COLON core_type EQUAL seq_expr
25392555
{ let loc = ($startpos($1), $endpos($3)) in
25402556
(ghpat ~loc (Ppat_constraint($1, $3)), $5) }
2541-
| LOCAL let_ident strict_binding_with_fun
2557+
| LOCAL let_ident local_strict_binding
25422558
{ ($2, mkexp_stack ~loc:$sloc $3) }
25432559
;
25442560
(* The formal parameter EXT can be instantiated with ext or no_ext
@@ -2603,10 +2619,18 @@ strict_binding:
26032619
| LPAREN TYPE lident_list RPAREN fun_binding
26042620
{ mk_newtypes ~loc:$sloc $3 $5 }
26052621
;
2606-
strict_binding_with_fun:
2607-
| labeled_simple_pattern fun_binding
2622+
local_fun_binding:
2623+
local_strict_binding
2624+
{ $1 }
2625+
| type_constraint EQUAL seq_expr
2626+
{ wrap_exp_stack (mkexp_constraint ~loc:$sloc $3 $1) }
2627+
;
2628+
local_strict_binding:
2629+
EQUAL seq_expr
2630+
{ $2 }
2631+
| labeled_simple_pattern local_fun_binding
26082632
{ let (l, o, p) = $1 in ghexp ~loc:$sloc (Pexp_fun(l, o, p, $2)) }
2609-
| LPAREN TYPE lident_list RPAREN strict_binding_with_fun
2633+
| LPAREN TYPE lident_list RPAREN local_fun_binding
26102634
{ mk_newtypes ~loc:$sloc $3 $5 }
26112635
;
26122636
%inline match_cases:

‎testsuite/tests/typing-local/local.ml‎

Lines changed: 159 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -31,6 +31,52 @@ let (!) = fun (local_ r) -> r.contents
3131
val ( ! ) : local_ 'a ref -> 'a = <fun>
3232
|}]
3333

34+
(* Local lets *)
35+
36+
let leak n =
37+
let local_ r = ref n in
38+
r
39+
[%%expect{|
40+
Line 3, characters 2-3:
41+
3 | r
42+
^
43+
Error: This local value escapes its region
44+
Hint: Cannot return local value without an explicit "local_" annotation
45+
|}]
46+
47+
let leak n =
48+
let local_ r : int ref = ref n in
49+
r
50+
[%%expect{|
51+
Line 3, characters 2-3:
52+
3 | r
53+
^
54+
Error: This local value escapes its region
55+
Hint: Cannot return local value without an explicit "local_" annotation
56+
|}]
57+
58+
let leak n =
59+
let local_ f : 'a. 'a -> 'a = fun x -> x in
60+
f
61+
[%%expect{|
62+
Line 3, characters 2-3:
63+
3 | f
64+
^
65+
Error: This local value escapes its region
66+
Hint: Cannot return local value without an explicit "local_" annotation
67+
|}]
68+
69+
let leak n =
70+
let local_ f x : int = x in
71+
f
72+
[%%expect{|
73+
Line 3, characters 2-3:
74+
3 | f
75+
^
76+
Error: This local value escapes its region
77+
Hint: Cannot return local value without an explicit "local_" annotation
78+
|}]
79+
3480
(*
3581
* Type equalities of function types
3682
*)
@@ -70,6 +116,119 @@ Error: The type constraints are not consistent.
70116
Type local_ int -> int is not compatible with type local_ int -> local_ int
71117
|}]
72118

119+
type local_higher_order = unit constraint
120+
local_ (int -> int -> int) -> int = local_ (int -> local_ (int -> int)) -> int
121+
[%%expect{|
122+
type local_higher_order = unit
123+
|}]
124+
125+
type nonlocal_higher_order = unit constraint
126+
(int -> int -> int) -> int = (int -> local_ (int -> int)) -> int
127+
[%%expect{|
128+
Line 2, characters 2-66:
129+
2 | (int -> int -> int) -> int = (int -> local_ (int -> int)) -> int
130+
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
131+
Error: The type constraints are not consistent.
132+
Type (int -> int -> int) -> int is not compatible with type
133+
(int -> local_ (int -> int)) -> int
134+
Type int -> int -> int is not compatible with type int -> local_ (int -> int)
135+
|}]
136+
137+
type local_higher_order = unit constraint
138+
int -> local_ (int -> int -> int) = int -> local_ (int -> local_ (int -> int))
139+
[%%expect{|
140+
type local_higher_order = unit
141+
|}]
142+
143+
type nonlocal_higher_order = unit constraint
144+
int -> (int -> int -> int) = int -> (int -> local_ (int -> int))
145+
[%%expect{|
146+
Line 2, characters 2-66:
147+
2 | int -> (int -> int -> int) = int -> (int -> local_ (int -> int))
148+
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
149+
Error: The type constraints are not consistent.
150+
Type int -> int -> int -> int is not compatible with type
151+
int -> int -> local_ (int -> int)
152+
Type int -> int -> int is not compatible with type int -> local_ (int -> int)
153+
|}]
154+
155+
let foo () =
156+
let local_ _bar : int -> int -> int =
157+
((fun y z -> z) : int -> local_ (int -> int)) in
158+
()
159+
[%%expect{|
160+
val foo : unit -> unit = <fun>
161+
|}]
162+
163+
let foo () =
164+
let _bar : int -> int -> int =
165+
((fun y z -> z) : int -> local_ (int -> int)) in
166+
()
167+
[%%expect{|
168+
Line 3, characters 4-49:
169+
3 | ((fun y z -> z) : int -> local_ (int -> int)) in
170+
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
171+
Error: This expression has type int -> local_ (int -> int)
172+
but an expression was expected of type int -> int -> int
173+
|}]
174+
175+
let foo () =
176+
let local_ _bar : 'a. 'a -> 'a -> 'a =
177+
((fun y z -> z) : _ -> local_ (_ -> _)) in
178+
()
179+
[%%expect{|
180+
val foo : unit -> unit = <fun>
181+
|}]
182+
183+
let foo () =
184+
let _bar : 'a. 'a -> 'a -> 'a =
185+
((fun y z -> z) : _ -> local_ (_ -> _)) in
186+
()
187+
[%%expect{|
188+
Line 3, characters 4-43:
189+
3 | ((fun y z -> z) : _ -> local_ (_ -> _)) in
190+
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
191+
Error: This expression has type 'b -> local_ ('c -> 'c)
192+
but an expression was expected of type 'a -> 'a -> 'a
193+
|}]
194+
195+
let foo () =
196+
let local_ _bar x : int -> int -> int =
197+
((fun y z -> z) : int -> local_ (int -> int)) in
198+
()
199+
[%%expect{|
200+
val foo : unit -> unit = <fun>
201+
|}]
202+
203+
let foo () =
204+
let _bar x : int -> int -> int =
205+
((fun y z -> z) : int -> local_ (int -> int)) in
206+
()
207+
[%%expect{|
208+
Line 3, characters 4-49:
209+
3 | ((fun y z -> z) : int -> local_ (int -> int)) in
210+
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
211+
Error: This expression has type int -> local_ (int -> int)
212+
but an expression was expected of type int -> int -> int
213+
|}]
214+
215+
let foo (local_ bar : int -> int -> int) =
216+
let _ = (bar : int -> local_ (int -> int)) in
217+
()
218+
[%%expect{|
219+
val foo : local_ (int -> int -> int) -> unit = <fun>
220+
|}]
221+
222+
let foo (bar : int -> int -> int) =
223+
let _ = (bar : int -> local_ (int -> int)) in
224+
()
225+
[%%expect{|
226+
Line 2, characters 11-14:
227+
2 | let _ = (bar : int -> local_ (int -> int)) in
228+
^^^
229+
Error: This expression has type int -> int -> int
230+
but an expression was expected of type int -> local_ (int -> int)
231+
|}]
73232

74233

75234
(*

0 commit comments

Comments
 (0)