OCaml 5.4

mlx.opam

@@ -8,7 +8,7 @@ doc: "https://url/to/documentation"
 bug-reports: "https://github.com/ocaml-mlx/mlx/issues"
 depends: [
   "ocaml" {>= "4.14.0"}
-  "ppxlib" {>= "0.34.0"}
+  "ppxlib" {>= "0.37.0"}
   "dune" {>= "3.16"}
   "menhir" {= "20201216" & with-dev-setup}
   "ocamlformat" {with-dev-setup}

mlx/ast_helper.ml

@@ -33,15 +33,20 @@ let with_default_loc l f =
   Misc.protect_refs [Misc.R (default_loc, l)] f
 
 module Const = struct
-  let integer ?suffix i = Pconst_integer (i, suffix)
-  let int ?suffix i = integer ?suffix (Int.to_string i)
-  let int32 ?(suffix='l') i = integer ~suffix (Int32.to_string i)
-  let int64 ?(suffix='L') i = integer ~suffix (Int64.to_string i)
-  let nativeint ?(suffix='n') i = integer ~suffix (Nativeint.to_string i)
-  let float ?suffix f = Pconst_float (f, suffix)
-  let char c = Pconst_char c
+  let mk ?(loc = !default_loc) d =
+    {pconst_desc = d;
+     pconst_loc = loc}
+
+  let integer ?loc ?suffix i = mk ?loc (Pconst_integer (i, suffix))
+  let int ?loc ?suffix i = integer ?loc ?suffix (Int.to_string i)
+  let int32 ?loc ?(suffix='l') i = integer ?loc ~suffix (Int32.to_string i)
+  let int64 ?loc ?(suffix='L') i = integer ?loc ~suffix (Int64.to_string i)
+  let nativeint ?loc ?(suffix='n') i =
+    integer ?loc ~suffix (Nativeint.to_string i)
+  let float ?loc ?suffix f = mk ?loc (Pconst_float (f, suffix))
+  let char ?loc c = mk ?loc (Pconst_char c)
   let string ?quotation_delimiter ?(loc= !default_loc) s =
-    Pconst_string (s, loc, quotation_delimiter)
+    mk ~loc (Pconst_string (s, loc, quotation_delimiter))
 end
 
 module Attr = struct
@@ -70,8 +75,9 @@ module Typ = struct
   let alias ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_alias (a, b))
   let variant ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_variant (a, b, c))
   let poly ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_poly (a, b))
-  let package ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_package (a, b))
+  let package ?loc ?attrs a = mk ?loc ?attrs (Ptyp_package a)
   let extension ?loc ?attrs a = mk ?loc ?attrs (Ptyp_extension a)
+  let open_ ?loc ?attrs mod_ident t = mk ?loc ?attrs (Ptyp_open (mod_ident, t))
 
   let force_poly t =
     match t.ptyp_desc with
@@ -92,7 +98,8 @@ module Typ = struct
             Ptyp_var x
         | Ptyp_arrow (label,core_type,core_type') ->
             Ptyp_arrow(label, loop core_type, loop core_type')
-        | Ptyp_tuple lst -> Ptyp_tuple (List.map loop lst)
+        | Ptyp_tuple lst ->
+            Ptyp_tuple (List.map (fun (l, t) -> l, loop t) lst)
         | Ptyp_constr( { txt = Longident.Lident s }, [])
           when List.mem s var_names ->
             Ptyp_var s
@@ -102,18 +109,20 @@ module Typ = struct
             Ptyp_object (List.map loop_object_field lst, o)
         | Ptyp_class (longident, lst) ->
             Ptyp_class (longident, List.map loop lst)
-        | Ptyp_alias(core_type, string) ->
-            check_variable var_names t.ptyp_loc string;
-            Ptyp_alias(loop core_type, string)
+        | Ptyp_alias(core_type, alias) ->
+            check_variable var_names alias.loc alias.txt;
+            Ptyp_alias(loop core_type, alias)
         | Ptyp_variant(row_field_list, flag, lbl_lst_option) ->
             Ptyp_variant(List.map loop_row_field row_field_list,
                          flag, lbl_lst_option)
         | Ptyp_poly(string_lst, core_type) ->
           List.iter (fun v ->
             check_variable var_names t.ptyp_loc v.txt) string_lst;
             Ptyp_poly(string_lst, loop core_type)
-        | Ptyp_package(longident,lst) ->
-            Ptyp_package(longident,List.map (fun (n,typ) -> (n,loop typ) ) lst)
+        | Ptyp_package ptyp ->
+            Ptyp_package (loop_package_type ptyp)
+        | Ptyp_open (mod_ident, core_type) ->
+            Ptyp_open (mod_ident, loop core_type)
         | Ptyp_extension (s, arg) ->
             Ptyp_extension (s, arg)
       in
@@ -134,9 +143,17 @@ module Typ = struct
             Oinherit (loop t)
       in
       { field with pof_desc; }
+    and loop_package_type ptyp =
+      { ptyp with
+        ppt_cstrs = List.map (fun (n,typ) -> (n,loop typ) ) ptyp.ppt_cstrs }
     in
     loop t
 
+  let package_type ?(loc = !default_loc) ?(attrs = []) p c =
+    {ppt_loc = loc;
+     ppt_path = p;
+     ppt_cstrs = c;
+     ppt_attrs = attrs}
 end
 
 module Pat = struct
@@ -152,7 +169,7 @@ module Pat = struct
   let alias ?loc ?attrs a b = mk ?loc ?attrs (Ppat_alias (a, b))
   let constant ?loc ?attrs a = mk ?loc ?attrs (Ppat_constant a)
   let interval ?loc ?attrs a b = mk ?loc ?attrs (Ppat_interval (a, b))
-  let tuple ?loc ?attrs a = mk ?loc ?attrs (Ppat_tuple a)
+  let tuple ?loc ?attrs a b = mk ?loc ?attrs (Ppat_tuple (a, b))
   let construct ?loc ?attrs a b = mk ?loc ?attrs (Ppat_construct (a, b))
   let variant ?loc ?attrs a b = mk ?loc ?attrs (Ppat_variant (a, b))
   let record ?loc ?attrs a b = mk ?loc ?attrs (Ppat_record (a, b))
@@ -164,6 +181,7 @@ module Pat = struct
   let unpack ?loc ?attrs a = mk ?loc ?attrs (Ppat_unpack a)
   let open_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_open (a, b))
   let exception_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_exception a)
