PoC %typeof

compiler/ml/typetexp.ml

@@ -206,14 +206,16 @@ let create_package_mty fake loc env (p, l) =
 (* Translation of type expressions *)
 
 let type_variables = ref (Tbl.empty : (string, type_expr) Tbl.t)
+let type_param_names = ref ([] : string list)
 let univars = ref ([] : (string * type_expr) list)
 let pre_univars = ref ([] : type_expr list)
 let used_variables = ref (Tbl.empty : (string, type_expr * Location.t) Tbl.t)
 
 let reset_type_variables () =
   reset_global_level ();
   Ctype.reset_reified_var_counter ();
-  type_variables := Tbl.empty
+  type_variables := Tbl.empty;
+  type_param_names := []
 
 let narrow () = (increase_global_level (), !type_variables)
 
@@ -252,6 +254,7 @@ let transl_type_param env styp =
       with Not_found ->
         let v = new_global_var ~name () in
         type_variables := Tbl.add name v !type_variables;
+        type_param_names := !type_param_names @ [name];
         v
     in
     {
@@ -565,8 +568,133 @@ and transl_type_aux env policy styp =
            pack_txt = p;
          })
       ty
-  | Ptyp_extension ext ->
-    raise (Error_forward (Builtin_attributes.error_of_extension ext))
+  | Ptyp_extension ext -> (
+    match ext with
+    | {txt = "typeof"; loc = ext_loc}, payload -> (
+      (* %typeof payload must be a single identifier *)
+      match Ast_payload.as_ident payload with
+      | Some ({txt = lid; loc = lid_loc} as _ident) ->
+        (* Lookup the value and embed its (generalized) type.
+           Important: avoid manufacturing polymorphism from a monomorphic
+           (weak) type, which would violate the value restriction. We only
+           allow %typeof on values whose type is a closed type scheme. *)
+        let _path, desc = find_value env lid_loc lid in
+        let ty0 = desc.val_type in
+        let () =
+          if not (Ctype.closed_schema env ty0) then
+            let msg =
+              "Cannot use %typeof on this value, because its type is not fully \
+               known yet.\n\n"
+              ^ "%typeof needs a value whose type is completely determined at \
+                 this point.\n"
+              ^ "For example, [] or ref([]) don't say what element type they \
+                 hold yet.\n\n" ^ "How to fix:\n"
+              ^ "- Add a type annotation to the value (e.g. let u: array<int> \
+                 = [];).\n"
+              ^ "- Or define the value in a way that makes its type known \
+                 immediately.\n\n"
+              ^ "Note: This is related to the value restriction \
+                 (non-generalizable type variables)."
+            in
+            raise (Error_forward (Location.error ~loc:ext_loc msg))
+        in
+        (match !type_param_names with
+        | [] -> ()
+        | lhs_params ->
+          let rhs_vars = Ctype.free_variables ty0 in
+          let rhs_names_opt =
+            List.map
+              (fun v ->
+                match (Ctype.repr v).desc with
+                | Tvar (Some n) | Tunivar (Some n) -> Some n
+                | _ -> None)
+              rhs_vars
+          in
+          let mk_params_string names =
+            match names with
+            | [] -> "< >"
+            | _ ->
+              let parts = List.map (fun n -> "'" ^ n) names in
+              Printf.sprintf "<%s>" (String.concat ", " parts)
+          in
+          let error msg =
+            raise (Error_forward (Location.error ~loc:ext_loc msg))
+          in
+          if List.mem None rhs_names_opt then
+            error
+              "This %typeof(...) expression refers to a polymorphic value \
+               whose type variables have no names.\n\
+               Name the type variables in the value's type annotation (e.g. \
+               promise<'response>), and use the same names here in the type \
+               definition.";
+          let rhs_named =
+            List.filter_map
+              (fun v ->
+                match (Ctype.repr v).desc with
+                | Tvar (Some n) | Tunivar (Some n) -> Some (n, v)
+                | _ -> None)
+              rhs_vars
+          in
+          let rhs_names = List.map fst rhs_named in
+          let module S = Set.Make (String) in
+          let s_lhs =
+            List.fold_left (fun s x -> S.add x s) S.empty lhs_params
+          in
+          let s_rhs = List.fold_left (fun s x -> S.add x s) S.empty rhs_names in
+          (if not (S.equal s_lhs s_rhs) then
+             let missing = S.elements (S.diff s_rhs s_lhs) in
+             let extra = S.elements (S.diff s_lhs s_rhs) in
+             let parts =
+               ( [] |> fun acc ->
+                 if missing <> [] then
+                   acc
+                   @ [
+                       Printf.sprintf "Missing on the left: %s"
+                         (mk_params_string missing);
+                     ]
+                 else acc )
+               |> fun acc ->
+               if extra <> [] then
+                 acc
+                 @ [
+                     Printf.sprintf "Remove from the left: %s"
+                       (mk_params_string extra);
+                   ]
+               else acc
+             in
+             let header =
+               Printf.sprintf
+                 "This identifier `%s` has type variables %s, but your type \
+                  parameters are %s."
+                 (Longident.last lid)
+                 (mk_params_string rhs_names)
+                 (mk_params_string lhs_params)
+             in
+             error
+               (if parts = [] then header
+                else header ^ "\n\n" ^ String.concat "\n" parts));
+          (* Tie variables: unify each LHS param with the corresponding RHS var by name.
+             %typeof reuses the value's scheme whose vars are distinct; tying
+             ensures the alias shares those vars (passes closedness, keeps names). *)
+          List.iter
+            (fun lhs_name ->
+              let lhs_param = Tbl.find lhs_name !type_variables in
+              let rhs_var = List.assoc lhs_name rhs_named in
+              Ctype.unify_var env lhs_param rhs_var)
+            lhs_params);
+        (* Preserve type variable names so that typedecl can enforce exact
+           name/order mapping against LHS parameters. Since we already ensured
+           the scheme is closed, we can reuse the original scheme here. *)
+        let ty = ty0 in
+        (* Build a core_type node carrying the looked up type; we mark the
+           desc as any since downstream only consults ctyp_type for typing. *)
+        ctyp Ttyp_any ty
+      | None ->
+        let msg =
+          "%%typeof expects an identifier. Example: type t = %typeof(x)"
+        in
+        raise (Error_forward (Location.error ~loc:ext_loc msg)))
+    | _ -> raise (Error_forward (Builtin_attributes.error_of_extension ext)))
 
 and transl_poly_type env policy t =
   transl_type env policy (Ast_helper.Typ.force_poly t)

