Merge pull request #80 from hackwaly/ocaml-5.4

Add OCaml 5.4 support

Author: sim642

.github/workflows/ci.yml

@@ -21,6 +21,7 @@ jobs:
           - ubuntu-latest
           - macos-latest
         ocaml-compiler:
+          - ocaml-base-compiler.5.4.0~beta2
           - 5.3.x
           - 5.2.x
           - 5.1.x

CHANGELOG.md

@@ -1,3 +1,9 @@
+## 1.3.4 - 2025-09-20
+
+### Added
+
+* Add OCaml 5.4 support (#80).
+
 ## 1.3.3 - 2024-11-10
 
 ### Added

src/debugger/inspect/types.ml

@@ -6,3 +6,11 @@ let commu_ok = Cok
 let row_fields row = row.row_fields
 let row_field_repr = Btype.row_field_repr
 [%%endif]
+
+[%%if ocaml_version >= (5, 4, 0)]
+type constructor_tag = Data_types.constructor_tag =
+  | Cstr_constant of int
+  | Cstr_block of int
+  | Cstr_unboxed
+  | Cstr_extension of Path.t * bool
+[%%endif]

src/debugger/inspect/value_module.ml

@@ -78,7 +78,19 @@ let adopter scene typenv obj typ =
         Lwt.return
           (Some (new module_value ~scene ~typenv:typenv' ~obj ~path:(Path.Pident mid) ()))
       with _ -> Lwt.return (Some unknown_module_value) )
-  | Tpackage (path, []) [@if ocaml_version >= (4, 13, 0)] -> (
+  | Tpackage (path, []) [@if ocaml_version >= (4, 13, 0) && ocaml_version < (5, 4, 0)] -> (
+      try
+        let mty = typenv |> Typenv.find_modtype_expansion path in
+        let mid =
+          Ident.create_persistent
+            (Printf.sprintf "M_%04x"
+                (Float.to_int (Sys.time () *. 1e9) mod 0x10000))
+        in
+        let typenv' = typenv |> Typenv.add_module mid Types.Mp_present mty in
+        Lwt.return
+          (Some (new module_value ~scene ~typenv:typenv' ~obj ~path:(Path.Pident mid) ()))
+      with _ -> Lwt.return (Some unknown_module_value) )
+  | Tpackage {pack_path = path; pack_cstrs = []} [@if ocaml_version >= (5, 4, 0)] -> (
       try
         let mty = typenv |> Typenv.find_modtype_expansion path in
         let mid =

src/debugger/inspect/value_struct.ml

@@ -38,6 +38,29 @@ class tuple_value ~scene ~typenv ~obj ?(pos = 0) ?(unboxed = false) ~members ()
       else "(‹1›, ‹2›, …)"
   end
 
+class label_tuple_value ~scene ~typenv ~obj ?(pos = 0) ?(unboxed = false) ~members ()
+  =
+  let member_name i label =
+    match label with
+    | None -> "‹" ^ string_of_int (i + 1) ^ "›"
+    | Some label -> label
+  in
+  let members =
+    members
+    |> List.mapi (fun i (label, typ) -> (member_name i label, typ))
+  in
+  object (self)
+    inherit struct_value ~scene ~typenv ~obj ~pos ~unboxed ~members
+
+    method to_short_string =
+      let num_named = self#num_named in
+      if num_named = 0 then "()"
+      else if num_named = 1 then "‹1›"
+      else if num_named = 2 then "(‹1›, ‹2›)"
+      else if num_named = 3 then "(‹1›, ‹2›, ‹3›)"
+      else "(‹1›, ‹2›, …)"
+  end
+
 class record_value ~scene ~typenv ~obj ?(pos = 0) ?(unboxed = false) ~members ()
   =
   object
@@ -200,8 +223,10 @@ let adopter scene typenv obj typ =
         Lwt.return (Some (new variant_value ~tag ?payload ~embed:true ()))
   in
   match Types.get_desc typ with
-  | Ttuple tys ->
+  | Ttuple tys [@if ocaml_version < (5, 4, 0)] ->
       Lwt.return (Some (new tuple_value ~scene ~typenv ~obj ~members:tys ()))
+  | Ttuple tys [@if ocaml_version >= (5, 4, 0)] ->
+      Lwt.return (Some (new label_tuple_value ~scene ~typenv ~obj ~members:tys ()))
   | Tconstr (path, type_args, _) -> (
       match typenv |> Typenv.find_type path with
       | exception Not_found -> Lwt.return None

src/debugger/misc/util.ml

@@ -29,11 +29,17 @@ module Path = struct
     in
     aux path
 
+  [%%if ocaml_version >= (5, 4, 0)]
+  let lift_longident = Location.mknoloc
+  [%%else]
+  let lift_longident = Fun.id
+  [%%endif]
+
   let rec to_longident path =
     match path with
     | Pident id -> Longident.Lident (Ident.name id)
-    | Pdot (p, d) -> Longident.Ldot (to_longident p, d)
-    | Pextra_ty (p, Pcstr_ty d) [@if ocaml_version >= (5, 1, 0)] -> Longident.Ldot (to_longident p, d)
-    | Papply (p1, p2) -> Longident.Lapply (to_longident p1, to_longident p2)
+    | Pdot (p, d) -> Longident.Ldot (lift_longident (to_longident p), lift_longident d)
+    | Pextra_ty (p, Pcstr_ty d) [@if ocaml_version >= (5, 1, 0)] -> Longident.Ldot (lift_longident (to_longident p), lift_longident d)
+    | Papply (p1, p2) -> Longident.Lapply (lift_longident (to_longident p1), lift_longident (to_longident p2))
     | Pextra_ty (p, Pext_ty) [@if ocaml_version >= (5, 1, 0)] -> to_longident p
 end

src/typenv/types.ml

@@ -0,0 +1,5 @@
+include Ocaml_common.Types
+
+[%%if ocaml_version >= (5, 4, 0)]
+type constructor_description = Data_types.constructor_description
+[%%endif]