+  let effect_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_effect(a, b))
   let extension ?loc ?attrs a = mk ?loc ?attrs (Ppat_extension a)
 end
 
@@ -178,8 +196,7 @@ module Exp = struct
   let ident ?loc ?attrs a = mk ?loc ?attrs (Pexp_ident a)
   let constant ?loc ?attrs a = mk ?loc ?attrs (Pexp_constant a)
   let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_let (a, b, c))
-  let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pexp_fun (a, b, c, d))
-  let function_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_function a)
+  let function_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_function (a, b, c))
   let apply ?loc ?attrs a b = mk ?loc ?attrs (Pexp_apply (a, b))
   let match_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_match (a, b))
   let try_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_try (a, b))
@@ -207,7 +224,7 @@ module Exp = struct
   let poly ?loc ?attrs a b = mk ?loc ?attrs (Pexp_poly (a, b))
   let object_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_object a)
   let newtype ?loc ?attrs a b = mk ?loc ?attrs (Pexp_newtype (a, b))
-  let pack ?loc ?attrs a = mk ?loc ?attrs (Pexp_pack a)
+  let pack ?loc ?attrs a b = mk ?loc ?attrs (Pexp_pack (a, b))
   let open_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_open (a, b))
   let letop ?loc ?attrs let_ ands body =
     mk ?loc ?attrs (Pexp_letop {let_; ands; body})
@@ -600,7 +617,6 @@ module Te = struct
      pext_loc = loc;
      pext_attributes = add_docs_attrs docs (add_info_attrs info attrs);
     }
-
 end
 
 module Csig = struct

mlx/ast_helper.mli

@@ -44,15 +44,16 @@ val with_default_loc: loc -> (unit -> 'a) -> 'a
 (** {1 Constants} *)
 
 module Const : sig
-  val char : char -> constant
+  val mk : ?loc:loc -> constant_desc -> constant
+  val char : ?loc:loc -> char -> constant
   val string :
     ?quotation_delimiter:string -> ?loc:Location.t -> string -> constant
-  val integer : ?suffix:char -> string -> constant
-  val int : ?suffix:char -> int -> constant
-  val int32 : ?suffix:char -> int32 -> constant
-  val int64 : ?suffix:char -> int64 -> constant
-  val nativeint : ?suffix:char -> nativeint -> constant
-  val float : ?suffix:char -> string -> constant
+  val integer : ?loc:loc -> ?suffix:char -> string -> constant
+  val int : ?loc:loc -> ?suffix:char -> int -> constant
+  val int32 : ?loc:loc -> ?suffix:char -> int32 -> constant
+  val int64 : ?loc:loc -> ?suffix:char -> int64 -> constant
+  val nativeint : ?loc:loc -> ?suffix:char -> nativeint -> constant
+  val float : ?loc:loc -> ?suffix:char -> string -> constant
 end
 
 (** {1 Attributes} *)
@@ -72,17 +73,19 @@ module Typ :
     val var: ?loc:loc -> ?attrs:attrs -> string -> core_type
     val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> core_type
                -> core_type
-    val tuple: ?loc:loc -> ?attrs:attrs -> core_type list -> core_type
+    val tuple: ?loc:loc -> ?attrs:attrs -> (string option * core_type) list
+               -> core_type
     val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type
     val object_: ?loc:loc -> ?attrs:attrs -> object_field list
                    -> closed_flag -> core_type
     val class_: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type
-    val alias: ?loc:loc -> ?attrs:attrs -> core_type -> string -> core_type
+    val alias: ?loc:loc -> ?attrs:attrs -> core_type -> string with_loc
+               -> core_type
     val variant: ?loc:loc -> ?attrs:attrs -> row_field list -> closed_flag
                  -> label list option -> core_type
     val poly: ?loc:loc -> ?attrs:attrs -> str list -> core_type -> core_type
-    val package: ?loc:loc -> ?attrs:attrs -> lid -> (lid * core_type) list
-                 -> core_type
+    val package: ?loc:loc -> ?attrs:attrs -> package_type -> core_type
+    val open_ : ?loc:loc -> ?attrs:attrs -> lid -> core_type -> core_type
     val extension: ?loc:loc -> ?attrs:attrs -> extension -> core_type
 
     val force_poly: core_type -> core_type
@@ -95,6 +98,10 @@ module Typ :
         appears in [newtypes].
         @since 4.05
      *)
