Get attr_replace test running

Signed-off-by: Jack Rickard <[email protected]>

Author: Skepfyr

src/context_free.ml

@@ -527,6 +527,25 @@ let rec handle_attr_replace_fix context attrs item base_ctxt =
   | Some item -> handle_attr_replace_fix context attrs item base_ctxt
   | None -> return item
 
+let rec handle_attr_replace_str attrs item base_ctxt =
+  (match item.pstr_desc with
+  | Pstr_extension _ ->
+      handle_attr_replace_once AC.Pstr_extension attrs item base_ctxt
+  | Pstr_eval _ -> handle_attr_replace_once AC.Pstr_eval attrs item base_ctxt
+  | _ -> return None)
+  >>= function
+  | Some item -> handle_attr_replace_str attrs item base_ctxt
+  | None -> return item
+
+let rec handle_attr_replace_sig attrs item base_ctxt =
+  (match item.psig_desc with
+  | Psig_extension _ ->
+      handle_attr_replace_once AC.Psig_extension attrs item base_ctxt
+  | _ -> return None)
+  >>= function
+  | Some item -> handle_attr_replace_sig attrs item base_ctxt
+  | None -> return item
+
 (* Returns the code generated by attribute handlers. We don't remove these attributes, as
    another pass might interpret them later. For instance both ppx_deriving and
    ppxlib_deriving interprets [@@deriving] attributes.
@@ -997,20 +1016,8 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop)
         match st with
         | [] -> return []
         | item :: rest -> (
-            let rec fix item =
-              (match item.pstr_desc with
-              | Pstr_extension _ ->
-                  handle_attr_replace_once AC.Pstr_extension
-                    attr_structure_item_replaces item base_ctxt
-              | Pstr_eval _ ->
-                  handle_attr_replace_once AC.Pstr_eval
-                    attr_structure_item_replaces item base_ctxt
-              | _ -> return None)
-              >>= function
-              | Some item -> fix item
-              | None -> return item
-            in
-            fix item >>= fun item ->
+            handle_attr_replace_str attr_structure_item_replaces item base_ctxt
+            >>= fun item ->
             let loc = item.pstr_loc in
             match item.pstr_desc with
             | Pstr_extension (ext, attrs) -> (
@@ -1142,17 +1149,8 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop)
         match sg with
         | [] -> return []
         | item :: rest -> (
-            let rec fix item =
-              (match item.psig_desc with
-              | Psig_extension _ ->
-                  handle_attr_replace_once AC.Psig_extension
-                    attr_signature_item_replaces item base_ctxt
-              | _ -> return None)
-              >>= function
-              | Some item -> fix item
-              | None -> return item
-            in
-            fix item >>= fun item ->
+            handle_attr_replace_sig attr_signature_item_replaces item base_ctxt
+            >>= fun item ->
             let loc = item.psig_loc in
             match item.psig_desc with
             | Psig_extension (ext, attrs) -> (

test/attr_replace/dune

@@ -1,4 +1,12 @@
-(library
- (name ppxlib_test_attr_replace)
- (preprocess
-  (pps ppxlib_test_attr_replace_ppx)))
+(rule
+ (deps test.ml)
+ (targets test.output.ml)
+ (action
+  (with-stdout-to
+   %{targets}
+   (run ./ppx/ppx_attr_replace.exe %{deps}))))
+
+(rule
+ (alias runtest)
+ (action
+  (diff test.expected.ml test.output.ml)))

test/attr_replace/ppx/dune

@@ -1,4 +1,6 @@
-(library
- (name ppxlib_test_attr_replace_ppx)
- (kind ppx_rewriter)
- (libraries ppxlib))
+(executable
+ (name ppx_attr_replace)
+ (modules ppx_attr_replace)
+ (libraries ppxlib)
+ (preprocess
+  (pps ppxlib.metaquot)))

test/attr_replace/ppx/ppxlib_test_attr_replace_ppx.ml renamed to test/attr_replace/ppx/ppx_attr_replace.ml

@@ -300,3 +300,5 @@ let () =
                let loc = { loc with loc_ghost = true } in
                [%stri let foo = ()]));
       ]
+
+let () = Driver.standalone ()

test/attr_replace/ppx/ppxlib_test_attr_replace_ppx.mli

@@ -0,0 +1,24 @@
+class c__suffix = object  end
+class type ct__suffix = object  end
+type t__suffix = unit
+let foo__suffix () = ()
+module M__suffix = struct  end
+module type S__suffix  = sig  end
+let prefix_foo_suffix = ()
+class class_ = c__suffix
+class class_field =
+  object val foo__suffix = ()[@@alert "-1"][@@alert "-2"] end
+class type class_type = ct__suffix
+class type class_type_field =
+  object val  x__suffix : int[@@alert "-1"][@@alert "-2"] end
+let _ = ()
+let _e = ()
+let _ = ((foo__suffix)[@alert "-1"][@alert "-2"])
+let _ = ((foo__suffix)[@alert "-1"][@alert "-2"]) ()
+include ((M__suffix)[@alert "-1"][@alert "-2"])
+module F : ((S__suffix)[@alert "-1"][@alert "-2"]) = struct  end 
+let _ = match () with | a__suffix -> ignore a__suffix
+module type S  = sig val foo : unit end
+let foo = ()
+module _ = struct ;;"" end
+let _ = ((prefix_foo_suffix)[@alert "-1"][@alert "-2"][@alert "-3"])