tests/analysis_tests/tests/src/Hover.res

@@ -281,3 +281,13 @@ module Arr = Belt.Array
 
 type aliased = variant
 //    ^hov
+
+let myFn = (a, b) => a ++ b->Int.toString
+
+type fnType = %typeof(myFn)
+//    ^hov
+
+let myFnPartial = myFn("hello", ...)
+
+type fnTypePartial = %typeof(myFnPartial)
+//    ^hov

tests/analysis_tests/tests/src/expected/Hover.res.txt

@@ -348,3 +348,9 @@ Hover src/Hover.res 278:8
 Hover src/Hover.res 281:6
 {"contents": {"kind": "markdown", "value": "```rescript\ntype aliased = variant\n```\n\n---\n\n```\n \n```\n```rescript\ntype variant = CoolVariant | OtherCoolVariant\n```\nGo to: [Type definition](command:rescript-vscode.go_to_location?%5B%22Hover.res%22%2C251%2C0%5D)\n"}}
 
+Hover src/Hover.res 286:6
+{"contents": {"kind": "markdown", "value": "```rescript\ntype fnType = (string, int) => string\n```"}}
+
+Hover src/Hover.res 291:6
+{"contents": {"kind": "markdown", "value": "```rescript\ntype fnTypePartial = int => string\n```"}}
+

tests/build_tests/super_errors/expected/typeof_mismatch.res.expected

@@ -0,0 +1,13 @@
+
+  We've found a bug for you!
+  /.../fixtures/typeof_mismatch.res:6:28
+
+  4 │ 
+  5 │ let f: fnType = myFn
+  6 │ let ff: fnType = (a, b) => a->Int.toString + b
+  7 │ 
+
+  This has type: string
+  But this function argument is expecting: int
+
+  You can convert string to int with Int.fromString.

