Skip to content

Commit

Permalink
switch to ppxlib
Browse files Browse the repository at this point in the history
  • Loading branch information
@pveber
pveber committed Nov 13, 2020
1 parent b594c98 commit 2c73ec1
Show file tree
Hide file tree
Showing 5 changed files with 75 additions and 78 deletions.
3 changes: 2 additions & 1 deletion lwt.opam
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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"}
]

Expand Down
3 changes: 1 addition & 2 deletions lwt_ppx.opam
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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: [
Expand Down
4 changes: 2 additions & 2 deletions src/ppx/dune
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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)))

|}
141 changes: 69 additions & 72 deletions src/ppx/ppx_lwt.ml
View file
Original file line number Diff line number Diff line change
@@ -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 =
Expand All @@ -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} *)
Expand Down Expand Up @@ -73,34 +68,33 @@ 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
(fun exn -> try Reraise.reraise exn with exn -> exn)
[%e lhs]
(fun [%p pat] -> [%e rhs])
]
[@metaloc exp.pexp_loc]

(** For expressions only *)
(* We only expand the first level after a %lwt.
Expand All @@ -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$] ≡
Expand All @@ -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
Expand All @@ -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 () =
Expand All @@ -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
Expand All @@ -193,26 +186,28 @@ 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] =
if [%e comp] [%e p'] [%e exp_bound] then Lwt.return_unit
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$] ≡
Expand All @@ -221,16 +216,16 @@ 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
(fun exn -> try Reraise.reraise exn with exn -> exn)
(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$]
Expand All @@ -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
Expand All @@ -287,17 +283,17 @@ 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 (
{txt="lwt"; loc= ext_loc},
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
Expand All @@ -306,47 +302,45 @@ 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
(fun exn -> try Reraise.reraise exn with exn -> exn)
(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: \"(<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 =
Expand All @@ -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
2 changes: 1 addition & 1 deletion src/ppx/ppx_lwt.mli
View file
Original file line number Diff line number Diff line change
Expand Up @@ -161,4 +161,4 @@ else
*)


val mapper : Migrate_parsetree.OCaml_411.Ast.Ast_mapper.mapper
class mapper : Ppxlib.Ast_traverse.map

0 comments on commit 2c73ec1

Please sign in to comment.