Attach location to constants (ocaml-ppx#1749)

Author: gpetiot

lib/Ast.ml

@@ -278,7 +278,7 @@ module Exp = struct
 
   let rec is_trivial c exp =
     match exp.pexp_desc with
-    | Pexp_constant (Pconst_string (_, _, None)) -> true
+    | Pexp_constant {pconst_desc= Pconst_string (_, _, None); _} -> true
     | Pexp_constant _ | Pexp_field _ | Pexp_ident _ | Pexp_send _ -> true
     | Pexp_construct (_, exp) -> Option.for_all exp ~f:(is_trivial c)
     | Pexp_apply (e0, [(_, e1)]) when is_prefix e0 -> is_trivial c e1
@@ -345,7 +345,8 @@ let doc_atrs ?(acc = []) atrs =
                 [ { pstr_desc=
                       Pstr_eval
                         ( { pexp_desc=
-                              Pexp_constant (Pconst_string (doc, _, None))
+                              Pexp_constant
+                                {pconst_desc= Pconst_string (doc, _, None); _}
                           ; pexp_loc= loc
                           ; pexp_attributes= []
                           ; _ }
@@ -1735,7 +1736,8 @@ end = struct
           ({txt= Lident "::"; _}, Some {pexp_desc= Pexp_tuple _; _}) ->
           Some ColonColon
       | Pexp_construct (_, Some _) -> Some Apply
-      | Pexp_constant (Pconst_integer (i, _) | Pconst_float (i, _)) -> (
+      | Pexp_constant
+          {pconst_desc= Pconst_integer (i, _) | Pconst_float (i, _); _} -> (
         match i.[0] with '-' | '+' -> Some UMinus | _ -> Some Atomic )
       | Pexp_apply ({pexp_desc= Pexp_ident {txt= Lident i; loc; _}; _}, [_])
         -> (
@@ -2276,7 +2278,8 @@ end = struct
     (* Integers without suffixes must be parenthesised on the lhs of an
        indexing operator *)
     | ( Exp {pexp_desc= Pexp_apply (op, (Nolabel, left) :: _); _}
-      , {pexp_desc= Pexp_constant (Pconst_integer (_, None)); _} )
+      , { pexp_desc= Pexp_constant {pconst_desc= Pconst_integer (_, None); _}
+        ; _ } )
       when exp == left && Exp.is_index_op op ->
         true
     | Exp {pexp_desc= Pexp_field (e, _); _}, {pexp_desc= Pexp_construct _; _}

lib/Cmts.ml

@@ -304,7 +304,7 @@ let relocate_ext_cmts (t : t) src ((_pre : string Location.loc), pld)
   | PStr
       [ { pstr_desc=
             Pstr_eval
-              ( { pexp_desc= Pexp_constant (Pconst_string _)
+              ( { pexp_desc= Pexp_constant {pconst_desc= Pconst_string _; _}
                 ; pexp_loc= _
                 ; pexp_loc_stack= _
                 ; pexp_attributes= _ }
@@ -349,7 +349,7 @@ let init fragment ~debug source asts comments_n_docstrings =
   in
   let comments = Normalize.dedup_cmts fragment asts comments_n_docstrings in
   if not (List.is_empty comments) then (
-    let loc_tree, locs = Loc_tree.of_ast fragment asts source in
+    let loc_tree, locs = Loc_tree.of_ast fragment asts in
     if debug then
       List.iter locs ~f:(fun loc ->
           if not (Location.compare loc Location.none = 0) then

lib/Conf.ml

@@ -2249,7 +2249,9 @@ let update ?(quiet = false) c {attr_name= {txt; loc}; attr_payload; _} =
       | PStr
           [ { pstr_desc=
                 Pstr_eval
-                  ( { pexp_desc= Pexp_constant (Pconst_string (str, _, None))
+                  ( { pexp_desc=
+                        Pexp_constant
+                          {pconst_desc= Pconst_string (str, _, None); _}
                     ; pexp_attributes= []
                     ; _ }
                   , [] )

lib/Fmt_ast.ml

@@ -239,10 +239,10 @@ let fmt_str_loc c ?pre {txt; loc} = Cmts.fmt c loc (fmt_opt pre $ str txt)
 let fmt_str_loc_opt c ?pre ?(default = "_") {txt; loc} =
   Cmts.fmt c loc (fmt_opt pre $ str (Option.value ~default txt))
 
-let fmt_constant c ~loc ?epi const =
+let fmt_constant c ?epi {pconst_desc; pconst_loc= loc} =
   Cmts.fmt c loc
   @@
-  match const with
+  match pconst_desc with
   | Pconst_integer (lit, suf) | Pconst_float (lit, suf) ->
       str lit $ opt suf char
   | Pconst_char _ -> wrap "'" "'" @@ str (Source.char_literal c.source loc)
@@ -502,7 +502,9 @@ let rec fmt_extension c ctx key (ext, pld) =
     , PStr
         [ { pstr_desc=
               Pstr_eval
-                ( { pexp_desc= Pexp_constant (Pconst_string (str, loc, delim))
+                ( { pexp_desc=
+                      Pexp_constant
+                        {pconst_desc= Pconst_string (str, loc, delim); _}
                   ; pexp_loc
                   ; pexp_loc_stack= _
                   ; pexp_attributes= [] }
@@ -543,7 +545,9 @@ and fmt_attribute c ~key {attr_name; attr_payload; attr_loc} =
     , PStr
         [ { pstr_desc=
               Pstr_eval
-                ( { pexp_desc= Pexp_constant (Pconst_string (doc, _, None))
+                ( { pexp_desc=
+                      Pexp_constant
+                        {pconst_desc= Pconst_string (doc, _, None); _}
                   ; pexp_attributes= []
                   ; _ }
                 , [] )
@@ -952,11 +956,8 @@ and fmt_pattern ?ext c ?pro ?parens ?(box = false)
            $ fmt "@ as@ "
            $ Cmts.fmt c loc
                (wrap_if (String_id.is_symbol txt) "( " " )" (str txt)) ) )
-  | Ppat_constant const ->
-      fmt_constant c ~loc:(Source.loc_of_pat_constant c.source pat) const
-  | Ppat_interval (l, u) ->
-      let loc1, loc2 = Source.locs_of_interval c.source ppat_loc in
-      fmt_constant ~loc:loc1 c l $ str " .. " $ fmt_constant ~loc:loc2 c u
+  | Ppat_constant const -> fmt_constant c const
+  | Ppat_interval (l, u) -> fmt_constant c l $ str " .. " $ fmt_constant c u
   | Ppat_tuple pats ->
       let parens = parens || Poly.(c.conf.parens_tuple_patterns = `Always) in
       hvbox 0
@@ -1069,7 +1070,9 @@ and fmt_pattern ?ext c ?pro ?parens ?(box = false)
       let xpats = Sugar.or_pat c.cmts xpat in
       let space p =
         match p.ppat_desc with
-        | Ppat_constant (Pconst_integer (i, _) | Pconst_float (i, _)) -> (
+        | Ppat_constant
+            {pconst_desc= Pconst_integer (i, _) | Pconst_float (i, _); _}
+          -> (
           match i.[0] with '-' | '+' -> true | _ -> false )
         | _ -> false
       in
@@ -1966,11 +1969,10 @@ and fmt_expression c ?(box = true) ?pro ?epi ?eol ?parens ?(indent_wrap = 0)
               $ fmt_if_k paren_body (closing_paren c)
               $ fmt_atrs ) ) )
   | Pexp_constant const ->
-      let loc = Source.loc_of_expr_constant c.source exp in
       Params.parens_if
         (parens || not (List.is_empty pexp_attributes))
         c.conf
-        (fmt_constant c ~loc ?epi const $ fmt_atrs)
+        (fmt_constant c ?epi const $ fmt_atrs)
   | Pexp_constraint
       ( {pexp_desc= Pexp_pack me; pexp_attributes= []; pexp_loc; _}
       , {ptyp_desc= Ptyp_package (id, cnstrs); ptyp_attributes= []; _} ) ->

lib/Indent.ml

@@ -52,10 +52,10 @@ module Valid_ast = struct
     | Unequal_lengths ->
         impossible "Cannot match pre-post formatting locations."
 
-  let indent_range fragment ~unformatted:(ast, src, txt_src)
+  let indent_range fragment ~unformatted:(ast, txt_src)
       ~formatted:(fmted_ast, fmted_src) ~lines ~range:(low, high) =
-    let loctree, locs = Loc_tree.of_ast fragment ast src in
-    let _, locs' = Loc_tree.of_ast fragment fmted_ast fmted_src in
+    let loctree, locs = Loc_tree.of_ast fragment ast in
+    let _, locs' = Loc_tree.of_ast fragment fmted_ast in
     let indent_line i =
       match loc_of_line loctree locs i with
       | Some loc -> (

lib/Indent.mli

@@ -12,7 +12,7 @@
 module Valid_ast : sig
   val indent_range :
        'a Extended_ast.t
-    -> unformatted:'a * Source.t * string
+    -> unformatted:'a * string
     -> formatted:'a * Source.t
     -> lines:string list
     -> range:int * int

lib/Loc_tree.ml

@@ -14,7 +14,7 @@ open Extended_ast
 include Non_overlapping_interval_tree.Make (Location)
 
 (** Use Ast_mapper to collect all locs in ast, and create tree of them. *)
-let of_ast fragment ast src =
+let of_ast fragment ast =
   let attribute (m : Ast_mapper.mapper) attr =
     (* ignore location of docstrings *)
     if Ast.Attr.is_doc attr then attr
@@ -25,20 +25,6 @@ let of_ast fragment ast src =
     locs := loc :: !locs ;
     loc
   in
-  let pat m p =
-    ( match p.ppat_desc with
-    | Ppat_constant _ -> locs := Source.loc_of_pat_constant src p :: !locs
-    | _ -> () ) ;
-    Ast_mapper.default_mapper.pat m p
-  in
-  let expr m e =
-    ( match e.pexp_desc with
-    | Pexp_constant _ -> locs := Source.loc_of_expr_constant src e :: !locs
-    | _ -> () ) ;
-    Ast_mapper.default_mapper.expr m e
-  in
-  let mapper =
-    Ast_mapper.{default_mapper with location; pat; attribute; expr}
-  in
+  let mapper = Ast_mapper.{default_mapper with location; attribute} in
   map fragment mapper ast |> ignore ;
   (of_list !locs, !locs)

lib/Loc_tree.mli

@@ -11,5 +11,5 @@
 
 include Non_overlapping_interval_tree.S with type itv = Location.t
 
-val of_ast : 'a Extended_ast.t -> 'a -> Source.t -> t * Location.t list
+val of_ast : 'a Extended_ast.t -> 'a -> t * Location.t list
 (** Use Ast_mapper to collect all locs in ast, and create a tree of them. *)

lib/Normalize.ml

@@ -31,7 +31,8 @@ let dedup_cmts fragment ast comments =
               [ { pstr_desc=
                     Pstr_eval
                       ( { pexp_desc=
-                            Pexp_constant (Pconst_string (doc, _, None))
+                            Pexp_constant
+                              {pconst_desc= Pconst_string (doc, _, None); _}
                         ; pexp_loc
                         ; _ }
                       , [] )

lib/Source.ml

@@ -146,53 +146,13 @@ let is_long_pmty_functor t {pmty_desc; pmty_loc= from; _} =
   | Pmty_functor (fp, _) -> is_long_functor_syntax t ~from fp
   | _ -> false
 
-let string_literal t mode (l : Location.t) =
-  (* the location of a [string] might include surrounding comments and
-     attributes because of [reloc_{exp,pat}] and a [string] can be found in
-     attributes payloads. {[ f ((* comments *) "c" [@attributes]) ]} *)
-  let toks =
-    tokens_at t
-      ~filter:(function
-        | Parser.STRING (_, _, None) -> true
-        | Parser.LBRACKETAT | Parser.LBRACKETATAT | Parser.LBRACKETATATAT ->
-            true
-        | _ -> false )
-      l
-  in
-  match toks with
-  | [(Parser.STRING (_, _, None), loc)]
-   |(Parser.STRING (_, _, None), loc)
-    :: ( Parser.LBRACKETATATAT, _
-       | Parser.LBRACKETATAT, _
-       | Parser.LBRACKETAT, _ )
-       :: _ ->
-      Option.value_exn ~message:"Parse error while reading string literal"
-        (Literal_lexer.string mode (string_at t loc))
-  | _ -> impossible "Pconst_string is only produced by string literals"
+let string_literal t mode loc =
+  Option.value_exn ~message:"Parse error while reading string literal"
+    (Literal_lexer.string mode (string_at t loc))
 
-let char_literal t (l : Location.t) =
-  (* the location of a [char] might include surrounding comments and
-     attributes because of [reloc_{exp,pat}] and a [char] can be found in
-     attributes payloads. {[ f ((* comments *) 'c' [@attributes]) ]} *)
-  let toks =
-    tokens_at t
-      ~filter:(function
-        | Parser.CHAR _ -> true
-        | Parser.LBRACKETAT | Parser.LBRACKETATAT | Parser.LBRACKETATATAT ->
-            true
-        | _ -> false )
-      l
-  in
-  match toks with
-  | [(Parser.CHAR _, loc)]
-   |(Parser.CHAR _, loc)
-    :: ( Parser.LBRACKETATATAT, _
-       | Parser.LBRACKETATAT, _
-       | Parser.LBRACKETAT, _ )
-       :: _ ->
-      (Option.value_exn ~message:"Parse error while reading char literal")
-        (Literal_lexer.char (string_at t loc))
-  | _ -> impossible "Pconst_char is only produced by char literals"
+let char_literal t loc =
+  Option.value_exn ~message:"Parse error while reading char literal"
+    (Literal_lexer.char (string_at t loc))
 
 let begins_line ?(ignore_spaces = true) t (l : Location.t) =
   if not ignore_spaces then Position.column l.loc_start = 0
@@ -227,44 +187,6 @@ let extension_using_sugar ~(name : string Location.loc)
 let type_constraint_is_first typ loc =
   Location.compare_start typ.ptyp_loc loc < 0
 
-let locs_of_interval source loc =
-  let toks =
-    tokens_at source loc ~filter:(function
-      | CHAR _ | DOTDOT | INT _ | STRING _ | FLOAT _ -> true
-      | _ -> false )
-  in
-  match toks with
-  | [ ((CHAR _ | INT _ | STRING _ | FLOAT _), loc1)
-    ; (DOTDOT, _)
-    ; ((CHAR _ | INT _ | STRING _ | FLOAT _), loc2) ] ->
-      (loc1, loc2)
-  | _ ->
-      impossible
-        "Ppat_interval is only produced by the sequence of 3 tokens: \
-         CONSTANT-DOTDOT-CONSTANT "
-
-let loc_of_constant t loc (cst : constant) =
-  let filter : Parser.token -> bool =
-    match cst with
-    | Pconst_string _ -> ( function STRING _ -> true | _ -> false )
-    | Pconst_char _ -> ( function CHAR _ -> true | _ -> false )
-    | Pconst_integer _ -> ( function INT _ -> true | _ -> false )
-    | Pconst_float _ -> ( function FLOAT _ -> true | _ -> false )
-  in
-  match tokens_at t loc ~filter with [(_, loc)] -> loc | _ -> loc
-
-let loc_of_pat_constant t (p : pattern) =
-  match p.ppat_desc with
-  | Ppat_constant cst ->
-      loc_of_constant t (Location.smallest p.ppat_loc p.ppat_loc_stack) cst
-  | _ -> impossible "loc_of_pat_constant is only called on constants"
-
-let loc_of_expr_constant t (e : expression) =
-  match e.pexp_desc with
-  | Pexp_constant cst ->
-      loc_of_constant t (Location.smallest e.pexp_loc e.pexp_loc_stack) cst
-  | _ -> impossible "loc_of_expr_constant is only called on constants"
-
 let is_quoted_string t loc =
   let toks =
     tokens_at t loc ~filter:(function