+
+    val package_type: ?loc:loc -> ?attrs:attrs -> lid -> (lid * core_type) list
+      -> package_type
+    (** @since 5.4 *)
   end
 
 (** Patterns *)
@@ -108,7 +115,8 @@ module Pat:
     val alias: ?loc:loc -> ?attrs:attrs -> pattern -> str -> pattern
     val constant: ?loc:loc -> ?attrs:attrs -> constant -> pattern
     val interval: ?loc:loc -> ?attrs:attrs -> constant -> constant -> pattern
-    val tuple: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern
+    val tuple: ?loc:loc -> ?attrs:attrs -> (string option * pattern) list
+               -> closed_flag -> pattern
     val construct: ?loc:loc -> ?attrs:attrs ->
       lid -> (str list * pattern) option -> pattern
     val variant: ?loc:loc -> ?attrs:attrs -> label -> pattern option -> pattern
@@ -122,6 +130,7 @@ module Pat:
     val unpack: ?loc:loc -> ?attrs:attrs -> str_opt -> pattern
     val open_: ?loc:loc -> ?attrs:attrs  -> lid -> pattern -> pattern
     val exception_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern
+    val effect_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern -> pattern
     val extension: ?loc:loc -> ?attrs:attrs -> extension -> pattern
   end
 
@@ -135,15 +144,16 @@ module Exp:
     val constant: ?loc:loc -> ?attrs:attrs -> constant -> expression
     val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list
               -> expression -> expression
-    val fun_: ?loc:loc -> ?attrs:attrs -> arg_label -> expression option
-              -> pattern -> expression -> expression
-    val function_: ?loc:loc -> ?attrs:attrs -> case list -> expression
+    val function_ : ?loc:loc -> ?attrs:attrs -> function_param list
+                   -> type_constraint option -> function_body
+                   -> expression
     val apply: ?loc:loc -> ?attrs:attrs -> expression
                -> (arg_label * expression) list -> expression
     val match_: ?loc:loc -> ?attrs:attrs -> expression -> case list
                 -> expression
     val try_: ?loc:loc -> ?attrs:attrs -> expression -> case list -> expression
-    val tuple: ?loc:loc -> ?attrs:attrs -> expression list -> expression
+    val tuple: ?loc:loc -> ?attrs:attrs -> (string option * expression) list
+               -> expression
     val construct: ?loc:loc -> ?attrs:attrs -> lid -> expression option
                    -> expression
     val variant: ?loc:loc -> ?attrs:attrs -> label -> expression option
@@ -182,7 +192,8 @@ module Exp:
               -> expression
     val object_: ?loc:loc -> ?attrs:attrs -> class_structure -> expression
     val newtype: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression
-    val pack: ?loc:loc -> ?attrs:attrs -> module_expr -> expression
+    val pack: ?loc:loc -> ?attrs:attrs -> module_expr -> package_type option
+               -> expression
     val open_: ?loc:loc -> ?attrs:attrs -> open_declaration -> expression
                -> expression
     val letop: ?loc:loc -> ?attrs:attrs -> binding_op

mlx/docstrings.ml

@@ -91,8 +91,9 @@ let docs_attr ds =
   let open Parsetree in
   let body = ds.ds_body in
   let loc = ds.ds_loc in
+  let const = { pconst_desc= Pconst_string(body,loc,None); pconst_loc= loc } in
   let exp =
