gentoo resync : 25.11.2020

1 files changed, 401 insertions, 0 deletions

diff --git a/dev-ml/lwt/files/lwt-5.3.0-ppxlib-0.18.0.patch b/dev-ml/lwt/files/lwt-5.3.0-ppxlib-0.18.0.patch
new file mode 100644
index 000000000000..0bda140294a0
--- /dev/null
+++ b/dev-ml/lwt/files/lwt-5.3.0-ppxlib-0.18.0.patch
@@ -0,0 +1,401 @@
+--- 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