Merge pull request #18 from noRubidium/enable-antiquoting-for-pattern-matching

implement antiquotation for pattern matching

Author: NathanReb

lib/pattern.ml

@@ -16,6 +16,12 @@ let expand_float ~loc s = [%pat? `Float [%p Ast_builder.Default.pfloat ~loc s]]
 
 let expand_var ~loc var = Ast_builder.Default.ppat_var ~loc var
 
+let expand_anti_quotation ~ppat_loc = function
+  | PPat (ppat, _) -> ppat
+  | PStr _
+  | PSig _
+  | PTyp _ -> Raise.bad_pat_antiquotation_payload ~loc:ppat_loc
+
 let rec expand ~loc ~path pat =
   match pat with
   | [%pat? _] -> [%pat? _]
@@ -31,6 +37,9 @@ let rec expand ~loc ~path pat =
     expand_intlit ~loc s
   | {ppat_desc = Ppat_constant (Pconst_float (s, None)); _} -> expand_float ~loc s
   | {ppat_desc = Ppat_var v; _} -> expand_var ~loc v
+  | {ppat_desc = Ppat_extension ({txt = "y"; _}, p); ppat_loc; _}
+    ->
+    expand_anti_quotation ~ppat_loc p
   | [%pat? [%p? left] | [%p? right]]
     ->
     ([%pat? [%p expand ~loc ~path left] | [%p expand ~loc ~path right]])
@@ -69,4 +78,3 @@ and expand_record ~loc ~ppat_loc ~path l =
     | [] -> assert false
     | [single] -> single
     | hd::tl -> List.fold_left (fun acc elm -> [%pat? [%p acc] | [%p elm]]) hd tl
-    

lib/raise.ml

@@ -14,3 +14,8 @@ let bad_expr_antiquotation_payload ~loc =
   Location.raise_errorf
     ~loc
     "ppx_yojson: bad antiquotation payload, should be a single expression"
+
+let bad_pat_antiquotation_payload ~loc =
+  Location.raise_errorf
+    ~loc
+    "ppx_yojson: bad antiquotation payload, should be a pattern"

lib/raise.mli

@@ -24,3 +24,8 @@ val too_many_fields_in_record_pattern :
 val bad_expr_antiquotation_payload :
   loc: Ppxlib.Location.t ->
   'a
+
+(** Use this for bad payload in pattern antiquotation [[%y? ...]]. *)
+val bad_pat_antiquotation_payload :
+  loc: Ppxlib.Location.t ->
+  'a

test/rewriter/errors/dune.inc

@@ -155,6 +155,32 @@
   (action (diff expr_unsupported_record_field.expected expr_unsupported_record_field.actual))
 )
 
+(library
+  (name pat_anti_quotation_payload)
+  (modules pat_anti_quotation_payload)
+  (preprocess (pps ppx_yojson))
+)
+
+(rule
+  (targets pat_anti_quotation_payload.actual)
+  (deps (:pp pp.exe) (:input pat_anti_quotation_payload.ml))
+  (action
+    (setenv "OCAML_ERROR_STYLE" "short"
+      (setenv "OCAML_COLOR" "never"
+        (with-stderr-to
+          %{targets}
+          (bash "./%{pp} -no-color --impl %{input} || true")
+        )
+      )
+    )
+  )
+)
+
+(alias
+  (name runtest)
+  (action (diff pat_anti_quotation_payload.expected pat_anti_quotation_payload.actual))
+)
+
 (library
   (name pat_integer_literal_binary)
   (modules pat_integer_literal_binary)

test/rewriter/errors/pat_anti_quotation_payload.expected

@@ -0,0 +1,2 @@
+File "pat_anti_quotation_payload.ml", line 2, characters 14-26:
+Error: ppx_yojson: bad antiquotation payload, should be a pattern

test/rewriter/errors/pat_anti_quotation_payload.ml

@@ -0,0 +1,3 @@
+let invalid_anti_quotation_pattern = function
+  | [%yojson? [%y `Int _a]] -> false
+  | _ -> true

test/rewriter/pp.expected.ml

@@ -89,5 +89,6 @@ let patterns =
     | `Intlit "1" as _int_32 -> ()
     | `Intlit "1" as _native_int -> ()
     | _s as _var -> ()
+    | `Assoc (("a", `Int _i)::[]) as _var -> ()
     | _ as _any -> ())
   [@warning "-11"])

test/rewriter/test.ml

@@ -52,4 +52,5 @@ let patterns = function [@warning "-11"]
   | [%yojson? 1l] as _int_32 -> ()
   | [%yojson? 1n] as _native_int -> ()
   | [%yojson? _s] as _var -> ()
+  | [%yojson? { a = [%y? `Int _i]}] as _var -> ()
   | [%yojson? _] as _any -> ()