--- 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: \"()[%%finally ...]\"." - )) + Location.raise_errorf ~loc:expr.pexp_loc + "Lwt's finally should be used only with the syntax: \"()[%%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