v0.11.117.10+09

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.

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

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 __)

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