You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
402 lines
13 KiB
402 lines
13 KiB
--- 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
|