path: root/dev-ml/lwt/files/lwt-5.3.0-ppxlib-0.18.0.patch

--- lwt-5.3.0-orig/lwt_ppx.opam	2020-04-23 16:32:55.000000000 +1000
+++ lwt-5.3.0/lwt_ppx.opam	2020-10-12 22:12:12.863159266 +1100
@@ -20,8 +20,7 @@
   "dune" {>= "1.8.0"}
   "lwt"
   "ocaml" {>= "4.02.0"}
-  "ocaml-migrate-parsetree" {>= "1.5.0"}
-  "ppx_tools_versioned" {>= "5.3.0"}
+  "ppxlib" {>= "0.16.0"}
 ]
 
 build: [
--- lwt-5.3.0-orig/src/ppx/dune	2020-04-23 16:32:55.000000000 +1000
+++ lwt-5.3.0/src/ppx/dune	2020-10-12 22:11:33.844038953 +1100
@@ -13,10 +13,10 @@
  (public_name lwt_ppx)
  (synopsis "Lwt PPX syntax extension")
  (modules ppx_lwt)
- (libraries compiler-libs.common ocaml-migrate-parsetree ppx_tools_versioned)
+ (libraries compiler-libs.common ppxlib)
  (ppx_runtime_libraries lwt)
  (kind ppx_rewriter)
- (preprocess (pps ppx_tools_versioned.metaquot_410 |} ^ bisect_ppx ^ {|))
+ (preprocess (pps ppxlib.metaquot|} ^ bisect_ppx ^ {|))
  (flags (:standard -w +A-4)))
 
 |}
--- lwt-5.3.0-orig/src/ppx/ppx_lwt.ml	2020-04-23 16:32:55.000000000 +1000
+++ lwt-5.3.0/src/ppx/ppx_lwt.ml	2020-10-12 22:10:11.298784433 +1100
@@ -1,16 +1,11 @@
-open! Migrate_parsetree
-open! OCaml_410.Ast
-open Ast_mapper
+open! Ppxlib
+open Ast_builder.Default
 open! Ast_helper
-open Asttypes
-open Parsetree
-
-open Ast_convenience_410
 
 (** {2 Convenient stuff} *)
 
-let with_loc f {txt ; loc = _loc} =
-  (f txt) [@metaloc _loc]
+let with_loc f {txt ; loc } =
+  f ~loc txt
 
 (** Test if a case is a catchall. *)
 let is_catchall case =
@@ -27,7 +22,7 @@
     List.exists is_catchall cases
   in
   if not has_wildcard
-  then cases @ [Exp.case [%pat? exn] [%expr Lwt.fail exn]] [@metaloc Location.none]
+  then cases @ (let loc = Location.none in [Exp.case [%pat? exn] [%expr Lwt.fail exn]])
   else cases
 
 (** {3 Internal names} *)
@@ -73,34 +68,33 @@
         evar ~loc:binding.pvb_expr.pexp_loc (gen_name i)
       in
       let fun_ =
-        [%expr (fun [%p binding.pvb_pat] -> [%e aux (i+1) t])] [@metaloc e_loc]
+        let loc = e_loc in
+        [%expr (fun [%p binding.pvb_pat] -> [%e aux (i+1) t])]
       in
       let new_exp =
-          [%expr
-            let module Reraise = struct external reraise : exn -> 'a = "%reraise" end in
-            Lwt.backtrace_bind
-              (fun exn -> try Reraise.reraise exn with exn -> exn)
-              [%e name]
-              [%e fun_]
-          ] [@metaloc e_loc]
+        let loc = e_loc in
+        [%expr
+          let module Reraise = struct external reraise : exn -> 'a = "%reraise" end in
+          Lwt.backtrace_bind
+            (fun exn -> try Reraise.reraise exn with exn -> exn)
+            [%e name]
+            [%e fun_]
+        ]
       in
       { new_exp with pexp_attributes = binding.pvb_attributes }
   in aux 0 l
 
