outcometree: print [@unboxed] attributes

Author: gasche

testsuite/tests/tool-toplevel/printval.ml

@@ -68,7 +68,11 @@ type t =
   | Proxy of t
 ;;
 [%%expect {|
-type t = Int of int | Str of string | Pair of t * t | Proxy of t
+type t =
+    Int of int [@unboxed]
+  | Str of string [@unboxed]
+  | Pair of t * t
+  | Proxy of t
 |}];;
 
 Int 42;;

typing/oprint.ml

@@ -502,6 +502,7 @@ let constructor_of_extension_constructor
     name = ext.oext_name;
     args = ext.oext_args;
     return_type = ext.oext_ret_type;
+    unboxed = false;
   }
 
 let split_anon_functor_arguments params =
@@ -712,29 +713,37 @@ and print_out_type_decl kwd ppf td =
     print_unboxed
 
 and print_out_constr ppf constr =
-  let { name; args = tyl; return_type } = constr in
+  let { name; args = tyl; return_type; unboxed } = constr in
   let name =
     match name with
     | "::" -> "(::)"   (* #7200 *)
     | s -> s
   in
+  let pp_unboxed ppf = function
+    | false -> ()
+    | true -> fprintf ppf "@ [@unboxed]"
+  in
   match return_type with
   | None ->
       begin match tyl with
       | [] ->
           pp_print_string ppf name
       | _ ->
-          fprintf ppf "@[<2>%s of@ %a@]" name
+          fprintf ppf "@[<2>%s of@ %a%a@]" name
             (print_typlist print_simple_out_type " *") tyl
+            pp_unboxed unboxed
       end
   | Some ret_type ->
       begin match tyl with
       | [] ->
-          fprintf ppf "@[<2>%s :@ %a@]" name print_simple_out_type  ret_type
+          fprintf ppf "@[<2>%s :@ %a%a@]" name
+            print_simple_out_type ret_type
+            pp_unboxed unboxed
       | _ ->
-          fprintf ppf "@[<2>%s :@ %a -> %a@]" name
+          fprintf ppf "@[<2>%s :@ %a -> %a%a@]" name
             (print_typlist print_simple_out_type " *")
             tyl print_simple_out_type ret_type
+            pp_unboxed unboxed
       end
 
 and print_out_extension_constructor ppf ext =

typing/outcometree.mli

@@ -82,6 +82,7 @@ and out_constructor = {
   name: string;
   args: out_type list;
   return_type: out_type option;
+  unboxed: bool;
 }
 
 and out_variant =

typing/printtyp.ml

@@ -1420,13 +1420,14 @@ and tree_of_constructor_arguments = function
 and tree_of_constructor cd =
   let name = Ident.name cd.cd_id in
   let arg () = tree_of_constructor_arguments cd.cd_args in
+  let unboxed = Builtin_attributes.has_unboxed cd.cd_attributes in
   match cd.cd_res with
-  | None -> { name; args = arg (); return_type = None }
+  | None -> { name; args = arg (); return_type = None; unboxed; }
   | Some res ->
       Names.with_local_names (fun () ->
         let ret = tree_of_typexp Type res in
         let args = arg () in
-        { name; args; return_type = Some ret })
+        { name; args; return_type = Some ret; unboxed; })
 
 and tree_of_label l =
   (Ident.name l.ld_id, l.ld_mutable = Mutable, tree_of_typexp Type l.ld_type)
@@ -1516,6 +1517,7 @@ let extension_only_constructor id ppf ext =
       name;
       args;
       return_type = ret;
+      unboxed = false;
     } : out_constructor)
 
 (* Print a value declaration *)