unikernel/duniverse/ppxlib/test/attr_replace/driver.ml

@@ -0,0 +1,285 @@
+open Ppxlib
+
+let string_pattern = Ast_pattern.(single_expr_payload (estring __))
+
+let template_class_expr ~ctxt:_ class_expr payload =
+  match class_expr.pcl_desc with
+  | Pcl_constr ({ txt = Lident name; loc }, args) ->
+      {
+        class_expr with
+        pcl_desc =
+          Pcl_constr ({ txt = Lident (name ^ "__" ^ payload); loc }, args);
+      }
+  | _ -> class_expr
+
+let () =
+  Driver.register_transformation "test.clx"
+    ~rules:
+      [
+        Context_free.Rule.attr_replace "test.clx" Extension.Context.class_expr
+          (Attribute.declare "test.clx" Class_expr string_pattern Fun.id)
+          template_class_expr;
+      ]
+
+let template_class_field ~ctxt:_ class_field payload =
+  match class_field.pcf_desc with
+  | Pcf_val ({ txt = name; loc }, flag, kind) ->
+      {
+        class_field with
+        pcf_desc = Pcf_val ({ txt = name ^ "__" ^ payload; loc }, flag, kind);
+      }
+  | _ -> class_field
+
+let () =
+  Driver.register_transformation "test.clf"
+    ~rules:
+      [
+        Context_free.Rule.attr_replace "test.clf" Extension.Context.class_field
+          (Attribute.declare "test.clf" Class_field string_pattern Fun.id)
+          template_class_field;
+      ]
+
+let template_class_type ~ctxt:_ class_type payload =
+  match class_type.pcty_desc with
+  | Pcty_constr ({ txt = Lident name; loc }, args) ->
+      {
+        class_type with
+        pcty_desc =
+          Pcty_constr ({ txt = Lident (name ^ "__" ^ payload); loc }, args);
+      }
+  | _ -> class_type
+
+let () =
+  Driver.register_transformation "test.clt"
+    ~rules:
+      [
+        Context_free.Rule.attr_replace "test.clt" Extension.Context.class_type
+          (Attribute.declare "test.clt" Class_type string_pattern Fun.id)
+          template_class_type;
+      ]
+
+let template_class_type_field ~ctxt:_ class_type_field payload =
+  match class_type_field.pctf_desc with
+  | Pctf_val ({ txt = name; loc }, mut_flag, virt_flag, ty) ->
+      {
+        class_type_field with
+        pctf_desc =
+          Pctf_val
+            ({ txt = name ^ "__" ^ payload; loc }, mut_flag, virt_flag, ty);
+      }
+  | _ -> class_type_field
+
+let () =
+  Driver.register_transformation "test.ctf"
+    ~rules:
+      [
+        Context_free.Rule.attr_replace "test.ctf"
+          Extension.Context.class_type_field
+          (Attribute.declare "test.ctf" Class_type_field string_pattern Fun.id)
+          template_class_type_field;
+      ]
+
+let template_core_type ~ctxt:_ core_type payload =
+  match core_type.ptyp_desc with
+  | Ptyp_constr ({ txt = Lident name; loc }, args) ->
+      {
+        core_type with
+        ptyp_desc =
+          Ptyp_constr ({ txt = Lident (name ^ "__" ^ payload); loc }, args);
+      }
+  | _ -> core_type
+
+let () =
+  Driver.register_transformation "test.typ"
+    ~rules:
+      [
+        Context_free.Rule.attr_replace "test.typ" Extension.Context.core_type
+          (Attribute.declare "test.typ" Core_type string_pattern Fun.id)
+          template_core_type;
+      ]
+
+let template_expression ~ctxt:_ expression payload =
+  match expression.pexp_desc with
+  | Pexp_ident { txt = Lident name; loc } ->
+      {
+        expression with
+        pexp_desc = Pexp_ident { txt = Lident (name ^ "__" ^ payload); loc };
+      }
+  | _ -> expression
+
+let () =
+  Driver.register_transformation "test.exp"
+    ~rules:
+      [
+        Context_free.Rule.attr_replace "test.exp" Extension.Context.expression
+          (Attribute.declare "test.exp" Expression string_pattern Fun.id)
+          template_expression;
+      ]
+
+let template_module_expr ~ctxt:_ module_expr payload =
+  match module_expr.pmod_desc with
+  | Pmod_ident { txt = Lident name; loc } ->
+      {
+        module_expr with
+        pmod_desc = Pmod_ident { txt = Lident (name ^ "__" ^ payload); loc };
+      }
+  | _ -> module_expr
+
+let () =
+  Driver.register_transformation "test.mod_exp"
+    ~rules:
+      [
+        Context_free.Rule.attr_replace "test.mod_exp"
+          Extension.Context.module_expr
+          (Attribute.declare "test.mod_exp" Module_expr string_pattern Fun.id)
+          template_module_expr;
+      ]
+
+let template_module_type ~ctxt:_ module_type payload =
+  match module_type.pmty_desc with
+  | Pmty_ident { txt = Lident name; loc } ->
+      {
+        module_type with
+        pmty_desc = Pmty_ident { txt = Lident (name ^ "__" ^ payload); loc };
+      }
+  | _ -> module_type
+
+let () =
+  Driver.register_transformation "test.mod_typ"
+    ~rules:
+      [
+        Context_free.Rule.attr_replace "test.mod_typ"
+          Extension.Context.module_type
+          (Attribute.declare "test.mod_typ" Module_type string_pattern Fun.id)
+          template_module_type;
+      ]
+
+let template_pattern ~ctxt:_ pattern payload =
+  match pattern.ppat_desc with
+  | Ppat_var { txt = name; loc } ->
+      { pattern with ppat_desc = Ppat_var { txt = name ^ "__" ^ payload; loc } }
+  | _ -> pattern
+
+let () =
+  Driver.register_transformation "test.pat"
+    ~rules:
+      [
+        Context_free.Rule.attr_replace "test.pat" Extension.Context.pattern
+          (Attribute.declare "test.pat" Pattern string_pattern Fun.id)
+          template_pattern;
+      ]
+
+let template_sig_extension ~ctxt:_ sig_item payload =
+  match sig_item.psig_desc with
+  | Psig_extension ((ext, inner_payload), attrs) ->
+      {
+        sig_item with
+        psig_desc =
+          Psig_extension
+            (({ ext with txt = ext.txt ^ "__" ^ payload }, inner_payload), attrs);
+      }
+  | _ -> assert false
+
+let () =
+  Driver.register_transformation "test.sig.ext"
+    ~rules:
+      [
+        Context_free.Rule.attr_replace "test.sig.ext"
+          Extension.Context.signature_item
+          (Attribute.declare "test.sig.ext" Psig_extension string_pattern Fun.id)
+          template_sig_extension;
+      ]
+
+let template_str_extension ~ctxt:_ structure_item payload =
+  match structure_item.pstr_desc with
+  | Pstr_extension ((ext, inner_payload), attrs) ->
+      {
+        structure_item with
+        pstr_desc =
+          Pstr_extension
+            (({ ext with txt = ext.txt ^ "__" ^ payload }, inner_payload), attrs);
+      }
+  | _ -> assert false
+
+let () =
+  Driver.register_transformation "test.str.ext"
+    ~rules:
+      [
+        Context_free.Rule.attr_replace "test.str.ext"
+          Extension.Context.structure_item
+          (Attribute.declare "test.str.ext" Pstr_extension string_pattern Fun.id)
+          template_str_extension;
+      ]
+
+let template_str_eval ~ctxt:_ structure_item payload =
+  match structure_item.pstr_desc with
+  | Pstr_eval (expression, attributes) ->
+      let expression =
+        match expression.pexp_desc with
+        | Pexp_ident { txt = Lident name; loc } ->
+            {
+              expression with
+              pexp_desc =
+                Pexp_ident { txt = Lident (name ^ "__" ^ payload); loc };
+            }
+        | _ -> expression
+      in
+      { structure_item with pstr_desc = Pstr_eval (expression, attributes) }
+  | _ -> assert false
+
+let () =
+  Driver.register_transformation "test.str.evl"
+    ~rules:
+      [
+        Context_free.Rule.attr_replace "test.str.evl"
+          Extension.Context.structure_item
+          (Attribute.declare "test.str.evl" Pstr_eval string_pattern Fun.id)
+          template_str_eval;
+      ]
+
+let template_ppx_import ~ctxt:_ _payload = assert false
+
+let () =
+  Driver.register_transformation "test.ppx.import"
+    ~rules:
+      [
+        Context_free.Rule.attr_replace "test.ppx.import"
+          Extension.Context.Ppx_import
+          (Attribute.declare "test.ppx.import" Type_declaration string_pattern
+             Fun.id)
+          template_ppx_import;
+      ]
+
+let attr_multi ~ctxt:_ expression
+    ([ prefix; suffix ] :
+      _ Context_free.Rule.Attr_multiple_replace.Parsed_payload_list.t) =
+  match (prefix, suffix) with
+  | None, None -> assert false
+  | _ -> (
+      ();
+      match expression.pexp_desc with
+      | Pexp_ident { txt = Lident name; loc } ->
+          let prefixed = Option.value ~default:"" prefix ^ name in
+          let suffixed = prefixed ^ Option.value ~default:"" suffix in
+          {
+            expression with
+            pexp_desc = Pexp_ident { txt = Lident suffixed; loc };
+          }
+      | _ -> expression)
+
+let () =
+  Driver.register_transformation "test"
+    ~rules:
+      [
+        Context_free.Rule.Attr_multiple_replace.attr_multiple_replace
+          "test.multi.exp" Extension.Context.expression
+          [
+            Attribute.declare "test.multi.exp.prefix" Expression string_pattern
+              Fun.id;
+            Attribute.declare "test.multi.exp.suffix" Expression string_pattern
+              Fun.id;
+          ]
+          attr_multi;
+      ]
+
+let () = Driver.standalone ()