-(* Note: instances of [@metaloc !default_loc] below are workarounds for
-    https://github.com/ocaml-ppx/ppx_tools_versioned/issues/21. *)
-
 let lwt_sequence mapper ~exp ~lhs ~rhs ~ext_loc =
-  let pat= [%pat? ()][@metaloc ext_loc] in
-  let lhs, rhs = mapper.expr mapper lhs, mapper.expr mapper rhs in
-    [%expr
-      let module Reraise = struct external reraise : exn -> 'a = "%reraise" end in
-      Lwt.backtrace_bind
-        (fun exn -> try Reraise.reraise exn with exn -> exn)
-        [%e lhs]
-        (fun [%p pat] -> [%e rhs])
-    ]
-  [@metaloc exp.pexp_loc]
+  let pat= let loc = ext_loc in [%pat? ()] in
+  let lhs, rhs = mapper#expression lhs, mapper#expression rhs in
+  let loc = exp.pexp_loc in
+  [%expr
+    let module Reraise = struct external reraise : exn -> 'a = "%reraise" end in
+    Lwt.backtrace_bind
+      (fun exn -> try Reraise.reraise exn with exn -> exn)
+      [%e lhs]
+      (fun [%p pat] -> [%e rhs])
+  ]
 
 (** For expressions only *)
 (* We only expand the first level after a %lwt.
@@ -121,7 +115,7 @@
         (gen_bindings vbl)
         (gen_binds exp.pexp_loc vbl e)
     in
-    Some (mapper.expr mapper { new_exp with pexp_attributes })
+    Some (mapper#expression { new_exp with pexp_attributes })
 
   (* [match%lwt $e$ with $c$] ≡ [Lwt.bind $e$ (function $c$)]
      [match%lwt $e$ with exception $x$ | $c$] ≡
@@ -134,11 +128,8 @@
         | _ -> false)
     in
     if cases = [] then
-        raise (Location.Error (
-          Location.errorf
-            ~loc:exp.pexp_loc
-            "match%%lwt must contain at least one non-exception pattern."
-        ));
+      Location.raise_errorf ~loc:exp.pexp_loc
+        "match%%lwt must contain at least one non-exception pattern." ;
     let exns =
       exns |> List.map (
         function
@@ -150,22 +141,24 @@
     let new_exp =
       match exns with
       | [] ->
-        [%expr Lwt.bind [%e e] [%e Exp.function_ cases]] [@metaloc !default_loc]
-      | _  ->  [%expr Lwt.try_bind (fun () -> [%e e])
-                                   [%e Exp.function_ cases]
-                                   [%e Exp.function_ exns]]
-          [@metaloc !default_loc]
+        let loc = !default_loc in
+        [%expr Lwt.bind [%e e] [%e Exp.function_ cases]]
+      | _  ->
+        let loc = !default_loc in
+        [%expr Lwt.try_bind (fun () -> [%e e])
+            [%e Exp.function_ cases]
+            [%e Exp.function_ exns]]
     in
-    Some (mapper.expr mapper { new_exp with pexp_attributes })
+    Some (mapper#expression { new_exp with pexp_attributes })
 
   (* [assert%lwt $e$] ≡
      [try Lwt.return (assert $e$) with exn -> Lwt.fail exn] *)
   | Pexp_assert e ->
     let new_exp =
+      let loc = !default_loc in
       [%expr try Lwt.return (assert [%e e]) with exn -> Lwt.fail exn]
-        [@metaloc !default_loc]
     in
-    Some (mapper.expr mapper { new_exp with pexp_attributes })
+    Some (mapper#expression { new_exp with pexp_attributes })
 
   (* [while%lwt $cond$ do $body$ done] ≡
      [let rec __ppx_lwt_loop () =
@@ -175,15 +168,15 @@
   *)
   | Pexp_while (cond, body) ->
     let new_exp =
+      let loc = !default_loc in
       [%expr
         let rec __ppx_lwt_loop () =
           if [%e cond] then Lwt.bind [%e body] __ppx_lwt_loop
           else Lwt.return_unit
         in __ppx_lwt_loop ()
       ]
-        [@metaloc !default_loc]
     in
-    Some (mapper.expr mapper { new_exp with pexp_attributes })
+    Some (mapper#expression { new_exp with pexp_attributes })
 
   (* [for%lwt $p$ = $start$ (to|downto) $end$ do $body$ done] ≡
      [let __ppx_lwt_bound = $end$ in
@@ -193,16 +186,19 @@
      in __ppx_lwt_loop $start$]
   *)
   | Pexp_for ({ppat_desc = Ppat_var p_var; _} as p, start, bound, dir, body) ->
-    let comp, op = match dir with
-      | Upto ->   evar ">", evar "+"
-      | Downto -> evar "<", evar "-"
+    let comp, op =
+      let loc = !default_loc in
+      match dir with
+      | Upto ->   evar ~loc ">", evar ~loc "+"
+      | Downto -> evar ~loc "<", evar ~loc "-"
     in
-    let p' = with_loc (fun s -> evar s) p_var in
+    let p' = with_loc evar p_var in
 
-    let exp_bound = [%expr __ppx_lwt_bound] [@metaloc bound.pexp_loc] in
-    let pat_bound = [%pat? __ppx_lwt_bound] [@metaloc bound.pexp_loc] in
+    let exp_bound = let loc = bound.pexp_loc in [%expr __ppx_lwt_bound] in
+    let pat_bound = let loc = bound.pexp_loc in [%pat? __ppx_lwt_bound] in
 
     let new_exp =
+      let loc = !default_loc in
       [%expr
         let [%p pat_bound] : int = [%e bound] in
         let rec __ppx_lwt_loop [%p p] =
@@ -210,9 +206,8 @@
           else Lwt.bind [%e body] (fun () -> __ppx_lwt_loop ([%e op] [%e p'] 1))
         in __ppx_lwt_loop [%e start]
       ]
-        [@metaloc !default_loc]
     in
-    Some (mapper.expr mapper { new_exp with pexp_attributes })
+    Some (mapper#expression { new_exp with pexp_attributes })
 
 
   (* [try%lwt $e$ with $c$] ≡
@@ -221,6 +216,7 @@
   | Pexp_try (expr, cases) ->
     let cases = add_wildcard_case cases in
     let new_exp =
+      let loc = !default_loc in
         [%expr
           let module Reraise = struct external reraise : exn -> 'a = "%reraise" end in
           Lwt.backtrace_catch
@@ -228,9 +224,8 @@
             (fun () -> [%e expr])
             [%e Exp.function_ cases]
         ]
-          [@metaloc !default_loc]
     in
-    Some (mapper.expr mapper { new_exp with pexp_attributes })
+    Some (mapper#expression { new_exp with pexp_attributes })
 
   (* [if%lwt $c$ then $e1$ else $e2$] ≡
      [match%lwt $c$ with true -> $e1$ | false -> $e2$]
@@ -240,37 +235,37 @@
   | Pexp_ifthenelse (cond, e1, e2) ->
     let e2 =
       match e2 with
-      | None -> [%expr Lwt.return_unit] [@metaloc !default_loc]
+      | None -> let loc = !default_loc in [%expr Lwt.return_unit]
       | Some e -> e
     in
     let cases =
+      let loc = !default_loc in
       [
-        Exp.case ([%pat? true] [@metaloc !default_loc]) e1 ;
-        Exp.case ([%pat? false] [@metaloc !default_loc]) e2 ;
+        Exp.case [%pat? true] e1 ;
+        Exp.case [%pat? false] e2 ;
       ]
     in
     let new_exp =
+      let loc = !default_loc in
       [%expr Lwt.bind [%e cond] [%e Exp.function_ cases]]
-        [@metaloc !default_loc]
     in
-    Some (mapper.expr mapper { new_exp with pexp_attributes })
+    Some (mapper#expression { new_exp with pexp_attributes })
 
   | _ ->
     None
 
 let warned = ref false
 
-let mapper =
-  { default_mapper with
+class mapper = object (self)
+  inherit Ast_traverse.map as super
 
-    structure = begin fun mapper structure ->
-      if !warned then
-        default_mapper.structure mapper structure
+  method! structure = begin fun structure ->
+      if !warned then super#structure structure
 
       else begin
         warned := true;
-        let structure = default_mapper.structure mapper structure in
-        let loc = Location.in_file !Location.input_name in
+        let structure = super#structure structure in
+        let loc = Location.in_file !Ocaml_common.Location.input_name in
 
         let warn_if condition message structure =
           if condition then
@@ -287,9 +282,9 @@
           ("-no-sequence is a deprecated Lwt PPX option\n" ^
            "  See https://github.com/ocsigen/lwt/issues/495")
       end
-    end;
+    end
 
-    expr = (fun mapper expr ->
+  method! expression = (fun expr ->
       match expr with
       | { pexp_desc=
             Pexp_extension (
@@ -297,7 +292,7 @@
               PStr[{pstr_desc= Pstr_eval (exp, _);_}]);
           _
         }->
-        begin match lwt_expression mapper exp expr.pexp_attributes ext_loc with
+        begin match lwt_expression self exp expr.pexp_attributes ext_loc with
         | Some expr' -> expr'
         | None -> expr
         end
@@ -306,47 +301,45 @@
       | [%expr [%e? exp ] [%finally     [%e? finally]] ]
       | [%expr [%e? exp ] [%lwt.finally [%e? finally]] ] ->
         let new_exp =
-            [%expr
-              let module Reraise = struct external reraise : exn -> 'a = "%reraise" end in
-              Lwt.backtrace_finalize
-                (fun exn -> try Reraise.reraise exn with exn -> exn)
-                (fun () -> [%e exp])
-                (fun () -> [%e finally])
-            ]
-              [@metaloc !default_loc]
+          let loc = !default_loc in
+          [%expr
+            let module Reraise = struct external reraise : exn -> 'a = "%reraise" end in
+            Lwt.backtrace_finalize
+              (fun exn -> try Reraise.reraise exn with exn -> exn)
+              (fun () -> [%e exp])
+              (fun () -> [%e finally])
+          ]
         in
-        mapper.expr mapper
+        super#expression
           { new_exp with
             pexp_attributes = expr.pexp_attributes @ exp.pexp_attributes
           }
 
       | [%expr [%finally     [%e? _ ]]]
       | [%expr [%lwt.finally [%e? _ ]]] ->
-        raise (Location.Error (
-          Location.errorf
-            ~loc:expr.pexp_loc
-            "Lwt's finally should be used only with the syntax: \"(<expr>)[%%finally ...]\"."
-        ))
+        Location.raise_errorf ~loc:expr.pexp_loc
+          "Lwt's finally should be used only with the syntax: \"(<expr>)[%%finally ...]\"."
 
       | _ ->
-        default_mapper.expr mapper expr);
-    structure_item = (fun mapper stri ->
+        super#expression expr)
+
+  method! structure_item = (fun stri ->
       default_loc := stri.pstr_loc;
       match stri with
       | [%stri let%lwt [%p? var] = [%e? exp]] ->
         let warning =
-          str
+          estring ~loc:!default_loc
             ("let%lwt should not be used at the module item level.\n" ^
              "Replace let%lwt x = e by let x = Lwt_main.run (e)")
         in
+        let loc = !default_loc in
         [%stri
           let [%p var] =
             (Lwt_main.run [@ocaml.ppwarning [%e warning]])
-              [%e mapper.expr mapper exp]]
-          [@metaloc !default_loc]
+              [%e super#expression exp]]
 
-      | x -> default_mapper.structure_item mapper x);
-}
+      | x -> super#structure_item x);
+end
 
 
 let args =
@@ -361,5 +354,8 @@
   ]
 
 let () =
-  Driver.register ~name:"ppx_lwt" ~args Versions.ocaml_410
-    (fun _config _cookies -> mapper)
+  let mapper = new mapper in
+  Driver.register_transformation "ppx_lwt"
+    ~impl:mapper#structure
+    ~intf:mapper#signature ;
+  List.iter (fun (key, spec, doc) -> Driver.add_arg key spec ~doc) args
--- lwt-5.3.0-orig/src/ppx/ppx_lwt.mli	2020-04-23 16:32:55.000000000 +1000
+++ lwt-5.3.0/src/ppx/ppx_lwt.mli	2020-10-12 22:10:45.384889535 +1100
@@ -161,4 +161,4 @@
 *)
 
 
-val mapper : Migrate_parsetree.OCaml_410.Ast.Ast_mapper.mapper
+class mapper : Ppxlib.Ast_traverse.map