test/attr_replace/test.expected.ml

@@ -12,124 +12,47 @@ module type S__suffix = sig end
 
 let prefix_foo_suffix = ()
 
-[@@@expand_inline class class_ = c [@test.clx "suffix"]]
+class class_ = c [@test.clx "suffix"]
 
-class class_ = c__suffix
-
-[@@@end]
-
-[@@@expand_inline
 class class_field =
   object
     val foo = () [@@alert "-1"] [@@test.clf "suffix"] [@@alert "-2"]
-  end]
-
-class class_field =
-  object
-    val foo__suffix = () [@@alert "-1"] [@@alert "-2"]
   end
 
-[@@@end]
-[@@@expand_inline class type class_type = ct[@test.clt "suffix"]]
+class type class_type = ct[@test.clt "suffix"]
 
-class type class_type = ct__suffix
-
-[@@@end]
-
-[@@@expand_inline
 class type class_type_field = object
   val x : int [@@alert "-1"] [@@test.ctf "suffix"] [@@alert "-2"]
-end]
-
-class type class_type_field = object
-  val x__suffix : int [@@alert "-1"] [@@alert "-2"]
 end
 
-[@@@end]
-
-[@@@expand_inline
-let _ : (t[@alert "-1"] [@test.typ "suffix"] [@alert "-2"]) = ()]
-
-let _ : (t__suffix[@alert "-1"] [@alert "-2"]) = ()
-
-[@@@end]
-[@@@expand_inline let _e : (t[@test.typ "suffix"]) = ()]
-
-let _e : t__suffix = ()
-
-[@@@end]
-[@@@expand_inline let _ = foo [@alert "-1"] [@test.exp "suffix"] [@alert "-2"]]
-
-let _ = foo__suffix [@alert "-1"] [@alert "-2"]
-
-[@@@end]
+let _ : (t[@alert "-1"] [@test.typ "suffix"] [@alert "-2"]) = ()
+let _e : (t[@test.typ "suffix"]) = ()
+let _ = foo [@alert "-1"] [@test.exp "suffix"] [@alert "-2"]
 
 (* Explicit test for the ident in a function application because it acts differently due
    to "special functions". *)
-[@@@expand_inline
-let _ = (foo [@alert "-1"] [@test.exp "suffix"] [@alert "-2"]) ()]
-
-let _ = (foo__suffix [@alert "-1"] [@alert "-2"]) ()
 
-[@@@end]
+let _ = (foo [@alert "-1"] [@test.exp "suffix"] [@alert "-2"]) ()
 
-[@@@expand_inline
-include M [@alert "-1"] [@test.mod_exp "suffix"] [@alert "-2"]]
+include M [@alert "-1"] [@test.mod_exp "suffix"] [@alert "-2"]
+module F : S [@alert "-1"] [@test.mod_typ "suffix"] [@alert "-2"] = struct end
 
-include M__suffix [@alert "-1"] [@alert "-2"]
+let _ = match () with (a [@test.pat "suffix"]) -> ignore a__suffix
 
-[@@@end]
-
-[@@@expand_inline
-module F : S [@alert "-1"] [@test.mod_typ "suffix"] [@alert "-2"] = struct end]
-
-module F : S__suffix [@alert "-1"] [@alert "-2"] = struct end
-
-[@@@end]
-
-[@@@expand_inline
-let _ = match () with (a [@test.pat "suffix"]) -> ignore a__suffix]
-
-let _ = match () with a__suffix -> ignore a__suffix
-
-[@@@end]
-
-[@@@expand_inline
 module type S = sig
   [%%foo] [@@test.sig.ext "suffix"]
-end]
-
-module type S = sig
-  val foo : unit
 end
 
-[@@@end]
-[@@@expand_inline [%%foo] [@@test.str.ext "suffix"]]
-
-let foo = ()
+[%%foo] [@@test.str.ext "suffix"]
 
-[@@@end]
-
-[@@@expand_inline
 module _ = struct
   "" [@@test.str.evl "suffix"]
-end]
-
-module _ = struct
-  ""
 end
 
-[@@@end]
-
-[@@@expand_inline
 let _ =
   foo
   [@alert "-1"]
   [@suffix "_suffix"]
   [@alert "-2"]
   [@prefix "prefix_"]
-  [@alert "-3"]]
-
-let _ = prefix_foo_suffix [@alert "-1"] [@alert "-2"] [@alert "-3"]
-
-[@@@end]
+  [@alert "-3"]