mlx: support for 4.14

mlx/docstrings.mli

@@ -0,0 +1,223 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                               Leo White                                *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Documentation comments
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+(** (Re)Initialise all docstring state *)
+val init : unit -> unit
+
+(** Emit warnings for unattached and ambiguous docstrings *)
+val warn_bad_docstrings : unit -> unit
+
+(** {2 Docstrings} *)
+
+(** Documentation comments *)
+type docstring
+
+(** Create a docstring *)
+val docstring : string -> Location.t -> docstring
+
+(** Register a docstring *)
+val register : docstring -> unit
+
+(** Get the text of a docstring *)
+val docstring_body : docstring -> string
+
+(** Get the location of a docstring *)
+val docstring_loc : docstring -> Location.t
+
+(** {2 Set functions}
+
+   These functions are used by the lexer to associate docstrings to
+   the locations of tokens. *)
+
+(** Docstrings immediately preceding a token *)
+val set_pre_docstrings : Lexing.position -> docstring list -> unit
+
+(** Docstrings immediately following a token *)
+val set_post_docstrings : Lexing.position -> docstring list -> unit
+
+(** Docstrings not immediately adjacent to a token *)
+val set_floating_docstrings : Lexing.position -> docstring list -> unit
+
+(** Docstrings immediately following the token which precedes this one *)
+val set_pre_extra_docstrings : Lexing.position -> docstring list -> unit
+
+(** Docstrings immediately preceding the token which follows this one *)
+val set_post_extra_docstrings : Lexing.position -> docstring list -> unit
+
+(** {2 Items}
+
+    The {!docs} type represents documentation attached to an item. *)
+
+type docs =
+  { docs_pre: docstring option;
+    docs_post: docstring option; }
+
+val empty_docs : docs
+
+val docs_attr : docstring -> Parsetree.attribute
+
+(** Convert item documentation to attributes and add them to an
+    attribute list *)
+val add_docs_attrs : docs -> Parsetree.attributes -> Parsetree.attributes
+
+(** Fetch the item documentation for the current symbol. This also
+    marks this documentation (for ambiguity warnings). *)
+val symbol_docs : unit -> docs
+val symbol_docs_lazy : unit -> docs Lazy.t
+
+(** Fetch the item documentation for the symbols between two
+    positions. This also marks this documentation (for ambiguity
+    warnings). *)
+val rhs_docs : int -> int -> docs
+val rhs_docs_lazy : int -> int -> docs Lazy.t
+
+(** Mark the item documentation for the current symbol (for ambiguity
+    warnings). *)
+val mark_symbol_docs : unit -> unit
+
+(** Mark as associated the item documentation for the symbols between
+    two positions (for ambiguity warnings) *)
+val mark_rhs_docs : int -> int -> unit
+
+(** {2 Fields and constructors}
+
+    The {!info} type represents documentation attached to a field or
+    constructor. *)
+
+type info = docstring option
+
+val empty_info : info
+
+val info_attr : docstring -> Parsetree.attribute
+
+(** Convert field info to attributes and add them to an
+    attribute list *)
+val add_info_attrs : info -> Parsetree.attributes -> Parsetree.attributes
+
+(** Fetch the field info for the current symbol. *)
+val symbol_info : unit -> info
+
+(** Fetch the field info following the symbol at a given position. *)
+val rhs_info : int -> info
+
+(** {2 Unattached comments}
+
+    The {!text} type represents documentation which is not attached to
+    anything. *)
+
+type text = docstring list
+
+val empty_text : text
+val empty_text_lazy : text Lazy.t
+
+val text_attr : docstring -> Parsetree.attribute
+
+(** Convert text to attributes and add them to an attribute list *)
+val add_text_attrs : text -> Parsetree.attributes -> Parsetree.attributes
+
+(** Fetch the text preceding the current symbol. *)
+val symbol_text : unit -> text
+val symbol_text_lazy : unit -> text Lazy.t
+
+(** Fetch the text preceding the symbol at the given position. *)
+val rhs_text : int -> text
+val rhs_text_lazy : int -> text Lazy.t
+
+(** {2 Extra text}
+
+    There may be additional text attached to the delimiters of a block
+    (e.g. [struct] and [end]). This is fetched by the following
+    functions, which are applied to the contents of the block rather
+    than the delimiters. *)
+
+(** Fetch additional text preceding the current symbol *)
+val symbol_pre_extra_text : unit -> text
+
+(** Fetch additional text following the current symbol *)
+val symbol_post_extra_text : unit -> text
+
+(** Fetch additional text preceding the symbol at the given position *)
+val rhs_pre_extra_text : int -> text
+
+(** Fetch additional text following the symbol at the given position *)
+val rhs_post_extra_text : int -> text
+
+(** Fetch text following the symbol at the given position *)
+val rhs_post_text : int -> text
+
+module WithMenhir: sig
+(** Fetch the item documentation for the current symbol. This also
+    marks this documentation (for ambiguity warnings). *)
+val symbol_docs : Lexing.position * Lexing.position -> docs
+val symbol_docs_lazy : Lexing.position * Lexing.position -> docs Lazy.t
+
+(** Fetch the item documentation for the symbols between two
+    positions. This also marks this documentation (for ambiguity
+    warnings). *)
+val rhs_docs : Lexing.position -> Lexing.position -> docs
+val rhs_docs_lazy : Lexing.position -> Lexing.position -> docs Lazy.t
+
+(** Mark the item documentation for the current symbol (for ambiguity
+    warnings). *)
+val mark_symbol_docs : Lexing.position * Lexing.position -> unit
+
+(** Mark as associated the item documentation for the symbols between
+    two positions (for ambiguity warnings) *)
+val mark_rhs_docs : Lexing.position -> Lexing.position -> unit
+
+(** Fetch the field info for the current symbol. *)
+val symbol_info : Lexing.position -> info
+
+(** Fetch the field info following the symbol at a given position. *)
+val rhs_info : Lexing.position -> info
+
+(** Fetch the text preceding the current symbol. *)
+val symbol_text : Lexing.position -> text
+val symbol_text_lazy : Lexing.position -> text Lazy.t
+
+(** Fetch the text preceding the symbol at the given position. *)
+val rhs_text : Lexing.position -> text
+val rhs_text_lazy : Lexing.position -> text Lazy.t
+
+(** {3 Extra text}
+
+    There may be additional text attached to the delimiters of a block
+    (e.g. [struct] and [end]). This is fetched by the following
+    functions, which are applied to the contents of the block rather
+    than the delimiters. *)
+
+(** Fetch additional text preceding the current symbol *)
+val symbol_pre_extra_text : Lexing.position -> text
+
+(** Fetch additional text following the current symbol *)
+val symbol_post_extra_text : Lexing.position -> text
+
+(** Fetch additional text preceding the symbol at the given position *)
+val rhs_pre_extra_text : Lexing.position -> text
+
+(** Fetch additional text following the symbol at the given position *)
+val rhs_post_extra_text : Lexing.position -> text
+
+(** Fetch text following the symbol at the given position *)
+val rhs_post_text : Lexing.position -> text
+
+end

