From 1c3bd075d7bb84f26a8543cf466d7f36a6b5e6a7 Mon Sep 17 00:00:00 2001 From: Xavier Clerc Date: Thu, 7 Jun 2018 11:39:27 +0100 Subject: [PATCH] v0.11.117.10+09 --- CHANGES.md | 5 +++++ README.md | 17 ++++++++++++----- src/ppx_let.ml | 40 ++++++++++++++++++++++------------------ test/test.ml | 6 ++++++ 4 files changed, 45 insertions(+), 23 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index b84af5327..38594829d 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,8 @@ +## git version + +- Support for `%map.A.B.C` syntax to use values from a specific module, rather + than the one in scope. + ## v0.11 - Depend on ppxlib instead of (now deprecated) ppx\_core and ppx\_driver. diff --git a/README.md b/README.md index c2a3c786a..389a8dbda 100644 --- a/README.md +++ b/README.md @@ -131,15 +131,22 @@ Getting the right names in scope The description of how the `%bind` and `%map` syntax extensions expand left out the fact that the names `bind`, `map`, `both`, and `return` are not used -directly, but rather qualified by `Let_syntax`. For example, we use -`Let_syntax.bind` rather than merely `bind`. This means one just needs to get a -properly loaded `Let_syntax` module in scope to use `%bind` and `%map`. +directly., but rather qualified by `Let_syntax`. For example, we use +`Let_syntax.bind` rather than merely `bind`. + +This means one just needs to get a properly loaded `Let_syntax` module +in scope to use `%bind` and `%map`. + +Alternatively, the extension can use values from a `Let_syntax` module +other than the one in scope. If you write `%map.A.B.C` instead of +`%map`, the expansion will use `A.B.C.Let_syntax.map` instead of +`Let_syntax.map` (and similarly for all extension points). For monads, `Core.Monad.Make` produces a submodule `Let_syntax` of the appropriate form. -For applicatives. The convention for these modules is to have a submodule -`Let_syntax` of the form +For applicatives, the convention for these modules is to have a submodule +`Let_syntax` of the form: ```ocaml module Let_syntax : sig diff --git a/src/ppx_let.ml b/src/ppx_let.ml index e44d12324..8c5fa76cb 100644 --- a/src/ppx_let.ml +++ b/src/ppx_let.ml @@ -29,12 +29,16 @@ module Extension_name = struct | Map_open -> "map_open" end -let let_syntax = "Let_syntax" +let let_syntax ~modul : Longident.t = + match modul with + | None -> Lident "Let_syntax" + | Some id -> Ldot (id.txt, "Let_syntax") -let open_on_rhs ~loc = Located.mk ~loc (Longident.Ldot (Lident let_syntax, "Open_on_rhs" )) +let open_on_rhs ~loc ~modul = + Located.mk ~loc (Longident.Ldot (let_syntax ~modul, "Open_on_rhs" )) -let eoperator ~loc func = - let lid : Longident.t = Ldot (Longident.Lident let_syntax, func) in +let eoperator ~loc ~modul func = + let lid : Longident.t = Ldot (let_syntax ~modul, func) in pexp_ident ~loc (Located.mk ~loc lid) ;; @@ -54,9 +58,9 @@ let expand_with_tmp_vars ~loc bindings expr ~f = pexp_let ~loc Nonrecursive s_lhs_tmp_var (f ~loc s_rhs_tmp_var expr) ;; -let bind_apply ~loc extension_name ~arg ~fn = +let bind_apply ~loc ~modul extension_name ~arg ~fn = pexp_apply ~loc - (eoperator ~loc (Extension_name.operator_name extension_name)) + (eoperator ~loc ~modul (Extension_name.operator_name extension_name)) [(Nolabel, arg); (Labelled "f", fn)] ;; @@ -67,13 +71,13 @@ let maybe_open extension_name ~to_open:module_to_open expr = | Bind_open | Map_open -> pexp_open ~loc Override (module_to_open ~loc) expr ;; -let expand_let extension_name ~loc bindings body = +let expand_let extension_name ~loc ~modul bindings body = (* Build expression [both E1 (both E2 (both ...))] *) let nested_boths = let rev_boths = List.rev_map bindings ~f:(fun vb -> vb.pvb_expr) in List.reduce_exn rev_boths ~f:(fun acc e -> let loc = e.pexp_loc in - eapply ~loc (eoperator ~loc "both") [e; acc]) + eapply ~loc (eoperator ~loc ~modul "both") [e; acc]) in (* Build pattern [(P1, (P2, ...))] *) let nested_patterns = @@ -82,13 +86,13 @@ let expand_let extension_name ~loc bindings body = let loc = p.ppat_loc in ppat_tuple ~loc [p; acc]) in - bind_apply ~loc extension_name ~arg:nested_boths + bind_apply ~loc ~modul extension_name ~arg:nested_boths ~fn:(pexp_fun ~loc Nolabel None nested_patterns body) ;; -let expand_match extension_name ~loc expr cases = - bind_apply ~loc extension_name - ~arg:(maybe_open extension_name ~to_open:open_on_rhs expr) +let expand_match extension_name ~loc ~modul expr cases = + bind_apply ~loc ~modul extension_name + ~arg:(maybe_open extension_name ~to_open:(open_on_rhs ~modul) expr) ~fn:(pexp_function ~loc cases) ;; @@ -98,7 +102,7 @@ let expand_if extension_name ~loc expr then_ else_ = ; case ~lhs:(pbool ~loc false) ~guard:None ~rhs:else_ ] -let expand ~loc:_ ~path:_ extension_name expr = +let expand ~loc:_ ~path:_ ~arg:modul extension_name expr = let loc = expr.pexp_loc in let expansion = match expr.pexp_desc with @@ -106,15 +110,15 @@ let expand ~loc:_ ~path:_ extension_name expr = let bindings = List.map bindings ~f:(fun vb -> { vb with - pvb_expr = maybe_open extension_name ~to_open:open_on_rhs vb.pvb_expr; + pvb_expr = maybe_open extension_name ~to_open:(open_on_rhs ~modul) vb.pvb_expr; }) in - expand_with_tmp_vars ~loc bindings expr ~f:(expand_let extension_name) + expand_with_tmp_vars ~loc bindings expr ~f:(expand_let extension_name ~modul) | Pexp_let (Recursive, _, _) -> Location.raise_errorf ~loc "'let%%%s' may not be recursive" (Extension_name.to_string extension_name) | Pexp_match (expr, cases) -> - expand_match extension_name ~loc expr cases + expand_match extension_name ~loc ~modul expr cases | Pexp_ifthenelse (expr, then_, else_) -> let else_ = match else_ with @@ -123,7 +127,7 @@ let expand ~loc:_ ~path:_ extension_name expr = Location.raise_errorf ~loc "'if%%%s' must include an else branch" (Extension_name.to_string extension_name) in - expand_if extension_name ~loc expr then_ else_ + expand_if extension_name ~loc ~modul expr then_ else_ | _ -> Location.raise_errorf ~loc "'%%%s' can only be used with 'let', 'match', and 'if'" @@ -133,7 +137,7 @@ let expand ~loc:_ ~path:_ extension_name expr = ;; let ext extension_name = - Extension.declare + Extension.declare_with_path_arg (Extension_name.to_string extension_name) Extension.Context.expression Ast_pattern.(single_expr_payload __) diff --git a/test/test.ml b/test/test.ml index 9c526d27d..5406416c7 100644 --- a/test/test.ml +++ b/test/test.ml @@ -138,3 +138,9 @@ module Applicative_example = struct | 0 -> true | _ -> false end + +module Example_without_open = struct + let _ag a : _ Applicative_example.X.t = + let%map.Applicative_example.X.Let_syntax x = a in + x + 1 +end