Implicit source positions object system support

chamelon/compat.jst.ml

@@ -20,26 +20,6 @@ type nonrec apply_arg = apply_arg
 type texp_apply_identifier = apply_position * Locality.t
 
 let mkTexp_apply ?id:(pos, mode = (Default, Locality.legacy)) (exp, args) =
-  (* XXX jrodri: Question! I am unsure if my approach for fixing
-     this subdirectory is sane. It seems like chamelon needs to run on both a "JST" version
-     and an "upstream" version. The JST version changes Typedtree with a new arg_label,
-     while the upstream version still does not have this new arg_label type.
-
-     jrodri: My first approach was to make this entire subdirectory use
-     [Typedtree.arg_label] which made `make minimizer` build fine, but
-     sadly made `make minimizer-upstream` fail. I then made the mli's keep
-     using [Asttypes.arg_label], and only perform the conversion here in
-     [compat.jst.ml] like in the diff below; however, I think this sadly means
-     that - since I always send in None/don't have access to the [core_type]/the
-     original AST pattern with the [(... : [%src_pos])] constraint, I may not
-     be able to retrieve things here...
-
-     jrodriguez: In the context of chamelon, is the below segment correct?
-     jrodriguez: Should my approach for fixing the [make minimizer] <-> [make
-     minimizer-upstream] compatibility relationship be different? (e.g. maybe changing the
-     dune.upstream/dune.jst files to be aware of the Typedtree change?/something else?)
-     Thanks!
-  *)
   let args =
     List.map (fun (label, x) -> (Typetexp.transl_label label None, x)) args
   in

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

@@ -93,3 +93,62 @@ Error: This function should have type
          a:[%src_pos] -> b:[%src_pos] -> unit -> unit
        but its first argument is ~(b:[%src_pos]) instead of ~(a:[%src_pos])
 |}]
+
+(* Object system *)
+
+class c ~(a : [%src_pos]) ~(b : [%src_pos]) () =
+  object 
+    method x = a, b
+  end
+[%%expect{|
+class c :
+  a:[%src_pos] ->
+  b:[%src_pos] ->
+  unit -> object method x : lexing_position * lexing_position end
+|}]
+
+(* Object system partial application *)
+let x = new c ~b:pos_b ;;
+let y = x ~a:pos_a ;;
+let a, b = (y ())#x ;;
+[%%expect{|
+val x : a:[%src_pos] -> unit -> c = <fun>
+val y : unit -> c = <fun>
+val a : lexing_position =
+  {pos_fname = "a"; pos_lnum = 0; pos_bol = 0; pos_cnum = -1}
+val b : lexing_position =
+  {pos_fname = "b"; pos_lnum = 0; pos_bol = 0; pos_cnum = -1}
+|}]
+
+(* Labels on source positions can't commute in class definitions *)
+class m : a:[%src_pos] -> b:[%src_pos] -> unit -> object end =
+  fun ~(b:[%src_pos]) ~(a:[%src_pos]) () -> object end
+[%%expect{|
+Line 2, characters 6-54:
+2 |   fun ~(b:[%src_pos]) ~(a:[%src_pos]) () -> object end
+          ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: The class type b:[%src_pos] -> a:[%src_pos] -> unit -> object  end
+       is not matched by the class type
+         a:[%src_pos] -> b:[%src_pos] -> unit -> object  end
+|}]
+
+(* [%src_pos] is distinct from lexing_position *)
+class c :
+  a:lexing_position -> b:[%src_pos] -> unit -> object
+    method x : lexing_position * lexing_position
+  end = fun ~(a : [%src_pos]) ~b () -> object
+    method x = a, b
+  end
+[%%expect{|
+Lines 4-6, characters 12-5:
+4 | ............~(a : [%src_pos]) ~b () -> object
+5 |     method x = a, b
+6 |   end
+Error: The class type
+         a:[%src_pos] -> b:'b -> unit -> object method x : 'a * 'b end
+       is not matched by the class type
+         a:lexing_position ->
+         b:[%src_pos] ->
+         unit -> object method x : lexing_position * lexing_position end
+|}]
+

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

@@ -91,3 +91,42 @@ Error: The function applied to this argument has type
          src_pos:[%src_pos] -> lexing_position
 This argument cannot be applied without label
 |}]
