Add ghostify function (#1)

* Add `Location.ghostify`

* Update the parser's `make_ghost` to save an allocation in some cases

* Promote parser.ml

ocaml/parsing/extensions.ml

@@ -90,7 +90,7 @@ module Comprehensions = struct
   *)
 
   let comprehension_expr ~loc names x =
-    Expression.wrap_desc ~loc:Location.{loc with loc_ghost = true} ~attrs:[] @@
+    Expression.wrap_desc ~loc:(Location.ghostify loc) ~attrs:[] @@
     Expression.make_extension ~loc (extension_string :: names) x
 
   (** First, we define how to go from the nice AST to the OCaml AST; this is
@@ -112,7 +112,7 @@ module Comprehensions = struct
 
   let expr_of_clause_binding ~loc { pattern; iterator; attributes } =
     Ast_helper.Vb.mk
-      ~loc:{loc with loc_ghost = true}
+      ~loc:(Location.ghostify loc)
       ~attrs:attributes
       pattern
       (expr_of_iterator ~loc iterator)

ocaml/parsing/extensions_parsing.ml

@@ -196,7 +196,7 @@ module Make_AST (AST_parameters : AST_parameters) :
     include AST_parameters
 
     let make_extension ~loc names =
-      let loc = Location.{loc with loc_ghost = true} in
+      let loc = Location.ghostify loc in
       make_extension_use
         ~extension_node:
           (make_extension_node

ocaml/parsing/location.ml

@@ -41,6 +41,11 @@ let init lexbuf fname =
   }
 ;;
 
+let ghostify l =
+  if l.loc_ghost
+  then l
+  else { l with loc_ghost = true }
+
 let symbol_rloc () = {
   loc_start = Parsing.symbol_start_pos ();
   loc_end = Parsing.symbol_end_pos ();

ocaml/parsing/location.mli

@@ -68,6 +68,9 @@ val init : Lexing.lexbuf -> string -> unit
 val curr : Lexing.lexbuf -> t
 (** Get the location of the current token from the [lexbuf]. *)
 
+val ghostify : t -> t
+(** Return a version of the location with [loc_ghost = true] *)
+
 val symbol_rloc: unit -> t
 val symbol_gloc: unit -> t
 

ocaml/parsing/parser.mly

@@ -504,7 +504,10 @@ let lapply ~loc p1 p2 =
 let loc_map (f : 'a -> 'b) (x : 'a Location.loc) : 'b Location.loc =
   { x with txt = f x.txt }
 
-let make_ghost x = { x with loc = { x.loc with loc_ghost = true }}
+let make_ghost x =
+  if x.loc.loc_ghost
+  then x (* Save an allocation *)
+  else { x with loc = Location.ghostify x.loc }
 
 let loc_last (id : Longident.t Location.loc) : string Location.loc =
   loc_map Longident.last id

ocaml/typing/typeclass.ml

@@ -999,7 +999,7 @@ and class_structure cl_num virt self_scope final val_env met_env loc
   let par_env = met_env in
 
   (* Location of self. Used for locations of self arguments *)
-  let self_loc = {spat.ppat_loc with Location.loc_ghost = true} in
+  let self_loc = Location.ghostify spat.ppat_loc in
 
   let sign = Ctype.new_class_signature () in
 

ocaml/typing/typecore.ml

@@ -1249,7 +1249,7 @@ let build_or_pat env loc lid =
   let make_row more =
     create_row ~fields ~more ~closed:false ~fixed:None ~name in
   let ty = newty (Tvariant (make_row (newvar Layout.value))) in
-  let gloc = {loc with Location.loc_ghost=true} in
+  let gloc = Location.ghostify loc in
   let row' = ref (make_row (newvar Layout.value)) in
   let pats =
     List.map
@@ -2247,7 +2247,7 @@ and type_pat_aux
         pat_env = !env }
   | Ppat_interval (Pconst_char c1, Pconst_char c2) ->
       let open Ast_helper.Pat in
-      let gloc = {loc with Location.loc_ghost=true} in
+      let gloc = Location.ghostify loc in
       let rec loop c1 c2 =
         if c1 = c2 then constant ~loc:gloc (Pconst_char c1)
         else
@@ -5319,7 +5319,7 @@ and type_expect_
         | { pbop_pat = spat; _} :: rest ->
             (* CR layouts v5: eliminate value requirement *)
             let ty = newvar Layout.value in
-            let loc = { slet.pbop_op.loc with Location.loc_ghost = true } in
+            let loc = Location.ghostify slet.pbop_op.loc in
             let spat_acc = Ast_helper.Pat.tuple ~loc [spat_acc; spat] in
             let ty_acc = newty (Ttuple [ty_acc; ty]) in
             loop spat_acc ty_acc rest
@@ -5726,7 +5726,7 @@ and type_label_access env srecord usage lid =
    (Handling of * modifiers contributed by Thorsten Ohl.) *)
 
 and type_format loc str env =
-  let loc = {loc with Location.loc_ghost = true} in
+  let loc = Location.ghostify loc in
   try
     CamlinternalFormatBasics.(CamlinternalFormat.(
       let mk_exp_loc pexp_desc = {
@@ -6764,7 +6764,7 @@ and type_let
                (* propagate type annotation to pattern,
                   to allow it to be generalized in -principal mode *)
                Pat.constraint_
-                 ~loc:{spat.ppat_loc with Location.loc_ghost=true}
+                 ~loc:(Location.ghostify spat.ppat_loc)
                  spat
                  sty
            | _ -> spat

ocaml/typing/typedecl.ml

@@ -1354,12 +1354,12 @@ let transl_type_decl env rec_flag sdecl_list =
     List.map
       (fun sdecl ->
          let ptype_name =
-           let loc = { sdecl.ptype_name.loc with Location.loc_ghost = true } in
+           let loc = Location.ghostify sdecl.ptype_name.loc in
            mkloc (sdecl.ptype_name.txt ^"#row") loc
          in
          let ptype_kind = Ptype_abstract in
          let ptype_manifest = None in
-         let ptype_loc = { sdecl.ptype_loc with Location.loc_ghost = true } in
+         let ptype_loc = Location.ghostify sdecl.ptype_loc in
         {sdecl with
            ptype_name; ptype_kind; ptype_manifest; ptype_loc })
       fixed_types