From 583f478ca0f0b2af5846d073ab8ccfd72977c0db Mon Sep 17 00:00:00 2001 From: Philippe Veber Date: Mon, 14 Sep 2020 13:03:11 +0200 Subject: [PATCH 1/2] switch to ppxlib --- lwt.opam | 3 +- lwt_ppx.opam | 3 +- src/ppx/dune | 4 +- src/ppx/ppx_lwt.ml | 141 ++++++++++++++++++++++---------------------- src/ppx/ppx_lwt.mli | 2 +- 5 files changed, 75 insertions(+), 78 deletions(-) diff --git a/lwt.opam b/lwt.opam index 277dea2451..0fe007bfd2 100644 --- a/lwt.opam +++ b/lwt.opam @@ -28,7 +28,8 @@ depends: [ "result" # result is needed as long as Lwt supports OCaml 4.02. "seq" # seq is needed as long as Lwt supports OCaml < 4.07.0. - "bisect_ppx" {dev & >= "2.0.0"} + # Until https://github.com/aantron/bisect_ppx/pull/327. + # "bisect_ppx" {dev & >= "2.0.0"} "ocamlfind" {dev & >= "1.7.3-1"} ] diff --git a/lwt_ppx.opam b/lwt_ppx.opam index 69a3287d11..d6ba6b7489 100644 --- a/lwt_ppx.opam +++ b/lwt_ppx.opam @@ -20,8 +20,7 @@ depends: [ "dune" {>= "1.8.0"} "lwt" "ocaml" {>= "4.02.0"} - "ocaml-migrate-parsetree" {>= "1.7.0"} - "ppx_tools_versioned" {>= "5.4.0"} + "ppxlib" {>= "0.16.0"} ] build: [ diff --git a/src/ppx/dune b/src/ppx/dune index f5e6ab5cc0..f0717b75ec 100644 --- a/src/ppx/dune +++ b/src/ppx/dune @@ -13,10 +13,10 @@ let () = Jbuild_plugin.V1.send @@ {| (public_name lwt_ppx) (synopsis "Lwt PPX syntax extension") (modules ppx_lwt) - (libraries compiler-libs.common ocaml-migrate-parsetree ppx_tools_versioned) + (libraries ocaml-compiler-libs.common ppxlib) (ppx_runtime_libraries lwt) (kind ppx_rewriter) - (preprocess (pps ppx_tools_versioned.metaquot_411 |} ^ bisect_ppx ^ {|)) + (preprocess (pps ppxlib.metaquot|} ^ bisect_ppx ^ {|)) (flags (:standard -w +A-4))) |} diff --git a/src/ppx/ppx_lwt.ml b/src/ppx/ppx_lwt.ml index ccd80e9f29..1e50a5a755 100644 --- a/src/ppx/ppx_lwt.ml +++ b/src/ppx/ppx_lwt.ml @@ -1,16 +1,11 @@ -open! Migrate_parsetree -open! OCaml_411.Ast -open Ast_mapper +open! Ppxlib +open Ast_builder.Default open! Ast_helper -open Asttypes -open Parsetree - -open Ast_convenience_411 (** {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 @@ let add_wildcard_case cases = 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,26 +68,26 @@ let gen_binds e_loc l e = 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 = + 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_] - ] [@metaloc e_loc] + ] 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 + 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 @@ -100,7 +95,6 @@ let lwt_sequence mapper ~exp ~lhs ~rhs ~ext_loc = [%e lhs] (fun [%p pat] -> [%e rhs]) ] - [@metaloc exp.pexp_loc] (** For expressions only *) (* We only expand the first level after a %lwt. @@ -121,7 +115,7 @@ let lwt_expression mapper exp attributes ext_loc = (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 @@ let lwt_expression mapper exp attributes ext_loc = | _ -> 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 lwt_expression mapper exp attributes ext_loc = 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]) + 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]] - [@metaloc !default_loc] 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 @@ let lwt_expression mapper exp attributes ext_loc = *) | 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 @@ let lwt_expression mapper exp attributes ext_loc = 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 @@ let lwt_expression mapper exp attributes ext_loc = 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 @@ let lwt_expression mapper exp attributes ext_loc = | 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 @@ let lwt_expression mapper exp attributes ext_loc = (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,38 @@ let lwt_expression mapper exp attributes ext_loc = | 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 -> + method! structure = begin fun structure -> if !warned then - default_mapper.structure mapper structure + 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 +283,9 @@ let mapper = ("-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 +293,7 @@ let mapper = 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,6 +302,7 @@ let mapper = | [%expr [%e? exp ] [%finally [%e? finally]] ] | [%expr [%e? exp ] [%lwt.finally [%e? finally]] ] -> let new_exp = + let loc = !default_loc in [%expr let module Reraise = struct external reraise : exn -> 'a = "%reraise" end in Lwt.backtrace_finalize @@ -313,40 +310,37 @@ let mapper = (fun () -> [%e exp]) (fun () -> [%e finally]) ] - [@metaloc !default_loc] 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 +355,8 @@ let args = ] let () = - Driver.register ~name:"ppx_lwt" ~args Versions.ocaml_411 - (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 diff --git a/src/ppx/ppx_lwt.mli b/src/ppx/ppx_lwt.mli index ece866d20b..3faea4061f 100644 --- a/src/ppx/ppx_lwt.mli +++ b/src/ppx/ppx_lwt.mli @@ -161,4 +161,4 @@ else *) -val mapper : Migrate_parsetree.OCaml_411.Ast.Ast_mapper.mapper +class mapper : Ppxlib.Ast_traverse.map From cfc48b143efbcbdc3e72b3046756fee9933b1126 Mon Sep 17 00:00:00 2001 From: Anton Bachin Date: Sat, 14 Nov 2020 08:33:41 +0300 Subject: [PATCH 2/2] Adjust Travis for preceding commit --- .travis.yml | 29 ++++++++++++++++++++--------- 1 file changed, 20 insertions(+), 9 deletions(-) diff --git a/.travis.yml b/.travis.yml index 9f614488d0..9611bf6126 100644 --- a/.travis.yml +++ b/.travis.yml @@ -70,7 +70,12 @@ scripts: - | if [ "$CACHED" == no ] then - opam install . --deps-only --yes + if [ "$PPX" == no ] + then + opam install ./lwt.opam ./lwt_react.opam --deps-only --yes + else + opam install . --deps-only --yes + fi fi - | if [ "$CACHED" == no && "$LIBEV" != no ] @@ -96,8 +101,14 @@ scripts: - | if [ "$COVERAGE" != yes ] then - dune build - dune runtest --force + if [ "$PPX" == no ] + then + dune build --only-packages lwt,lwt_react + dune runtest --only-packages lwt,lwt_react --force + else + dune build + dune runtest --force + fi else make coverage bisect-ppx-report send-to Coveralls @@ -159,7 +170,7 @@ matrix: env: COMPILER=4.10.0 LIBEV=no - <<: *opam os: linux - env: COMPILER=4.10.0 LIBEV=no PPX_LET=yes COVERAGE=yes + env: COMPILER=4.10.0 LIBEV=no PPX_LET=yes - <<: *opam os: linux env: COMPILER=4.09.0 DOCS=yes @@ -177,13 +188,13 @@ matrix: env: COMPILER=4.05.0+bytecode-only - <<: *opam os: linux - env: COMPILER=4.04.2 + env: COMPILER=4.04.2 PACKAGING=yes - <<: *opam os: linux - env: COMPILER=4.03.0 + env: COMPILER=4.03.0 PPX=no - <<: *opam os: linux - env: COMPILER=4.02.3 PACKAGING=yes + env: COMPILER=4.02.3 PPX=no - <<: *esy os: linux env: ESY=yes @@ -194,8 +205,8 @@ matrix: - env: COMPILER=4.07.1 - env: COMPILER=4.06.1 LWT_STRESS_TEST=true - env: COMPILER=4.05.0+bytecode-only - - env: COMPILER=4.04.2 - - env: COMPILER=4.03.0 + - env: COMPILER=4.04.2 PACKAGING=yes + - env: COMPILER=4.03.0 PPX=no - env: ESY=yes fast_finish: true