+
+class this_class_has_an_unerasable_argument ~(pos : [%src_pos]) = object end
+
+[%%expect{|
+Line 1, characters 46-49:
+1 | class this_class_has_an_unerasable_argument ~(pos : [%src_pos]) = object end
+                                                  ^^^
+Warning 188 [unerasable-position-argument]: this position argument cannot be erased.
+
+class this_class_has_an_unerasable_argument : pos:[%src_pos] -> object  end
+|}]
+
+class c = object 
+  method this_method_has_an_unerasable_argument ~(pos : [%src_pos]) = pos
+end
+[%%expect{|
+Line 2, characters 50-53:
+2 |   method this_method_has_an_unerasable_argument ~(pos : [%src_pos]) = pos
+                                                      ^^^
+Warning 188 [unerasable-position-argument]: this position argument cannot be erased.
+
+class c :
+  object
+    method this_method_has_an_unerasable_argument :
+      pos:[%src_pos] -> lexing_position
+  end
+|}]
+
+let this_object_has_an_unerasable_argument ~(pos : [%src_pos]) = object end
+
+[%%expect{|
+Line 1, characters 45-48:
+1 | let this_object_has_an_unerasable_argument ~(pos : [%src_pos]) = object end
+                                                 ^^^
+Warning 188 [unerasable-position-argument]: this position argument cannot be erased.
+
+val this_object_has_an_unerasable_argument : pos:[%src_pos] -> <  > = <fun>
+|}]
+

ocaml/testsuite/tests/typing-implicit-source-positions/object_system.ml