-    { pexp_desc = Pexp_constant (Pconst_string(body, loc, None));
+    { pexp_desc = Pexp_constant const;
       pexp_loc = loc;
       pexp_loc_stack = [];
       pexp_attributes = []; }
@@ -143,8 +144,9 @@ let text_attr ds =
   let open Parsetree in
   let body = ds.ds_body in
   let loc = ds.ds_loc in
+  let const = { pconst_desc= Pconst_string(body,loc,None); pconst_loc= loc } in
   let exp =
-    { pexp_desc = Pexp_constant (Pconst_string(body, loc, None));
+    { pexp_desc = Pexp_constant const;
       pexp_loc = loc;
       pexp_loc_stack = [];
       pexp_attributes = []; }

mlx/dune

@@ -4,15 +4,15 @@
  (public_name mlx-pp)
  (modules :standard \ mlx_shim)
  (flags
-  (:standard -w -9-67 -open Astlib -open Astlib.Ast_501 -open Mlx_shim))
+  (:standard -w -9-67 -open Astlib -open Astlib.Ast_504 -open Mlx_shim))
  (libraries ppxlib ocaml-compiler-libs.shadow mlx_shim))
 
 (library
  (name mlx_shim)
  (package mlx)
  (modules mlx_shim)
  (flags
-  (:standard -w -9-67 -open Astlib -open Astlib.Ast_501))
+  (:standard -w -9-67 -open Astlib -open Astlib.Ast_504))
  (libraries ppxlib ocaml-compiler-libs.shadow))
 
 (ocamllex lexer)
@@ -39,7 +39,7 @@
  (mode promote)
  (enabled_if
   (<> %{profile} "release"))
- (files ../ocaml/parsing/parse.{ml,mli}))
+ (files ../ocaml/parsing/parse.mli))
 
 (copy_files
  (mode promote)

mlx/jsx_helper.ml

@@ -19,23 +19,15 @@ let mkjsxexp ~loc:loc' e =
   let pexp_attributes = [ Attr.mk ~loc { txt = "JSX"; loc } (PStr []) ] in
   { e with pexp_attributes }
 
-let rec equal_longindent a b =
-  match a, b with
-  | Longident.Lident a, Longident.Lident b -> String.equal a b
-  | Ldot (pa, a), Ldot (pb, b) ->
-      String.equal a b && equal_longindent pa pb
-  | Lapply _, _ | _, Lapply _ -> assert false
-  | _ -> false
-
 let make_jsx_element ~raise ~loc:_ ~tag ~end_tag ~props ~children () =
   let () =
     match end_tag with
     | None -> ()
     | Some (end_tag, (_, end_loc_e)) ->
         let eq =
           match tag, end_tag with
-          | (`Module, _, s), (`Module, _, e) -> equal_longindent s e
-          | (`Value, _, s), (`Value, _, e) -> equal_longindent s e
+          | (`Module, _, s), (`Module, _, e) -> Longident.same s e
+          | (`Value, _, s), (`Value, _, e) -> Longident.same s e
           | _ -> false
         in
         if not eq then
@@ -57,8 +49,12 @@ let make_jsx_element ~raise ~loc:_ ~tag ~end_tag ~props ~children () =
     | `Value, loc, txt ->
         mkexp ~loc (Pexp_ident { loc = make_loc loc; txt })
     | `Module, loc, txt ->
-        let txt = Longident.Ldot (txt, "createElement") in
-        mkexp ~loc (Pexp_ident { loc = make_loc loc; txt })
+        let loc' = make_loc loc in
+        let txt =
+          Longident.Ldot
+            ({ txt; loc = loc' }, { txt = "createElement"; loc = loc' })
+        in
+        mkexp ~loc (Pexp_ident { loc = loc'; txt })
   in
   let props =
     let prop_exp ~loc name =

mlx/lexer.mli

@@ -20,7 +20,7 @@
 
 *)
 
-val init : unit -> unit
+val init : ?keyword_edition:((int*int) option * string list) -> unit -> unit
 val token: Lexing.lexbuf -> Parser.token
 val skip_hash_bang: Lexing.lexbuf -> unit
 
@@ -33,14 +33,21 @@ type error =
   | Unterminated_string_in_comment of Location.t * Location.t
   | Empty_character_literal
   | Keyword_as_label of string
+  | Capitalized_label of string
   | Invalid_literal of string
   | Invalid_directive of string * string option
+  | Invalid_encoding of string
+  | Invalid_char_in_ident of Uchar.t
+  | Non_lowercase_delimiter of string
+  | Capitalized_raw_identifier of string
+  | Unknown_keyword of string
 
 exception Error of error * Location.t
 
 val in_comment : unit -> bool
 val in_string : unit -> bool
 
+val is_keyword : string -> bool
 
 val print_warnings : bool ref
 val handle_docstrings: bool ref