Striate jkind annotations from attributes

ocaml/parsing/builtin_attributes.ml

@@ -452,15 +452,15 @@ let warn_on_literal_pattern attrs =
 let explicit_arity attrs =
   has_attribute ["ocaml.explicit_arity"; "explicit_arity"] attrs
 
-type jkind_annotation =
+type jkind_attribute =
   | Any
   | Value
   | Void
   | Immediate64
   | Immediate
   | Float64
 
-let jkind_of_string = function
+let jkind_attribute_of_string = function
   | "ocaml.any" | "any" -> Some Any
   | "ocaml.value" | "value" -> Some Value
   | "ocaml.void" | "void" -> Some Void
@@ -469,25 +469,19 @@ let jkind_of_string = function
   | "ocaml.float64" | "float64" -> Some Float64
   | _ -> None
 
-let jkind_to_string = function
+let jkind_attribute_to_string = function
   | Any -> "any"
   | Value -> "value"
   | Void -> "void"
   | Immediate64 -> "immediate64"
   | Immediate -> "immediate"
   | Float64 -> "float64"
 
-let jkind_of_parsetree x =
-  jkind_of_string (Jane_asttypes.jkind_to_string x)
-
-let jkind_to_parsetree x =
-  Jane_asttypes.jkind_of_string (jkind_to_string x)
-
 let jkind ~legacy_immediate attrs =
   let jkind =
     List.find_map
       (fun a ->
-         match jkind_of_string a.attr_name.txt with
+         match jkind_attribute_of_string a.attr_name.txt with
          | Some attr -> Some (a, attr)
          | None -> None
       ) attrs

ocaml/parsing/builtin_attributes.mli

@@ -175,16 +175,15 @@ val has_unique: Parsetree.attributes -> (bool,unit) result
 
 val has_once : Parsetree.attributes -> (bool, unit) result
 
-type jkind_annotation =
+type jkind_attribute =
   | Any
   | Value
   | Void
   | Immediate64
   | Immediate
   | Float64
 
