Skip to content

Commit 65480ac

Browse files
vivianyydvivianyyd
authored
[%src_pos] in fn decls and defns (#1579)
* src_pos in fn decls and defns * Revert is_optional modifications for now * src_pos shouldn't work in arbitrary places * Tidy code * Whitespace * Add test * Comment on documentation * Whitespace * more whitespace * Amend test to use Position * Correctly print [%src_pos] rather than lexing_position and fix corresponding test * Store hard-coded string in variable * Hacky outcometree printing without creating nontrivial node * Update documentation for Position labels * Update tests * Fix erroneously printing lexing_position for Position arguments * Clean up code * Reconstruct constraint for Position arguments in Untypeast * Update tests * Move comments around * Slightly prettify * Use Location.none in Untypeast reconstructed extensions * Add Ttyp_src_pos to Typedtree * Add CR * Comments * Clean up code * Update comment in printtyp.ml * Add documentation for Ttyp_src_pos, remove extraneous comments * *synonyms.ml * src_pos in fn decls and defns * Revert is_optional modifications for now * src_pos shouldn't work in arbitrary places * Tidy code * Whitespace * Add test * Comment on documentation * Whitespace * Correctly print [%src_pos] rather than lexing_position and fix corresponding test * Store hard-coded string in variable * Hacky outcometree printing without creating nontrivial node * Update documentation for Position labels * Update tests * Fix erroneously printing lexing_position for Position arguments * Clean up code * Reconstruct constraint for Position arguments in Untypeast * Update tests * Move comments around * Slightly prettify * Use Location.none in Untypeast reconstructed extensions * Add Ttyp_src_pos to Typedtree * Add CR * Comments * Clean up code * Add documentation for Ttyp_src_pos, remove extraneous comments * *synonyms.ml * Merge cleanup * Add label to Octy_arrow * Rename function * transl_label checks for Position * Pass None to transl_label for classes * Add comment * Delete comment * Consider Position when approximating type * Add tests for application, recursion * Error messages mention Position * Prettify * Comments * Rename function * Add comment * Remove extraneous calls to label translation * Test type-based disambiguation * Add comment for fn app labels * Add commuting tests * Remove duplicated src_pos match logic * Reduce instances of src_pos string * src_pos in fn decls and defns * src_pos shouldn't work in arbitrary places * Whitespace * Correctly print [%src_pos] rather than lexing_position and fix corresponding test * Store hard-coded string in variable * Hacky outcometree printing without creating nontrivial node * Clean up code * Slightly prettify * Add CR * Clean up code * Update comment in printtyp.ml * Merge cleanup * Add label to Octy_arrow * Rename function * transl_label checks for Position * Pass None to transl_label for classes * Add comment * Delete comment * Consider Position when approximating type * Add tests for application, recursion * Error messages mention Position * Prettify * Comments * Rename function * Add comment * Remove extraneous calls to label translation * Test type-based disambiguation * Add comment for fn app labels * Add commuting tests * Remove duplicated src_pos match logic * Reduce instances of src_pos string * Make things is_optional again * Add commuting tests * Add transl_label_from_pat * Whitespace * Parenthesize src_pos in error message * Fix test
1 parent e17a714 commit 65480ac

27 files changed

+493
-103
lines changed

‎ocaml/ocamldoc/odoc_sig.ml

+3-1
Original file line numberDiff line numberDiff line change
@@ -1783,7 +1783,9 @@ module Analyser =
17831783
| (Parsetree.Pcty_arrow (parse_label, _, pclass_type), Types.Cty_arrow (label, type_expr, class_type)) ->
17841784
(* label = string. In signature, there is no parameter names inside tuples *)
17851785
(* if label = "", no label . Here we have the information to determine if a label is explicit or not. *)
1786-
if (Typetexp.transl_label parse_label) = label then
1786+
(* CR src_pos: Implement Position arguments for classes, and pass a
1787+
reasonable type to translate the label below *)
1788+
if (Typetexp.transl_label parse_label None) = label then
17871789
(
17881790
let new_param = Simple_name
17891791
{

‎ocaml/parsing/parsetree.mli

+5-2
Original file line numberDiff line numberDiff line change
@@ -170,8 +170,8 @@ and core_type_desc =
170170

171171
and arg_label = Asttypes.arg_label =
172172
Nolabel
173-
| Labelled of string (** [label:T -> ...] *)
174-
| Optional of string (** [?label:T -> ...] *)
173+
| Labelled of string
174+
| Optional of string
175175

176176
and package_type = Longident.t loc * (Longident.t loc * core_type) list
177177
(** As {!package_type} typed values:
@@ -338,6 +338,9 @@ and expression_desc =
338338
{{!expression_desc.Pexp_fun}[Pexp_fun]}.
339339
- [let f P = E] is represented using
340340
{{!expression_desc.Pexp_fun}[Pexp_fun]}.
341+
- While Position arguments ([lbl:[%src_pos] -> ...]) are parsed as
342+
{{!Asttypes.arg_label.Labelled}[Labelled l]}, they are converted to
343+
{{!Types.arg_label.Position}[Position l]} arguments for type-checking.
341344
*)
342345
| Pexp_apply of expression * (arg_label * expression) list
343346
(** [Pexp_apply(E0, [(l1, E1) ; ... ; (ln, En)])]

‎ocaml/testsuite/tests/typing-implicit-source-positions/commuting.ml

+95
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,95 @@
1+
(* TEST
2+
* expect
3+
*)
4+
5+
let pos_a : lexing_position = {Lexing.dummy_pos with pos_fname = "a"};;
6+
let pos_b : lexing_position = {Lexing.dummy_pos with pos_fname = "b"};;
7+
[%%expect{|
8+
val pos_a : lexing_position =
9+
{pos_fname = "a"; pos_lnum = 0; pos_bol = 0; pos_cnum = -1}
10+
val pos_b : lexing_position =
11+
{pos_fname = "b"; pos_lnum = 0; pos_bol = 0; pos_cnum = -1}
12+
|}]
13+
14+
let f = fun ~(a:[%src_pos]) ~(b:[%src_pos]) () -> a, b
15+
[%%expect{|
16+
val f :
17+
a:[%src_pos] -> b:[%src_pos] -> unit -> lexing_position * lexing_position =
18+
<fun>
19+
|}]
20+
21+
let _ = f ~b:pos_b ~a:pos_a () ;;
22+
[%%expect{|
23+
- : lexing_position * lexing_position =
24+
({pos_fname = "a"; pos_lnum = 0; pos_bol = 0; pos_cnum = -1},
25+
{pos_fname = "b"; pos_lnum = 0; pos_bol = 0; pos_cnum = -1})
26+
|}]
27+
28+
(* Partial application *)
29+
let x = f ~b:pos_b ;;
30+
let y = x ~a:pos_a ;;
31+
let z = y () ;;
32+
[%%expect {|
33+
val x : a:[%src_pos] -> unit -> lexing_position * lexing_position = <fun>
34+
val y : unit -> lexing_position * lexing_position = <fun>
35+
val z : lexing_position * lexing_position =
36+
({pos_fname = "a"; pos_lnum = 0; pos_bol = 0; pos_cnum = -1},
37+
{pos_fname = "b"; pos_lnum = 0; pos_bol = 0; pos_cnum = -1})
38+
|}]
39+
40+
let g = fun ~(a:[%src_pos]) ?(c = 0) ~(b:[%src_pos]) () -> a, b, c
41+
[%%expect{|
42+
val g :
43+
a:[%src_pos] ->
44+
?c:int -> b:[%src_pos] -> unit -> lexing_position * lexing_position * int =
45+
<fun>
46+
|}]
47+
48+
let _ = g ~b:pos_b ~a:pos_a () ;;
49+
[%%expect{|
50+
- : lexing_position * lexing_position * int =
51+
({pos_fname = "a"; pos_lnum = 0; pos_bol = 0; pos_cnum = -1},
52+
{pos_fname = "b"; pos_lnum = 0; pos_bol = 0; pos_cnum = -1}, 0)
53+
|}]
54+
55+
let h = fun ~(a:[%src_pos]) ~(b:int) () -> a, b
56+
[%%expect{|
57+
val h : a:[%src_pos] -> b:int -> unit -> lexing_position * int = <fun>
58+
|}]
59+
60+
let _ = h ~b:0 ~a:pos_a ();;
61+
[%%expect{|
62+
- : lexing_position * int =
63+
({pos_fname = "a"; pos_lnum = 0; pos_bol = 0; pos_cnum = -1}, 0)
64+
|}]
65+
66+
let k = fun ~(a:int) ~(a:[%src_pos])() -> a
67+
[%%expect{|
68+
val k : a:int -> a:[%src_pos] -> unit -> lexing_position = <fun>
69+
|}]
70+
71+
let _ = k ~a:Lexing.dummy_pos ~a:0 ();;
72+
[%%expect{|
73+
Line 1, characters 13-29:
74+
1 | let _ = k ~a:Lexing.dummy_pos ~a:0 ();;
75+
^^^^^^^^^^^^^^^^
76+
Error: This expression has type Lexing.position = lexing_position
77+
but an expression was expected of type int
78+
|}]
79+
80+
let _ = k ~a:0 ~a:Lexing.dummy_pos ();;
81+
[%%expect{|
82+
- : Lexing.position =
83+
{Lexing.pos_fname = ""; pos_lnum = 0; pos_bol = 0; pos_cnum = -1}
84+
|}]
85+
86+
(* Labels on source positions can't commute in definitions *)
87+
let m : a:[%src_pos] -> b:[%src_pos] -> unit -> unit = fun ~(b:[%src_pos]) ~(a:[%src_pos]) () -> ()
88+
[%%expect{|
89+
Line 1, characters 55-99:
90+
1 | let m : a:[%src_pos] -> b:[%src_pos] -> unit -> unit = fun ~(b:[%src_pos]) ~(a:[%src_pos]) () -> ()
91+
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
92+
Error: This function should have type
93+
a:[%src_pos] -> b:[%src_pos] -> unit -> unit
94+
but its first argument is ~(b:[%src_pos]) instead of ~(a:[%src_pos])
95+
|}]

‎ocaml/testsuite/tests/typing-implicit-source-positions/fn_decl_and_defn.ml

+41
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,41 @@
1+
(* TEST
2+
* expect
3+
*)
4+
5+
type t = src_pos:[%src_pos] -> unit -> unit
6+
7+
[%%expect {|
8+
type t = src_pos:[%src_pos] -> unit -> unit
9+
|}]
10+
11+
let f : t = fun ~(src_pos:[%src_pos]) () -> ()
12+
13+
[%%expect{|
14+
val f : t = <fun>
15+
|}]
16+
17+
let g ~(src_pos:[%src_pos]) () = ()
18+
19+
[%%expect{|
20+
val g : src_pos:[%src_pos] -> unit -> unit = <fun>
21+
|}]
22+
23+
let apply (f : t) = f ~src_pos:Lexing.dummy_pos () ;;
24+
[%%expect {|
25+
val apply : t -> unit = <fun>
26+
|}]
27+
28+
let _ = apply f ;;
29+
[%%expect{|
30+
- : unit = ()
31+
|}]
32+
33+
let _ = apply g ;;
34+
[%%expect{|
35+
- : unit = ()
36+
|}]
37+
38+
let _ = g ~src_pos:Lexing.dummy_pos () ;;
39+
[%%expect{|
40+
- : unit = ()
41+
|}]

‎ocaml/testsuite/tests/typing-implicit-source-positions/invalid_usages.ml

+78
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,78 @@
1+
(* TEST
2+
* expect
3+
*)
4+
5+
type t = [%src_pos]
6+
[%%expect {|
7+
Line 1, characters 11-18:
8+
1 | type t = [%src_pos]
9+
^^^^^^^
10+
Error: Uninterpreted extension 'src_pos'.
11+
|}]
12+
(* CR src_pos: Improve this error message to notify that [%src_pos] may only
13+
be used in arguments *)
14+
15+
type t = unit -> unit -> [%src_pos]
16+
[%%expect {|
17+
Line 1, characters 27-34:
18+
1 | type t = unit -> unit -> [%src_pos]
19+
^^^^^^^
20+
Error: Uninterpreted extension 'src_pos'.
21+
|}]
22+
23+
let f ~(src_pos:[%src_pos]) () : [%src_pos] = src_pos
24+
25+
[%%expect{|
26+
Line 1, characters 35-42:
27+
1 | let f ~(src_pos:[%src_pos]) () : [%src_pos] = src_pos
28+
^^^^^^^
29+
Error: Uninterpreted extension 'src_pos'.
30+
|}]
31+
32+
let apply f = f ~src_pos:Lexing.dummy_pos () ;;
33+
[%%expect {|
34+
val apply : (src_pos:Lexing.position -> unit -> 'a) -> 'a = <fun>
35+
|}]
36+
37+
let g = fun ~(src_pos:[%src_pos]) () -> ()
38+
[%%expect{|
39+
val g : src_pos:[%src_pos] -> unit -> unit = <fun>
40+
|}]
41+
42+
let _ = apply g ;;
43+
[%%expect{|
44+
Line 1, characters 14-15:
45+
1 | let _ = apply g ;;
46+
^
47+
Error: This expression has type src_pos:[%src_pos] -> unit -> unit
48+
but an expression was expected of type
49+
src_pos:Lexing.position -> unit -> 'a
50+
|}]
51+
52+
let h ?(src_pos:[%src_pos]) () = ()
53+
[%%expect{|
54+
Line 1, characters 16-26:
55+
1 | let h ?(src_pos:[%src_pos]) () = ()
56+
^^^^^^^^^^
57+
Error: A position argument must not be optional.
58+
|}]
59+
60+
let j (src_pos:[%src_pos]) () = ()
61+
[%%expect{|
62+
Line 1, characters 15-25:
63+
1 | let j (src_pos:[%src_pos]) () = ()
64+
^^^^^^^^^^
65+
Error: A position argument must not be unlabelled.
66+
|}]
67+
68+
let k : src_pos:[%src_pos] -> unit -> unit =
69+
fun ~src_pos () -> ()
70+
(* CR src_pos: Improve this error message *)
71+
[%%expect{|
72+
Line 2, characters 3-24:
73+
2 | fun ~src_pos () -> ()
74+
^^^^^^^^^^^^^^^^^^^^^
75+
Error: This function should have type src_pos:[%src_pos] -> unit -> unit
76+
but its first argument is labeled ~src_pos
77+
instead of ~(src_pos:[%src_pos])
78+
|}]

‎ocaml/testsuite/tests/typing-implicit-source-positions/named_function.ml

-30
This file was deleted.

‎ocaml/testsuite/tests/typing-implicit-source-positions/recursion.ml

+49
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,49 @@
1+
(* TEST
2+
* expect
3+
*)
4+
5+
type t = {
6+
pos_fname : string;
7+
pos_lnum : int;
8+
pos_bol : int;
9+
pos_cnum : int;
10+
}
11+
[%%expect{|
12+
type t = {
13+
pos_fname : string;
14+
pos_lnum : int;
15+
pos_bol : int;
16+
pos_cnum : int;
17+
}
18+
|}]
19+
20+
(* type-based disambiguation *)
21+
let rec f ~(src_pos:[%src_pos]) i =
22+
if i < 0 then 0
23+
else f ~src_pos:{ pos_fname = ""
24+
; pos_lnum = 0
25+
; pos_bol = 0
26+
; pos_cnum = -1 }
27+
(i - 1)
28+
[%%expect {|
29+
val f : src_pos:[%src_pos] -> int -> int = <fun>
30+
|}]
31+
32+
let y = { pos_fname = ""
33+
; pos_lnum = 0
34+
; pos_bol = 0
35+
; pos_cnum = -1 }
36+
[%%expect {|
37+
val y : t = {pos_fname = ""; pos_lnum = 0; pos_bol = 0; pos_cnum = -1}
38+
|}]
39+
40+
let rec g ~(src_pos:[%src_pos]) i =
41+
if i < 0 then 0
42+
else g ~src_pos:y (i - 1)
43+
[%%expect {|
44+
Line 3, characters 18-19:
45+
3 | else g ~src_pos:y (i - 1)
46+
^
47+
Error: This expression has type t but an expression was expected of type
48+
lexing_position
49+
|}]

‎ocaml/testsuite/tests/typing-implicit-source-positions/shadowing.ml

+5-5
Original file line numberDiff line numberDiff line change
@@ -4,24 +4,24 @@
44

55
(* Shadowing *)
66

7-
type lexing_position = int
7+
type lexing_position = int
88
[%%expect{|
99
type lexing_position = int
1010
|}]
1111

1212
(* src_pos works *)
13-
let f ~(src_pos:[%src_pos]) = ();;
13+
let f ~(src_pos:[%src_pos]) () = ();;
1414
[%%expect{|
15-
val f : src_pos:lexing_position/2 -> unit = <fun>
15+
val f : src_pos:[%src_pos] -> unit -> unit = <fun>
1616
|}]
1717

18-
let _ = f ~src_pos:{pos_fname="hello" ; pos_lnum=1; pos_bol=2; pos_cnum=3} ;;
18+
let _ = f ~src_pos:Lexing.dummy_pos () ;;
1919
[%%expect{|
2020
- : unit = ()
2121
|}]
2222

2323
(* new type works *)
24-
let h (x:lexing_position) = x ;;
24+
let h (x : lexing_position) = x ;;
2525
[%%expect{|
2626
val h : lexing_position -> lexing_position = <fun>
2727
|}]

0 commit comments

Comments
 (0)