Fix hash used by Attribute.get

CHANGES.md

@@ -1,6 +1,8 @@
 unreleased
 -------------------
 
+- Update `Attribute.get` to ignore `loc_ghost`. (#460, @ceastlund)
+
 - Add API to manipulate attributes that are used as flags (#408, @dianaoigo)
 
 - Update changelog to use ISO 8061 date format: YYYY-MM-DD. (#445, @ceastlund)

src/attribute.ml

@@ -307,8 +307,9 @@ let declare_flag name context =
 module Attribute_table = Stdlib.Hashtbl.Make (struct
   type t = string loc
 
-  let hash : t -> int = Hashtbl.hash
-  let equal : t -> t -> bool = Poly.equal
+  let normalize t = { t with loc = { t.loc with loc_ghost = true } }
+  let hash t = Hashtbl.hash (normalize t)
+  let equal x y = Poly.equal (normalize x) (normalize y)
 end)
 
 let not_seen = Attribute_table.create 128

test/driver/attributes/test.ml

@@ -177,28 +177,88 @@ let flag = Attribute.declare_flag "flag" Attribute.Context.expression
 val flag : expression Attribute.flag = <abstr>
 |}]
 
-let replace_flagged = object
-  inherit Ast_traverse.map as super
+let extend name f =
+  let ext =
+    Extension.V3.declare
+      name
+      Expression
+      Ast_pattern.(single_expr_payload __)
+      (fun ~ctxt:_ e -> f e)
+  in
+  Driver.register_transformation name ~rules:[ Context_free.Rule.extension ext ]
+[%%expect{|
+val extend : string -> (expression -> expression) -> unit = <fun>
+|}]
 
-  method! expression e =
-    match Attribute.has_flag_res flag e with
-    | Ok true -> Ast_builder.Default.estring ~loc:e.pexp_loc "Found flag"
-    | Ok false -> super#expression e
-    | Error (err, _) -> Ast_builder.Default.estring ~loc:e.pexp_loc (Location.Error.message err)
+let () =
+  extend "flagged" (fun e ->
+    if Attribute.has_flag flag e
+    then e
+    else Location.raise_errorf ~loc:e.pexp_loc "flag not found")
+
+let e1 = [%flagged "Absent flag"]
+[%%expect{|
+Line _, characters 19-32:
+Error: flag not found
+|}]
+
+let e2 = [%flagged "Found flag" [@flag]]
+[%%expect{|
+val e2 : string = "Found flag"
+|}]
+
+let e3 = [%flagged "Misused flag" [@flag 12]]
+[%%expect{|
+Line _, characters 41-43:
+Error: [] expected
+|}]
+
+(* Testing attribute in trivial transformation *)
+
+open Ast_builder.Default
+
+let flagged e =
+  let loc = e.pexp_loc in
+  pexp_extension ~loc ({ loc; txt = "flagged" }, PStr [pstr_eval ~loc e []])
+[%%expect{|
+val flagged : expression -> expression = <fun>
+|}]
+
+let () = extend "simple" flagged
+
+let e = [%simple "flagged" [@flag]]
+[%%expect{|
+val e : string = "flagged"
+|}]
+
+(* When duplicating code, apply [ghost] to all but one copy. *)
+
+let ghost = object
+  inherit Ast_traverse.map
+  method! location l = { l with loc_ghost = true }
 end
 [%%expect{|
-val replace_flagged : Ast_traverse.map = <obj>
+val ghost : Ast_traverse.map = <obj>
 |}]
 
+(* Test attribute lookup in non-ghosted subexpression. *)
+
 let () =
-  Driver.register_transformation "" ~impl:replace_flagged#structure
+  extend "flag_alive" (fun e ->
+    pexp_tuple ~loc:e.pexp_loc [ flagged e; ghost#expression e ])
 
-let e1 = "flagged" [@flag]
+let e = [%flag_alive "hello" [@flag]]
 [%%expect{|
-val e1 : string = "Found flag"
+val e : string * string = ("hello", "hello")
 |}]
 
-let e1 = "flagged" [@flag 12]
+(* Test attribute lookup in ghosted subexpression. *)
+
+let () =
+  extend "flag_ghost" (fun e ->
+    pexp_tuple ~loc:e.pexp_loc [ e; flagged (ghost#expression e) ])
+
+let e = [%flag_ghost "bye" [@flag]]
 [%%expect{|
-val e1 : string = "[] expected"
+val e : string * string = ("bye", "bye")
 |}]

test/driver/attributes/test_510.ml

@@ -201,31 +201,97 @@ let flag = Attribute.declare_flag "flag" Attribute.Context.expression
 val flag : expression Attribute.flag = <abstr>
 |}]
 
-let replace_flagged = object
-  inherit Ast_traverse.map as super
+let extend name f =
+  let ext =
+    Extension.V3.declare
+      name
+      Expression
+      Ast_pattern.(single_expr_payload __)
+      (fun ~ctxt:_ e -> f e)
+  in
+  Driver.register_transformation name ~rules:[ Context_free.Rule.extension ext ]
+[%%expect{|
 
-  method! expression e =
-    match Attribute.has_flag_res flag e with
-    | Ok true -> Ast_builder.Default.estring ~loc:e.pexp_loc "Found flag"
-    | Ok false -> super#expression e
-    | Error (err, _) -> Ast_builder.Default.estring ~loc:e.pexp_loc (Location.Error.message err)
+val extend : string -> (expression -> expression) -> unit = <fun>
+|}]
+
+let () =
+  extend "flagged" (fun e ->
+    if Attribute.has_flag flag e
+    then e
+    else Location.raise_errorf ~loc:e.pexp_loc "flag not found")
+
+let e1 = [%flagged "Absent flag"]
+[%%expect{|
+
+Line _, characters 19-32:
+Error: flag not found
+|}]
+
+let e2 = [%flagged "Found flag" [@flag]]
+[%%expect{|
+
+val e2 : string = "Found flag"
+|}]
+
+let e3 = [%flagged "Misused flag" [@flag 12]]
+[%%expect{|
+
+Line _, characters 41-43:
+Error: [] expected
+|}]
+
+(* Testing attribute in trivial transformation *)
+
+open Ast_builder.Default
+
+let flagged e =
+  let loc = e.pexp_loc in
+  pexp_extension ~loc ({ loc; txt = "flagged" }, PStr [pstr_eval ~loc e []])
+[%%expect{|
+
+val flagged : expression -> expression = <fun>
+|}]
+
+let () = extend "simple" flagged
+
+let e = [%simple "flagged" [@flag]]
+[%%expect{|
+
+val e : string = "flagged"
+|}]
+
+(* When duplicating code, apply [ghost] to all but one copy. *)
+
+let ghost = object
+  inherit Ast_traverse.map
+  method! location l = { l with loc_ghost = true }
 end
 [%%expect{|
 
-val replace_flagged : Ast_traverse.map = <obj>
+val ghost : Ast_traverse.map = <obj>
 |}]
 
+(* Test attribute lookup in non-ghosted subexpression. *)
+
 let () =
-  Driver.register_transformation "" ~impl:replace_flagged#structure
+  extend "flag_alive" (fun e ->
+    pexp_tuple ~loc:e.pexp_loc [ flagged e; ghost#expression e ])
 
-let e1 = "flagged" [@flag]
+let e = [%flag_alive "hello" [@flag]]
 [%%expect{|
 
-val e1 : string = "Found flag"
+val e : string * string = ("hello", "hello")
 |}]
 
-let e1 = "flagged" [@flag 12]
+(* Test attribute lookup in ghosted subexpression. *)
+
+let () =
+  extend "flag_ghost" (fun e ->
+    pexp_tuple ~loc:e.pexp_loc [ e; flagged (ghost#expression e) ])
+
+let e = [%flag_ghost "bye" [@flag]]
 [%%expect{|
 
-val e1 : string = "[] expected"
+val e : string * string = ("bye", "bye")
 |}]