-val jkind_of_parsetree : Jane_asttypes.const_jkind -> jkind_annotation option
-val jkind_to_parsetree : jkind_annotation -> Jane_asttypes.const_jkind
+val jkind_attribute_to_string : jkind_attribute -> string
 
 (* [jkind] gets the jkind in the attributes if one is present.  We always
    allow the [value] annotation, even if the layouts extensions are disabled.
@@ -218,4 +217,4 @@ val jkind_to_parsetree : jkind_annotation -> Jane_asttypes.const_jkind
 (* CR layouts: we should eventually be able to delete ~legacy_immediate (after we
    turn on layouts by default). *)
 val jkind : legacy_immediate:bool -> Parsetree.attributes ->
-  (jkind_annotation Location.loc option, jkind_annotation Location.loc) result
+  (jkind_attribute Location.loc option, jkind_attribute Location.loc) result

ocaml/typing/jkind.ml

@@ -438,22 +438,43 @@ module Const : sig
     | Immediate
     | Float64
 
-  val to_user_written_attribute : t -> Builtin_attributes.jkind_annotation
-
   val of_user_written_attribute_unchecked :
-    Builtin_attributes.jkind_annotation -> t
+    Builtin_attributes.jkind_attribute -> t
+
+  val of_user_written_annotation_unchecked :
+    Jane_asttypes.const_jkind -> t option
+
+  val to_user_written_annotation : t -> Jane_asttypes.const_jkind
 end = struct
-  type t = Builtin_attributes.jkind_annotation =
+  type t = Builtin_attributes.jkind_attribute =
     | Any
     | Value
     | Void
     | Immediate64
     | Immediate
     | Float64
 
-  let of_user_written_attribute_unchecked x = x
-
-  let to_user_written_attribute x = x
+  let of_user_written_attribute_unchecked t = t
+
+  let of_user_written_annotation_unchecked annot =
+    match Jane_asttypes.jkind_to_string annot with
+    | "any" -> Some Any
+    | "value" -> Some Value
+    | "void" -> Some Void
+    | "immediate64" -> Some Immediate64
+    | "immediate" -> Some Immediate
+    | "float64" -> Some Float64
+    | _ -> None
+
+  let to_user_written_annotation annot =
+    Jane_asttypes.jkind_of_string
+      (match annot with
+      | Any -> "any"
+      | Value -> "value"
+      | Void -> "void"
+      | Immediate64 -> "immediate64"
+      | Immediate -> "immediate"
+      | Float64 -> "float64")
 end
 
 type const = Const.t =
@@ -528,43 +549,37 @@ let of_const ~why : const -> t = function
   | Void -> fresh_jkind (Sort Sort.void) ~why
   | Float64 -> fresh_jkind (Sort Sort.float64) ~why
 
-let const_of_user_written_attribute ?(legacy_immediate = false) ~context
-    Location.{ loc; txt = (annot : Builtin_attributes.jkind_annotation) } =
-  (* This is *the* place that does checks on the
-     Builtin_attributes.jkind_annotation, so it's fine to do this "unchecked"
-     conversion.
-  *)
-  match Const.of_user_written_attribute_unchecked annot with
+let check_user_written_annotation ?(legacy_immediate = false) ~context ~loc
+    annot =
+  match annot with
   | (Immediate | Immediate64 | Value) as const when legacy_immediate -> const
   | const ->
     let required_layouts_level = get_required_layouts_level context const in
     if not (Language_extension.is_at_least Layouts required_layouts_level)
     then raise ~loc (Insufficient_level (context, const));
     const
 
-let const_loc_of_user_written_attribute ?legacy_immediate ~context attribute =
-  let const =
-    const_of_user_written_attribute ?legacy_immediate ~context attribute
-  in
-  Location.{ txt = const; loc = attribute.loc }
-
 let const_of_user_written_annotation ?legacy_immediate ~context
     Location.{ loc; txt = annot } =
-  match Builtin_attributes.jkind_of_parsetree annot with
+  match Const.of_user_written_annotation_unchecked annot with
   | None -> raise ~loc (Unknown_jkind annot)
-  | Some attribute ->
-    const_of_user_written_attribute ?legacy_immediate ~context
-      { txt = attribute; loc }
+  | Some unchecked ->
+    check_user_written_annotation ?legacy_immediate ~context ~loc unchecked
 
-let const_to_user_written_annotation annot =
-  (* CR nroberts: a bit of a lie *)
-  Builtin_attributes.jkind_to_parsetree (Const.to_user_written_attribute annot)
+let const_to_user_written_annotation = Const.to_user_written_annotation
+
+let const_of_user_written_attribute ?legacy_immediate ~context
+    Location.{ loc; txt = attribute } =
+  let unchecked = Const.of_user_written_attribute_unchecked attribute in
+  let checked =
+    check_user_written_annotation ?legacy_immediate ~context ~loc unchecked
+  in
+  Location.{ loc; txt = checked }
 
 let const_of_attributes ~legacy_immediate ~context attrs =
   Builtin_attributes.jkind ~legacy_immediate attrs
   |> Result.map
-       (Option.map
-          (const_loc_of_user_written_attribute ~legacy_immediate ~context))
+       (Option.map (const_of_user_written_attribute ~legacy_immediate ~context))
 
 let of_annotated_const ~context Location.{ txt = const; loc = const_loc } =
   of_const ~why:(Annotated (context, const_loc)) const

ocaml/typing/jkind.mli

@@ -401,7 +401,7 @@ val of_attributes :
   legacy_immediate:bool ->
   context:annotation_context ->
   Parsetree.attributes ->
-  (t option, Builtin_attributes.jkind_annotation Location.loc) result
+  (t option, Builtin_attributes.jkind_attribute Location.loc) result
 
 (** Find a jkind in attributes, defaulting to ~default.  Returns error if a
     disallowed jkind is present, but always allows immediate if
@@ -411,7 +411,7 @@ val of_attributes_default :
   context:annotation_context ->
   default:t ->
   Parsetree.attributes ->
-  (t, Builtin_attributes.jkind_annotation Location.loc) result
+  (t, Builtin_attributes.jkind_attribute Location.loc) result
 
 (** Choose an appropriate jkind for a boxed record type, given whether
     all of its fields are [void]. *)

ocaml/typing/printtyp.ml

@@ -1646,8 +1646,8 @@ let rec tree_of_type_decl id decl =
        begin match
          Builtin_attributes.jkind ~legacy_immediate:true decl.type_attributes
        with
-       | Ok annot -> annot
-       | Error annot -> Some annot  (* don't care here about extensions *)
+       | Ok attr -> attr
+       | Error attr -> Some attr  (* don't care here about extensions *)
        end
     | _ -> None (* other cases have no jkind annotation *)
   in
@@ -1657,7 +1657,15 @@ let rec tree_of_type_decl id decl =
       otype_private = priv;
       otype_jkind =
         Option.map
-          (fun { txt } -> Olay_const (Builtin_attributes.jkind_to_parsetree txt))
+          (fun { txt } ->
+             let jkind_attribute =
+               Builtin_attributes.jkind_attribute_to_string txt
+             in
+             (* CR layouts 1.5: This is a bit of a lie: we're interpreting the
+                jkind attribute as a jkind *annotation*. This will go away in a
+                child PR when we move jkind annotations into Jane Syntax. *)
+             let jkind_annot = Jane_asttypes.jkind_of_string jkind_attribute in
+             Olay_const jkind_annot)
           lay;
       otype_unboxed = unboxed;
       otype_cstrs = constraints }

ocaml/typing/typedecl.ml

@@ -79,7 +79,7 @@ type error =
   | Nonrec_gadt
   | Invalid_private_row_declaration of type_expr
   | Local_not_enabled
-  | Layout_not_enabled of Builtin_attributes.jkind_annotation
+  | Layout_not_enabled of Builtin_attributes.jkind_attribute
 
 open Typedtree
 
@@ -2661,10 +2661,9 @@ let report_error ppf = function
                    To enable it, pass the '-extension local' flag@]"
   | Layout_not_enabled c ->
       fprintf ppf
-        "@[Layout %a is used here, but the appropriate layouts extension is \
+        "@[Layout %s is used here, but the appropriate layouts extension is \
          not enabled@]"
-        Jane_syntax.Layouts.Pprint.const_jkind
-        (Builtin_attributes.jkind_to_parsetree c)
+        (Builtin_attributes.jkind_attribute_to_string c)
 
 let () =
   Location.register_error_of_exn

ocaml/typing/typedecl.mli

@@ -117,7 +117,7 @@ type error =
   | Nonrec_gadt
   | Invalid_private_row_declaration of type_expr
   | Local_not_enabled
-  | Layout_not_enabled of Builtin_attributes.jkind_annotation
+  | Layout_not_enabled of Builtin_attributes.jkind_attribute
 
 exception Error of Location.t * error
 

ocaml/typing/typetexp.ml

@@ -243,8 +243,7 @@ end = struct
       f
       ~finally:(fun () -> univars := old_univars)
 
-  let ttyp_poly_arg (poly_univars : poly_univars) =
-    List.map
+  let ttyp_poly_arg (poly_univars : poly_univars) = List.map
       (fun (name, _, jkind_info) -> name, jkind_info.jkind_annot)
       poly_univars
 

ocaml/typing/typetexp.mli

@@ -52,8 +52,7 @@ module TyVarEnv : sig
        type scheme (i.e. variables become Tvar rather than Tunivar) *)
 
   val ttyp_poly_arg : poly_univars -> (string * Jkind.const option) list
-  (* CR nroberts: document more *)
-  (* something suitable as an argument to [Ttyp_poly] *)
+    (** A suitable arg to the corresponding [Ttyp_poly] type. *)
 end
 
 val valid_tyvar_name : string -> bool