From ca859ed9d470492390388a3c8b7352123f3dc90b Mon Sep 17 00:00:00 2001
From: Thierry Martinez <Thierry.Martinez@inria.fr>
Date: Wed, 27 May 2020 14:58:26 +0200
Subject: [PATCH] Add metaquotations for signatures.

---
 ppx_metaquot.ml | 33 ++++++++++++++++++++++++++++++++-
 1 file changed, 32 insertions(+), 1 deletion(-)

diff --git a/ppx_metaquot.ml b/ppx_metaquot.ml
index aa71e0f..c63dbf1 100644
--- a/ppx_metaquot.ml
+++ b/ppx_metaquot.ml
@@ -11,6 +11,8 @@
    [%pat? ...] maps to code which creates the pattern represented by ...
    [%str ...] maps to code which creates the structure represented by ...
    [%stri ...] maps to code which creates the structure item represented by ...
+   [%sig: ...] maps to code which creates the signature represented by ...
+   [%sigi: ...] maps to code which creates the signature item represented by ...
    [%type: ...] maps to code which creates the core type represented by ...
 
    Quoted code can refer to expressions representing AST fragments,
@@ -20,6 +22,7 @@
      [%t ...] where ... is an expression of type Parsetree.core_type
      [%p ...] where ... is an expression of type Parsetree.pattern
      [%%s ...] where ... is an expression of type Parsetree.structure
+               or Parsetree.signature depending on the context.
 
 
    All locations generated by the meta quotation are by default set
@@ -149,6 +152,15 @@ module Main : sig end = struct
                cons (super # lift_Parsetree_structure_item x))
           str (nil ())
 
+      method! lift_Parsetree_signature sign =
+        List.fold_right
+          (function
+           | {psig_desc=Psig_extension(({txt="s";loc}, e), _); _} ->
+               append (get_exp loc e)
+           | x ->
+               cons (super # lift_Parsetree_signature_item x))
+          sign (nil ())
+
       method! lift_Parsetree_core_type = function
         | {ptyp_desc=Ptyp_extension({txt="t";loc}, e); _} -> map (get_exp loc e)
         | x -> super # lift_Parsetree_core_type x
@@ -206,6 +218,10 @@ module Main : sig end = struct
                (exp_lifter !loc this) # lift_Parsetree_structure e
            | Pexp_extension({txt="stri";_}, PStr [e]) ->
                (exp_lifter !loc this) # lift_Parsetree_structure_item e
+           | Pexp_extension({txt="sig";_}, PSig e) ->
+               (exp_lifter !loc this) # lift_Parsetree_signature e
+           | Pexp_extension({txt="sigi";_}, PSig [e]) ->
+               (exp_lifter !loc this) # lift_Parsetree_signature_item e
            | Pexp_extension({txt="type";loc=l}, e) ->
                (exp_lifter !loc this) # lift_Parsetree_core_type (get_typ l e)
            | _ ->
@@ -223,6 +239,10 @@ module Main : sig end = struct
                (pat_lifter this) # lift_Parsetree_structure e
            | Ppat_extension({txt="stri";_}, PStr [e]) ->
                (pat_lifter this) # lift_Parsetree_structure_item e
+           | Ppat_extension({txt="sig";_}, PSig e) ->
+               (pat_lifter this) # lift_Parsetree_signature e
+           | Ppat_extension({txt="sigi";_}, PSig [e]) ->
+               (pat_lifter this) # lift_Parsetree_signature_item e
            | Ppat_extension({txt="type";loc=l}, e) ->
                (pat_lifter this) # lift_Parsetree_core_type (get_typ l e)
            | _ ->
@@ -239,8 +259,19 @@ module Main : sig end = struct
       end;
       super.structure_item this x
 
+    and signature this l =
+      with_loc
+        (fun () -> super.signature this l)
+
+    and signature_item this x =
+      begin match x.psig_desc with
+      | Psig_attribute x -> handle_attr x
+      | _ -> ()
+      end;
+      super.signature_item this x
+
     in
-    {super with expr; pat; structure; structure_item}
+    {super with expr; pat; structure; structure_item; signature; signature_item}
 
   let () = Ast_mapper.run_main expander
 end