mlx/dune

@@ -3,8 +3,8 @@
  (package mlx)
  (public_name mlx-pp)
  (flags
-  (:standard -w -9-67))
- (libraries compiler-libs.common))
+  (:standard -w -9-67 -open Astlib.Ast_501))
+ (libraries ppxlib compiler-libs.common))
 
 (ocamllex lexer)
 
@@ -38,6 +38,24 @@
   (<> %{profile} "release"))
  (files ../ocaml/parsing/lexer.mli))
 
+(copy_files
+ (mode promote)
+ (enabled_if
+  (<> %{profile} "release"))
+ (files ../ocaml/parsing/syntaxerr.{ml,mli}))
+
+(copy_files
+ (mode promote)
+ (enabled_if
+  (<> %{profile} "release"))
+ (files ../ocaml/parsing/ast_helper.{ml,mli}))
+
+(copy_files
+ (mode promote)
+ (enabled_if
+  (<> %{profile} "release"))
+ (files ../ocaml/parsing/docstrings.{ml,mli}))
+
 (copy_files
  (mode promote)
  (enabled_if

mlx/pp.ml

@@ -2,6 +2,8 @@ let print_ml = ref false
 let input = ref None
 let speclist = [ "-print-ml", Arg.Set print_ml, "Print .ml syntax" ]
 
+module Conv = Ppxlib_ast.Convert(Ppxlib_ast__Versions.OCaml_501)(Ppxlib_ast.Compiler_version)
+
 let () =
   Arg.parse speclist
     (fun input' -> input := Some input')
@@ -23,6 +25,7 @@ let () =
   in
   match str with
   | Ok str ->
+      let str = Conv.copy_structure str in
       if !print_ml then Format.printf "%a@." Pprintast.structure str
       else
         let oc = stdout in

mlx/syntaxerr.ml

@@ -0,0 +1,45 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1997 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Auxiliary type for reporting syntax errors *)
+
+type error =
+    Unclosed of Location.t * string * Location.t * string
+  | Expecting of Location.t * string
+  | Not_expecting of Location.t * string
+  | Applicative_path of Location.t
+  | Variable_in_scope of Location.t * string
+  | Other of Location.t
+  | Ill_formed_ast of Location.t * string
+  | Invalid_package_type of Location.t * string
+  | Removed_string_set of Location.t
+
+exception Error of error
+exception Escape_error
+
+let location_of_error = function
+  | Unclosed(l,_,_,_)
+  | Applicative_path l
+  | Variable_in_scope(l,_)
+  | Other l
+  | Not_expecting (l, _)
+  | Ill_formed_ast (l, _)
+  | Invalid_package_type (l, _)
+  | Expecting (l, _)
+  | Removed_string_set l -> l
+
+
+let ill_formed_ast loc s =
+  raise (Error (Ill_formed_ast (loc, s)))

mlx/syntaxerr.mli

@@ -0,0 +1,38 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1997 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Auxiliary type for reporting syntax errors
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+type error =
+    Unclosed of Location.t * string * Location.t * string
+  | Expecting of Location.t * string
+  | Not_expecting of Location.t * string
+  | Applicative_path of Location.t
+  | Variable_in_scope of Location.t * string
+  | Other of Location.t
+  | Ill_formed_ast of Location.t * string
+  | Invalid_package_type of Location.t * string
+  | Removed_string_set of Location.t
+
+exception Error of error
+exception Escape_error
+
+val location_of_error: error -> Location.t
+val ill_formed_ast: Location.t -> string -> 'a