release ppxlib constraints

Author: maxtori

src/ppx/dune

@@ -3,7 +3,7 @@
  (public_name ez_api.ppx_common)
  (optional)
  (modules ppx_common)
- (preprocess (pps ppxlib.metaquot))
+ (preprocess (pps ppxlib.metaquot ppxlib_optcomp))
  (libraries ppx_deriving_encoding.lib))
 
 (library
@@ -42,12 +42,18 @@
  (libraries ppx_common)
  (ppx_runtime_libraries ezReq_lwt))
 
+(library
+ (name ppxlib_optcomp)
+ (modules ppxlib_optcomp)
+ (libraries compiler-libs.common ppxlib)
+ (kind ppx_rewriter))
+
 (library
  (name ppx_deriving_err_case)
  (public_name ez_api.ppx_err_case)
  (optional)
  (modules ppx_deriving_err_case)
- (preprocess (pps ppxlib.metaquot))
+ (preprocess (pps ppxlib.metaquot ppxlib_optcomp))
  (kind ppx_rewriter)
  (ppx_runtime_libraries ez_api)
  (libraries ppx_deriving_encoding.lib ez_api))

src/ppx/ppx_common.ml

@@ -697,20 +697,20 @@ let handler_args ~name e =
       p, [%expr match [%e evar ~loc (name ^ "_req")] _req with
         | Error e -> EzAPIServerUtils.return ([%e !global_req_error] e)
         | Ok [%p pvar ~loc id] -> [%e f]] in
-  match e.pexp_desc with
-  | Pexp_fun (_, _, p1, {pexp_desc=Pexp_fun (_, _, p2, {pexp_desc=Pexp_fun (_, _, p3, f); _}); _}) ->
+  match e with
+  | [%expr fun [%p? p1] [%p? p2] [%p? p3] -> [%e? f]] ->
     let f = match !global_wrapper with
       | None -> f
       | Some wrap -> eapply ~loc wrap [ f ] in
     let p1, f = aux p1 f in
     [%expr fun [%p p1] [%p p2] [%p p3] -> [%e f]]
-  | Pexp_fun (_, _, p1, {pexp_desc = Pexp_fun (_, _, p2, f); _}) ->
+  | [%expr fun [%p? p1] [%p? p2] -> [%e? f]] ->
     let f = match !global_wrapper with
       | None -> f
       | Some wrap -> eapply ~loc wrap [ f ] in
     let p1, f = aux p1 f in
     [%expr fun [%p p1] _ [%p p2] -> [%e f]]
-  | Pexp_fun (_, _, p, f) ->
+  | [%expr fun [%p? p] -> [%e? f]] ->
     let f = match !global_wrapper with
       | None -> f
       | Some wrap -> eapply ~loc wrap [ f ] in

src/ppx/ppx_deriving_err_case.ml

@@ -12,6 +12,14 @@ open Ppxlib
 open Ast_builder.Default
 open Ppx_deriving_encoding_lib
 
+let pexp_function ~loc l =
+  pexp_function ~loc l
+[@@if ast_version < 502]
+
+let pexp_function ~loc l =
+  pexp_function ~loc [] None @@ Pfunction_cases (l, loc, [])
+[@@if ast_version >= 502]
+
 let mk ~loc ?enc ?(kind_label="kind") ~title name code =
   let kind_enc = Utils.(enc_apply ~loc "obj1" [
       enc_apply ~loc "req" [
@@ -23,11 +31,10 @@ let mk ~loc ?enc ?(kind_label="kind") ~title name code =
   let encoding =
     if title then Utils.enc_apply ~loc "def" [ estring ~loc name; encoding ]
     else encoding in
-  let select = pexp_function ~loc [
-      case ~guard:None
-        ~lhs:(ppat_variant ~loc name (Option.map (fun _ -> [%pat? x]) enc))
-        ~rhs:(Option.fold ~none:[%expr Some ()] ~some:(fun _ -> [%expr Some ((), x)]) enc);
-      case ~guard:None ~lhs:[%pat? _] ~rhs:[%expr None] ] in
+  let select = [%expr function
+    | [%p ppat_variant ~loc name (Option.map (fun _ -> [%pat? x]) enc)] ->
+      [%e Option.fold ~none:[%expr Some ()] ~some:(fun _ -> [%expr Some ((), x)]) enc]
+    | _ -> None] in
   let deselect = Utils.pexp_fun
       (Option.fold ~none:[%pat? ()] ~some:(fun _ -> [%pat? ((), x)]) enc)
       (pexp_variant ~loc name (Option.map (fun _ -> [%expr x]) enc)) in

src/ppx/ppxlib_optcomp.ml

@@ -0,0 +1,54 @@
+open Ppxlib
+
+let keep attrs =
+  match List.find_map (fun a -> if a.attr_name.txt = "if" then Some a.attr_payload else None) attrs with
+  | Some PStr [ {pstr_desc=Pstr_eval ({
+    pexp_desc=Pexp_apply ({
+      pexp_desc=Pexp_ident {txt=Lident cmp; _}; _}, [
+        Nolabel, {pexp_desc=Pexp_ident {txt=Lident "ast_version"; _}; _};
+        Nolabel, {pexp_desc=Pexp_constant Pconst_integer (v, None); _}
+      ]); _}, _); _} ] ->
+    let f = match cmp with
+      | "=" -> (=) | ">" -> (>) | ">=" -> (>=) | "<" -> (<) | "<=" -> (<=)
+      | "<>" -> (<>) | _ -> (fun _ _ -> true) in
+    f Selected_ast.version (int_of_string v)
+  | _ -> true
+
+let rec filter_pattern = function
+  | { ppat_desc = Ppat_or (p1, p2); _ } as p ->
+    (match filter_pattern p1, filter_pattern p2 with
+     | None, None -> None
+     | Some p1, None -> Some p1
+     | None, Some p2 -> Some p2
+     | Some p1, Some p2 -> Some { p with ppat_desc = Ppat_or (p1, p2) })
+  | { ppat_attributes; _ } as p ->
+    if keep ppat_attributes then Some p else None
+
+
+let transform = object inherit Ast_traverse.map as super
+  method! structure s =
+    let s = List.filter_map (fun it -> match it.pstr_desc with
+      | Pstr_value (flag, l) ->
+        let l = List.filter (fun vb -> keep vb.pvb_attributes) l in
+        (match l with [] -> None | _ -> Some { it with pstr_desc = Pstr_value (flag, l) })
+      | _ -> Some it
+    ) s in
+    super#structure s
+
+  method! cases l =
+    let l = List.filter_map (fun c ->
+      let p = filter_pattern c.pc_lhs in
+      Option.map (fun pc_lhs -> { c with pc_lhs }) p
+    ) l in
+    super#cases l
+
+  method! expression e =
+    match e.pexp_desc with
+    | Pexp_let (flag, l, end_) ->
+      let l = List.filter (fun vb -> keep vb.pvb_attributes) l in
+      let e = match l with [] -> end_ | _ -> { e with pexp_desc = Pexp_let (flag, l, end_) } in
+      super#expression e
+    | _ -> super#expression e
+end
+
+let () = Driver.register_transformation ~impl:transform#structure "ppxlib_optcomp"