Resolve OCaml 5 conflicts in parsing/ (#173)

* fix parser.mly * Fix conflicts in parse.ml, pprintast.ml, location.ml * Generate parser as part of the dune build, rather than using boot/ Requires two hacks for MenhirLib, copying the hacks used in the Makefile: 1. Copy MenhirLib to camlinternalMenhirLib (keeping a fix for a locals-related horror from Makefile.menhir) 2. Add "module MenhirLib = CamlinternalMenhirLib" to parser.ml (expressed as a custom dune preprocessor) a * promote menhir * CR layouts 1.5 --------- Co-authored-by: Stephen Dolan <[email protected]>
ocaml-flambda · Oct 18, 2023 · d841d7f · d841d7f
1 parent e81bd7d
commit d841d7f
Show file tree

Hide file tree

Showing 11 changed files with 32,634 additions and 69,958 deletions.
diff --git a/boot/menhir/parser.ml b/boot/menhir/parser.ml
diff --git a/compilerlibs/Makefile.compilerlibs b/compilerlibs/Makefile.compilerlibs
@@ -34,13 +34,9 @@ UTILS = \
   utils/local_store.cmo \
   utils/load_path.cmo \
   utils/clflags.cmo \
-<<<<<<< HEAD
   utils/debug.cmo \
   utils/language_extension_kernel.cmo \
   utils/language_extension.cmo \
-||||||| merged common ancestors
-=======
->>>>>>> ocaml/5.1
   utils/profile.cmo \
   utils/terminfo.cmo \
   utils/ccomp.cmo \
@@ -88,15 +84,8 @@ TYPING = \
   typing/path.cmo \
   typing/jkind.cmo \
   typing/primitive.cmo \
-<<<<<<< HEAD
   typing/shape.cmo \
   typing/mode.cmo \
-||||||| merged common ancestors
-  typing/type_immediacy.cmo \
-=======
-  typing/type_immediacy.cmo \
-  typing/shape.cmo \
->>>>>>> ocaml/5.1
   typing/types.cmo \
   typing/btype.cmo \
   typing/oprint.cmo \

diff --git a/dune b/dune
@@ -30,6 +30,7 @@
 
 (copy_files# utils/*.ml{,i})
 (copy_files# parsing/*.ml{,i})
+(copy_files parsing/parser.mly)
 (copy_files# typing/*.ml{,i})
 (copy_files# bytecomp/*.ml{,i})
 (copy_files# driver/*.ml{,i})
@@ -42,6 +43,14 @@
 ;(copy_files# middle_end/flambda/*.ml{,i})
 ;(copy_files# middle_end/flambda/base_types/*.ml{,i})
 
+(menhir
+  (modules parser)
+  (flags
+    --lalr --explain --dump --require-aliases --strict
+    --unused-token COMMENT --unused-token DOCSTRING --unused-token EOL --unused-token GREATERRBRACKET
+    --fixed-exception --table
+    --strategy simplified))
+
 (library
  (name ocamlcommon)
  (wrapped false)
@@ -52,6 +61,13 @@
    ; remove -w -67 by adding the camlinternalMenhirLib hack like the Makefile
  ))
  (ocamlopt_flags (:include %{project_root}/ocamlopt_flags.sexp))
+ (preprocess
+   (per_module
+     ((action
+        (progn
+          (echo "module MenhirLib = CamlinternalMenhirLib")
+          (run cat %{input-file})))
+       parser)))
  (library_flags -linkall)
  (modules_without_implementation
    annot asttypes jane_asttypes cmo_format outcometree parsetree debug_event)

diff --git a/dune-project.jst b/dune-project.jst
@@ -1,6 +1,7 @@
 (lang dune 2.8)
 (wrapped_executables false)
 (using experimental_building_ocaml_compiler_with_dune 0.1)
+(using menhir 2.1)
 
 (use_standard_c_and_cxx_flags true)
 (cram enable)

diff --git a/parsing/dune b/parsing/dune
@@ -12,36 +12,20 @@
 ;*                                                                        *
 ;**************************************************************************
 
-;; We're just reusing the stuff from boot/ here.
-;; One could add a dune file in boot/menhir/ with the appropriate rules if we
-;; want to regenerate the parser while building with dune, but it doesn't seem
-;; essential right now.
-
 (rule
  (targets camlinternalMenhirLib.ml)
- (mode    fallback)
- (action  (copy# ../boot/menhir/menhirLib.ml %{targets})))
-
-(rule
- (targets camlinternalMenhirLib.mli)
- (mode    fallback)
- (action  (copy# ../boot/menhir/menhirLib.mli %{targets})))
-
-(rule
- (targets parser.ml)
- (mode    fallback)
- (deps    (:dep ../boot/menhir/parser.ml))
  (action
-   (with-stdout-to %{targets}
-     (bash "cat %{dep} | sed 's/MenhirLib/CamlinternalMenhirLib/g'"))))
+  (with-stdout-to %{targets}
+   ;; Partial applications of the form Obj.magic f x in menhirLib cause
+   ;; an issue with locals, so rewrite these to Obj.magic (f x)
+   (bash "cat $(menhir --suggest-menhirLib)/menhirLib.ml |
+          sed 's/\\b\\(in\\|then\\|with\\|else\\)\\b/@@@\\1/g; s/Obj.magic \\([a-z0-9_]\\+\\( [a-z0-9_]\\+\\)\\+\\)/Obj.magic (\\1)/g;  s/@@@//g'"))))
 
 (rule
- (targets parser.mli)
- (mode    fallback)
- (deps    (:dep ../boot/menhir/parser.mli))
+ (targets camlinternalMenhirLib.mli)
  (action
-   (with-stdout-to %{targets}
-     (bash "cat %{dep} | sed 's/MenhirLib/CamlinternalMenhirLib/g'"))))
+  (with-stdout-to %{targets}
+   (bash "cat $(menhir --suggest-menhirLib)/menhirLib.mli"))))
 
 (ocamllex
  (modules lexer)

diff --git a/parsing/location.ml b/parsing/location.ml
@@ -18,7 +18,6 @@ open Lexing
 type t = Warnings.loc =
   { loc_start: position; loc_end: position; loc_ghost: bool }
 
-<<<<<<< HEAD
 let compare_position : position -> position -> int =
   fun
     { pos_fname = pos_fname_1
@@ -59,18 +58,7 @@ let compare
   | i -> i
 ;;
 
-let in_file name =
-  let loc = { dummy_pos with pos_fname = name } in
-  { loc_start = loc; loc_end = loc; loc_ghost = true }
-;;
-||||||| merged common ancestors
-let in_file name =
-  let loc = { dummy_pos with pos_fname = name } in
-  { loc_start = loc; loc_end = loc; loc_ghost = true }
-;;
-=======
 let in_file = Warnings.ghost_loc_in_file
->>>>>>> ocaml/5.1
 
 let none = in_file "_none_"
 let is_none l = (l = none)

diff --git a/parsing/parse.ml b/parsing/parse.ml
@@ -104,99 +104,3 @@ let constr_ident= wrap Parser.parse_constr_longident
 let extended_module_path = wrap Parser.parse_mod_ext_longident
 let simple_module_path = wrap Parser.parse_mod_longident
 let type_ident = wrap Parser.parse_mty_longident
-<<<<<<< HEAD
-||||||| merged common ancestors
-
-(* Error reporting for Syntaxerr *)
-(* The code has been moved here so that one can reuse Pprintast.tyvar *)
-
-let prepare_error err =
-  let open Syntaxerr in
-  match err with
-  | Unclosed(opening_loc, opening, closing_loc, closing) ->
-      Location.errorf
-        ~loc:closing_loc
-        ~sub:[
-          Location.msg ~loc:opening_loc
-            "This '%s' might be unmatched" opening
-        ]
-        "Syntax error: '%s' expected" closing
-
-  | Expecting (loc, nonterm) ->
-      Location.errorf ~loc "Syntax error: %s expected." nonterm
-  | Not_expecting (loc, nonterm) ->
-      Location.errorf ~loc "Syntax error: %s not expected." nonterm
-  | Applicative_path loc ->
-      Location.errorf ~loc
-        "Syntax error: applicative paths of the form F(X).t \
-         are not supported when the option -no-app-func is set."
-  | Variable_in_scope (loc, var) ->
-      Location.errorf ~loc
-        "In this scoped type, variable %a \
-         is reserved for the local type %s."
-        Pprintast.tyvar var var
-  | Other loc ->
-      Location.errorf ~loc "Syntax error"
-  | Ill_formed_ast (loc, s) ->
-      Location.errorf ~loc
-        "broken invariant in parsetree: %s" s
-  | Invalid_package_type (loc, s) ->
-      Location.errorf ~loc "invalid package type: %s" s
-
-let () =
-  Location.register_error_of_exn
-    (function
-      | Syntaxerr.Error err -> Some (prepare_error err)
-      | _ -> None
-    )
-=======
-
-(* Error reporting for Syntaxerr *)
-(* The code has been moved here so that one can reuse Pprintast.tyvar *)
-
-let prepare_error err =
-  let open Syntaxerr in
-  match err with
-  | Unclosed(opening_loc, opening, closing_loc, closing) ->
-      Location.errorf
-        ~loc:closing_loc
-        ~sub:[
-          Location.msg ~loc:opening_loc
-            "This '%s' might be unmatched" opening
-        ]
-        "Syntax error: '%s' expected" closing
-
-  | Expecting (loc, nonterm) ->
-      Location.errorf ~loc "Syntax error: %s expected." nonterm
-  | Not_expecting (loc, nonterm) ->
-      Location.errorf ~loc "Syntax error: %s not expected." nonterm
-  | Applicative_path loc ->
-      Location.errorf ~loc
-        "Syntax error: applicative paths of the form F(X).t \
-         are not supported when the option -no-app-func is set."
-  | Variable_in_scope (loc, var) ->
-      Location.errorf ~loc
-        "In this scoped type, variable %a \
-         is reserved for the local type %s."
-        Pprintast.tyvar var var
-  | Other loc ->
-      Location.errorf ~loc "Syntax error"
-  | Ill_formed_ast (loc, s) ->
-      Location.errorf ~loc
-        "broken invariant in parsetree: %s" s
-  | Invalid_package_type (loc, s) ->
-      Location.errorf ~loc "invalid package type: %s" s
-  | Removed_string_set loc ->
-      Location.errorf ~loc
-        "Syntax error: strings are immutable, there is no assignment \
-         syntax for them.\n\
-         @{<hint>Hint@}: Mutable sequences of bytes are available in \
-         the Bytes module.\n\
-         @{<hint>Hint@}: Did you mean to use 'Bytes.set'?"
-let () =
-  Location.register_error_of_exn
-    (function
-      | Syntaxerr.Error err -> Some (prepare_error err)
-      | _ -> None
-    )
->>>>>>> ocaml/5.1
diff --git a/parsing/parser.mly b/parsing/parser.mly
@@ -3125,113 +3125,53 @@ labeled_simple_expr:
 ;
 let_binding_body_no_punning:
     let_ident strict_binding
-<<<<<<< HEAD
-      { ($1, $2) }
+      { ($1, $2, None) }
   | mode_flags let_ident type_constraint EQUAL seq_expr
       { let v = $2 in (* PR#7344 *)
-||||||| merged common ancestors
-      { ($1, $2) }
-  | let_ident type_constraint EQUAL seq_expr
-      { let v = $1 in (* PR#7344 *)
-=======
-      { ($1, $2, None) }
-  | let_ident type_constraint EQUAL seq_expr
-      { let v = $1 in (* PR#7344 *)
->>>>>>> ocaml/5.1
         let t =
-<<<<<<< HEAD
           match $3 with
-          | N_ary.Pconstraint t -> t
-          | N_ary.Pcoerce (_, t) -> t
-||||||| merged common ancestors
-          match $2 with
-            Some t, None -> t
-          | _, Some t -> t
-          | _ -> assert false
-=======
-          match $2 with
-            Some t, None ->
+          | N_ary.Pconstraint t ->
              Pvc_constraint { locally_abstract_univars = []; typ=t }
-          | ground, Some coercion -> Pvc_coercion { ground; coercion}
-          | _ -> assert false
->>>>>>> ocaml/5.1
+          | N_ary.Pcoerce (ground, coercion) -> Pvc_coercion { ground; coercion}
         in
-<<<<<<< HEAD
-        let loc = Location.(t.ptyp_loc.loc_start, t.ptyp_loc.loc_end) in
-        let typ = ghtyp ~loc (Ptyp_poly([],t)) in
-        let patloc = ($startpos($2), $endpos($3)) in
-        let pat =
-          mkpat_with_modes $1 (ghpat ~loc:patloc (Ppat_constraint(v, typ)))
-        in
-        let exp =
-          ghexp_with_modes $sloc $1
-            (wrap_exp_with_modes $1 (mkexp_constraint ~loc:$sloc $5 $3))
-        in
-        (pat, exp) }
+        let pat = mkpat_with_modes $1 v in
+        let exp = ghexp_with_modes $sloc $1 (wrap_exp_with_modes $1 $5) in
+        (pat, exp, Some t)
+      }
   | mode_flags let_ident COLON poly(core_type) EQUAL seq_expr
-      { let patloc = ($startpos($2), $endpos($4)) in
-        let bound_vars, inner_type = $4 in
+      { let bound_vars, inner_type = $4 in
         let ltyp = Jane_syntax.Layouts.Ltyp_poly { bound_vars; inner_type } in
         let typ_loc = Location.ghostify (make_loc $loc($4)) in
         let typ =
           Jane_syntax.Layouts.type_of ~loc:typ_loc ltyp
         in
-        let pat =
-          mkpat_with_modes $1
-            (ghpat ~loc:patloc
-               (Ppat_constraint($2, typ)))
-        in
+        let pat = mkpat_with_modes $1 $2 in
         let exp = ghexp_with_modes $sloc $1 $6 in
-        (pat, exp) }
+        (pat, exp, Some (Pvc_constraint { locally_abstract_univars = []; typ }))
+      }
   | let_ident COLON TYPE newtypes DOT core_type EQUAL seq_expr
-      { let exp, poly =
-          wrap_type_annotation ~loc:$sloc $4 $6 $8 in
-        let loc = ($startpos($1), $endpos($6)) in
-        (ghpat ~loc (Ppat_constraint($1, poly)), exp) }
-||||||| merged common ancestors
-        let loc = Location.(t.ptyp_loc.loc_start, t.ptyp_loc.loc_end) in
-        let typ = ghtyp ~loc (Ptyp_poly([],t)) in
-        let patloc = ($startpos($1), $endpos($2)) in
-        (ghpat ~loc:patloc (Ppat_constraint(v, typ)),
-         mkexp_constraint ~loc:$sloc $4 $2) }
-  | let_ident COLON poly(core_type) EQUAL seq_expr
-      { let patloc = ($startpos($1), $endpos($3)) in
-        (ghpat ~loc:patloc
-           (Ppat_constraint($1, ghtyp ~loc:($loc($3)) $3)),
-         $5) }
-  | let_ident COLON TYPE lident_list DOT core_type EQUAL seq_expr
-      { let exp, poly =
-          wrap_type_annotation ~loc:$sloc $4 $6 $8 in
+      (* The code upstream looks like:
+         {[
+           let constraint' =
+             Pvc_constraint { locally_abstract_univars=$4; typ = $6}
+           in
+           ($1, $8, Some constraint')
+         ]}
+
+         But this would require encoding [newtypes] (which, internally, may
+         associate a layout with a newtype) in Jane Syntax, which will require
+         a small amount of work.
+      *)
+      { let exp, poly = wrap_type_annotation ~loc:$sloc $4 $6 $8 in
         let loc = ($startpos($1), $endpos($6)) in
-        (ghpat ~loc (Ppat_constraint($1, poly)), exp) }
-=======
-        (v, $4, Some t)
-        }
-  | let_ident COLON poly(core_type) EQUAL seq_expr
-    {
-      let t = ghtyp ~loc:($loc($3)) $3 in
-      ($1, $5, Some (Pvc_constraint { locally_abstract_univars = []; typ=t }))
-    }
-  | let_ident COLON TYPE lident_list DOT core_type EQUAL seq_expr
-    { let constraint' =
-        Pvc_constraint { locally_abstract_univars=$4; typ = $6}
-      in
-      ($1, $8, Some constraint') }
->>>>>>> ocaml/5.1
+        (ghpat ~loc (Ppat_constraint($1, poly)), exp, None)
+       }
   | pattern_no_exn EQUAL seq_expr
       { ($1, $3, None) }
   | simple_pattern_not_ident COLON core_type EQUAL seq_expr
-<<<<<<< HEAD
-      { let loc = ($startpos($1), $endpos($3)) in
-        (ghpat ~loc (Ppat_constraint($1, $3)), $5) }
-  | mode_flag+ let_ident strict_binding_modes
-    { ($2, ghexp_with_modes $sloc $1 ($3 $1)) }
-||||||| merged common ancestors
-      { let loc = ($startpos($1), $endpos($3)) in
-        (ghpat ~loc (Ppat_constraint($1, $3)), $5) }
-=======
       { ($1, $5, Some(Pvc_constraint { locally_abstract_univars=[]; typ=$3 })) }
->>>>>>> ocaml/5.1
+  | mode_flag+ let_ident strict_binding_modes
+      { ($2, ghexp_with_modes $sloc $1 ($3 $1), None) }
 ;
 let_binding_body:
   | let_binding_body_no_punning