tests/build_tests/super_errors/expected/typeof_non_generalized.res.expected

@@ -0,0 +1,19 @@
+
+  We've found a bug for you!
+  /.../fixtures/typeof_non_generalized.res:3:10-16
+
+  1 │ let u = []
+  2 │ 
+  3 │ type t = %typeof(u)
+  4 │ 
+
+  Cannot use %typeof on this value, because its type is not fully known yet.
+
+%typeof needs a value whose type is completely determined at this point.
+For example, [] or ref([]) don't say what element type they hold yet.
+
+How to fix:
+- Add a type annotation to the value (e.g. let u: array<int> = [];).
+- Or define the value in a way that makes its type known immediately.
+
+Note: This is related to the value restriction (non-generalizable type variables).

tests/build_tests/super_errors/expected/typeof_non_ident.res.expected

@@ -0,0 +1,8 @@
+
+  We've found a bug for you!
+  /.../fixtures/typeof_non_ident.res:1:10-16
+
+  1 │ type t = %typeof(1 + 2)
+  2 │ 
+
+  %%typeof expects an identifier. Example: type t = %typeof(x)

tests/build_tests/super_errors/expected/typeof_param_count_mismatch.res.expected

@@ -0,0 +1,12 @@
+
+  We've found a bug for you!
+  /.../fixtures/typeof_param_count_mismatch.res:3:29-35
+
+  1 │ external fetch: string => promise<'response> = "fetch"
+  2 │ 
+  3 │ type fetch<'response, 'x> = %typeof(fetch)
+  4 │ 
+
+  This identifier `fetch` has type variables <'response>, but your type parameters are <'response, 'x>.
+
+Remove from the left: <'x>

tests/build_tests/super_errors/expected/typeof_param_name_mismatch.res.expected

@@ -0,0 +1,13 @@
+
+  We've found a bug for you!
+  /.../fixtures/typeof_param_name_mismatch.res:3:21-27
+
+  1 │ external fetch: string => promise<'response> = "fetch"
+  2 │ 
+  3 │ type fetch<'resp> = %typeof(fetch)
+  4 │ 
+
+  This identifier `fetch` has type variables <'response>, but your type parameters are <'resp>.
+
+Missing on the left: <'response>
+Remove from the left: <'resp>

tests/build_tests/super_errors/fixtures/typeof_mismatch.res

@@ -0,0 +1,6 @@
+let myFn = (a, b) => a ++ b->Int.toString
+
+type fnType = %typeof(myFn)
+
+let f: fnType = myFn
+let ff: fnType = (a, b) => a->Int.toString + b

tests/build_tests/super_errors/fixtures/typeof_non_generalized.res

@@ -0,0 +1,3 @@
+let u = []
+
+type t = %typeof(u)

tests/build_tests/super_errors/fixtures/typeof_non_ident.res

@@ -0,0 +1 @@
+type t = %typeof(1 + 2)

tests/build_tests/super_errors/fixtures/typeof_param_count_mismatch.res

@@ -0,0 +1,3 @@
+external fetch: string => promise<'response> = "fetch"
+
+type fetch<'response, 'x> = %typeof(fetch)

tests/build_tests/super_errors/fixtures/typeof_param_name_mismatch.res

@@ -0,0 +1,3 @@
+external fetch: string => promise<'response> = "fetch"
+
+type fetch<'resp> = %typeof(fetch)

tests/tests/src/Typeof.mjs

@@ -0,0 +1,14 @@
+// Generated by ReScript, PLEASE EDIT WITH CARE
+
+
+function myFn(a, b) {
+  return a + b.toString();
+}
+
+let f = myFn;
+
+export {
+  myFn,
+  f,
+}
+/* No side effect */

tests/tests/src/Typeof.res

@@ -0,0 +1,9 @@
+let myFn = (a, b) => a ++ b->Int.toString
+
+type fnType = %typeof(myFn)
+
+let f: fnType = myFn
+
+external fetch: string => promise<'response> = "fetch"
+
+type fetch<'response> = %typeof(fetch)