@@ -0,0 +1,221 @@
+(* TEST
+   * expect
+*)
+
+let object_with_a_method_with_a_positional_parameter = object 
+  method m ~(src_pos : [%src_pos]) () = src_pos
+end
+
+[%%expect{|
+val object_with_a_method_with_a_positional_parameter :
+  < m : src_pos:[%src_pos] -> unit -> lexing_position > = <obj>
+|}]
+
+let position = object_with_a_method_with_a_positional_parameter#m ();;
+
+[%%expect{|
+val position : lexing_position =
+  {pos_fname = ""; pos_lnum = 1; pos_bol = 276; pos_cnum = 291}
+|}]
+
+class class_with_a_method_with_a_positional_parameter = object 
+  method m ~(src_pos : [%src_pos]) () = src_pos
+end
+
+[%%expect{|
+class class_with_a_method_with_a_positional_parameter :
+  object method m : src_pos:[%src_pos] -> unit -> lexing_position end
+|}]
+
+let o = new class_with_a_method_with_a_positional_parameter;;
+
+[%%expect{|
+val o : class_with_a_method_with_a_positional_parameter = <obj>
+|}]
+
+let position = o#m ();;
+
+[%%expect{|
+val position : lexing_position =
+  {pos_fname = ""; pos_lnum = 1; pos_bol = 866; pos_cnum = 881}
+|}]
+
+let position = (new class_with_a_method_with_a_positional_parameter)#m ();;
+
+[%%expect{|
+val position : lexing_position =
+  {pos_fname = ""; pos_lnum = 1; pos_bol = 1005; pos_cnum = 1020}
+|}]
+
+
+class class_with_positional_parameter ~(src_pos : [%src_pos]) () = object 
+  method src_pos = src_pos
+end
+
+[%%expect{|
+class class_with_positional_parameter :
+  src_pos:[%src_pos] -> unit -> object method src_pos : lexing_position end
+|}]
+
+let o = new class_with_positional_parameter ()
+let position = o#src_pos
+
+[%%expect{|
+val o : class_with_positional_parameter = <obj>
+val position : lexing_position =
+  {pos_fname = ""; pos_lnum = 1; pos_bol = 1439; pos_cnum = 1447}
+|}]
+
+
+(* Different kinds of shadowed parameters (both a class parameter is shadowed and a
+   method parameter is shadowed) *)
+
+class c ~(src_pos : [%src_pos]) () = object(self)
+  method from_class_param = src_pos
+
+  method m ~(src_pos : [%src_pos]) () = src_pos, self#from_class_param
+end
+[%%expect{|
+class c :
+  src_pos:[%src_pos] ->
+  unit ->
+  object
+    method from_class_param : lexing_position
+    method m :
+      src_pos:[%src_pos] -> unit -> lexing_position * lexing_position
+  end
+|}]
+
+let c = (new c ())
+let from_method_param, from_class_param = c#m()
+
+[%%expect{|
+val c : c = <obj>
+val from_method_param : lexing_position =
+  {pos_fname = ""; pos_lnum = 2; pos_bol = 2186; pos_cnum = 2228}
+val from_class_param : lexing_position =
+  {pos_fname = ""; pos_lnum = 1; pos_bol = 2167; pos_cnum = 2175}
+|}]
+
+class parent ~(src_pos : [%src_pos]) () = object
+  method pos = src_pos
+end
+
+let o = object 
+  inherit parent ()
+end
+let position = o#pos
+
+[%%expect{|
+class parent :
+  src_pos:[%src_pos] -> unit -> object method pos : lexing_position end
+val o : parent = <obj>
+val position : lexing_position =
+  {pos_fname = ""; pos_lnum = 6; pos_bol = 2578; pos_cnum = 2588}
+|}]
+
+let o ~(src_pos : [%src_pos]) () = object 
+  inherit parent ~src_pos ()
+end
+let position = (o ())#pos
+
+[%%expect{|
+val o : src_pos:[%src_pos] -> unit -> parent = <fun>
+val position : lexing_position =
+  {pos_fname = ""; pos_lnum = 4; pos_bol = 2926; pos_cnum = 2941}
+|}]
+
+(* Applying an src_pos argument without a label. *)
+let o ~(src_pos : [%src_pos]) () = object 
+  inherit parent src_pos ()
+end
+let position = (o ())#pos
+
+[%%expect{|
+Line 2, characters 10-16:
+2 |   inherit parent src_pos ()
+              ^^^^^^
+Warning 6 [labels-omitted]: label src_pos was omitted in the application of this function.
+
+val o : src_pos:[%src_pos] -> unit -> parent = <fun>
+val position : lexing_position =
+  {pos_fname = ""; pos_lnum = 4; pos_bol = 3249; pos_cnum = 3264}
+|}]
+
+
+(* Same behavior as optional parameters. *)
+class parent ?(i = 1) () = object
+  method i = i
+end
+
+let o = object 
+  inherit parent ()
+end
+let position = o#i
+
+[%%expect{|
+class parent : ?i:int -> unit -> object method i : int end
+val o : parent = <obj>
+val position : int = 1
+|}]
+
+(* Partially applying a class *)
+class c ~(a : [%src_pos]) ~(b : [%src_pos]) () =
+  object 
+    method a = a
+    method b = b
+  end
+
+[%%expect{|
+class c :
+  a:[%src_pos] ->
+  b:[%src_pos] ->
+  unit -> object method a : lexing_position method b : lexing_position end
+|}]
+
+let pos_a : lexing_position = {Lexing.dummy_pos with pos_fname = "a"};;
+let partially_applied_class = new c ~a:pos_a
+
+[%%expect{|
+val pos_a : lexing_position =
+  {pos_fname = "a"; pos_lnum = 0; pos_bol = 0; pos_cnum = -1}
+val partially_applied_class : b:[%src_pos] -> unit -> c = <fun>
+|}]
+
+let fully_applied_class = partially_applied_class ()
+
+[%%expect{|
+val fully_applied_class : c = <obj>
+|}]
+
+let a, b = fully_applied_class#a, fully_applied_class#b
+
+[%%expect{|
+val a : lexing_position =
+  {pos_fname = "a"; pos_lnum = 0; pos_bol = 0; pos_cnum = -1}
+val b : lexing_position =
+  {pos_fname = ""; pos_lnum = 1; pos_bol = 4459; pos_cnum = 4485}
+|}]
+
+class c :
+  x:[%src_pos] -> y:lexing_position -> unit -> object
+    method xy : lexing_position * lexing_position
+  end = fun ~(x : [%src_pos]) ~y () -> object
+    method xy = x, y
+  end
+
+[%%expect{|
+class c :
+  x:[%src_pos] ->
+  y:lexing_position ->
+  unit -> object method xy : lexing_position * lexing_position end
+|}]
+
+let x, y = (new c ~y:pos_a ())#xy
+
+[%%expect{|
+val x : lexing_position =
+  {pos_fname = ""; pos_lnum = 1; pos_bol = 5143; pos_cnum = 5154}
+val y : lexing_position =
+  {pos_fname = "a"; pos_lnum = 0; pos_bol = 0; pos_cnum = -1}
+|}]

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

@@ -30,3 +30,31 @@ let _ = h 5;;
 [%%expect {|
 - : lexing_position = 5
 |}]
+
+(* Works with class parameters *)
+class c ~(src_pos : [%src_pos]) () = object end
+
+[%%expect {|
+class c : src_pos:[%src_pos] -> unit -> object  end
+|}]
+
+let _ = new c ~src_pos:Lexing.dummy_pos ();;
+
+[%%expect{|
+- : c = <obj>
+|}]
+
+(* Works with object method parameters *)
+let o = object
+   method m ~(src_pos : [%src_pos]) () = ()
+end
+
+[%%expect {|
+val o : < m : src_pos:[%src_pos] -> unit -> unit > = <obj>
+|}]
+
+let _ = o#m ~src_pos:Lexing.dummy_pos ()
+
+[%%expect{|
+- : unit = ()
+|}]