113.33.00

_oasis

@@ -2,7 +2,7 @@ OASISFormat:      0.4
 OCamlVersion:     >= 4.02.3
 FindlibVersion:   >= 1.3.2
 Name:             ppx_let
-Version:          113.24.00
+Version:          113.33.00
 Synopsis:         Monadic let-bindings
 Authors:          Jane Street Group, LLC <opensource@janestreet.com>
 Copyrights:       (C) 2015-2016 Jane Street Group LLC <opensource@janestreet.com>

js-utils/install_tags.ml

@@ -6,8 +6,8 @@ let sections =
     ],
     [ ("META", None)
     ])
-  ; ("libexec",
-    [ ("built_exec_ppx", Some "ppx")
+  ; ("bin",
+    [ ("built_exec_ppx", Some "../lib/ppx_let/ppx")
     ],
     [])
   ]

src/ppx_let.ml

@@ -67,7 +67,8 @@ let bind_apply ~loc extension_name ~arg ~fn =
     [("", arg); (fn_label, fn)]
 ;;
 
-let maybe_open extension_name ~loc ~to_open:module_to_open expr =
+let maybe_open extension_name ~to_open:module_to_open expr =
+  let loc = expr.pexp_loc in
   match (extension_name : Extension_name.t) with
   | Bind      | Map      -> expr
   | Bind_open | Map_open -> pexp_open ~loc Override (module_to_open ~loc) expr
@@ -90,18 +91,18 @@ let expand_let extension_name ~loc bindings body =
   in
   bind_apply ~loc extension_name ~arg:nested_boths
     ~fn:(pexp_fun ~loc "" None nested_patterns
-           (maybe_open extension_name ~loc ~to_open:open_in_body body))
+           (maybe_open extension_name ~to_open:open_in_body body))
 ;;
 
 let expand_match extension_name ~loc expr cases =
   let cases =
     List.map cases ~f:(fun case ->
       { case with
-        pc_rhs = maybe_open extension_name ~loc ~to_open:open_in_body case.pc_rhs;
+        pc_rhs = maybe_open extension_name ~to_open:open_in_body case.pc_rhs;
       })
   in
   bind_apply ~loc extension_name
-    ~arg:(maybe_open extension_name ~loc ~to_open:open_on_rhs expr)
+    ~arg:(maybe_open extension_name ~to_open:open_on_rhs expr)
     ~fn:(pexp_function ~loc cases)
 ;;
 
@@ -113,7 +114,7 @@ let expand ~loc:_ ~path:_ extension_name expr =
       let bindings =
         List.map bindings ~f:(fun vb ->
           { vb with
-            pvb_expr = maybe_open extension_name ~loc ~to_open:open_on_rhs vb.pvb_expr;
+            pvb_expr = maybe_open extension_name ~to_open:open_on_rhs vb.pvb_expr;
           })
       in
       expand_with_tmp_vars ~loc bindings expr ~f:(expand_let extension_name)

test/test-locations.mlt

@@ -0,0 +1,19 @@
+(* -*- tuareg -*- *)
+
+module Let_syntax = struct
+  type 'a t = T of 'a
+  let map (T x) ~f = T (f x)
+  let both (T x) (T y) = T (x, y)
+  module Open_on_rhs = struct
+    let return x = T x
+    let f x ~(doc:string) = T (x, doc)
+  end
+  module Open_in_body = struct end
+end
+
+let _ = [%map_open let x = return 42 and y = f 42 in ()]
+[%%expect{|
+Line _, characters 45-49:
+Error: This expression has type doc:bytes -> (int * bytes) Let_syntax.t
+       but an expression was expected of type 'a Let_syntax.t
+|}]

test/test.ml

@@ -127,22 +127,26 @@ module Async_command_override_example = struct
     type 'a t
     val return : 'a -> 'a t
     module Let_syntax : sig
-      type 'a t
-      val return : 'a -> 'a t
-      val map    : 'a t -> f:('a -> 'b) -> 'b t
-      val both   : 'a t -> 'b t -> ('a * 'b) t
-      module Open_on_rhs  : sig val return : 'a -> 'a t end
-      module Open_in_body : sig val return : 'a -> 'a t end
-    end with type 'a t := 'a t
+      module Let_syntax : sig
+        type 'a t
+        val return : 'a -> 'a t
+        val map    : 'a t -> f:('a -> 'b) -> 'b t
+        val both   : 'a t -> 'b t -> ('a * 'b) t
+        module Open_on_rhs  : sig val return : 'a -> 'a t end
+        module Open_in_body : sig val return : 'a -> 'a t end
+      end with type 'a t := 'a t
+    end
   end = struct
     type 'a t = 'a
     let return x = x
     module Let_syntax = struct
-      let return = return
-      let map x ~f = f x
-      let both x y = (x, y)
-      module Open_on_rhs  = struct let return = return end
-      module Open_in_body = struct let return = return end
+      module Let_syntax = struct
+        let return = return
+        let map x ~f = f x
+        let both x y = (x, y)
+        module Open_on_rhs  = struct let return = return end
+        module Open_in_body = struct let return = return end
+      end
     end
   end
 
@@ -154,13 +158,15 @@ module Async_command_override_example = struct
       val anon : 'a -> int t
     end
     module Let_syntax : sig
-      type 'a t
-      val return : 'a -> 'a t
-      val map    : 'a t -> f:('a -> 'b) -> 'b t
-      val both   : 'a t -> 'b t -> ('a * 'b) t
-      module Open_on_rhs = Param
-      module Open_in_body : sig end
-    end with type 'a t := 'a Param.t
+      module Let_syntax : sig
+        type 'a t
+        val return : 'a -> 'a t
+        val map    : 'a t -> f:('a -> 'b) -> 'b t
+        val both   : 'a t -> 'b t -> ('a * 'b) t
+        module Open_on_rhs = Param
+        module Open_in_body : sig end
+      end with type 'a t := 'a Param.t
+    end
   end = struct
     module Param = struct
       type 'a t = 'a
@@ -171,9 +177,11 @@ module Async_command_override_example = struct
       let anon _ = 77
     end
     module Let_syntax = struct
-      include Param
-      module Open_on_rhs = Param
-      module Open_in_body = struct end
+      module Let_syntax = struct
+        include Param
+        module Open_on_rhs = Param
+        module Open_in_body = struct end
+      end
     end
   end
 
@@ -183,19 +191,20 @@ module Async_command_override_example = struct
       let special_flag = flag 88
     end
     module Let_syntax = struct
-      include (Command.Let_syntax : module type of Command.Let_syntax
-               with module Open_on_rhs  := Command.Let_syntax.Open_on_rhs
-                and module Open_in_body := Command.Let_syntax.Open_in_body)
+      open Command.Let_syntax
+      module Let_syntax = struct
+        include (Let_syntax : module type of Let_syntax
+                 with module Open_on_rhs  := Let_syntax.Open_on_rhs
+                  and module Open_in_body := Let_syntax.Open_in_body)
 
-      module Open_on_rhs = Param
-      module Open_in_body = struct
-        module Let_syntax = Deferred.Let_syntax
+        module Open_on_rhs = Param
+        module Open_in_body = Deferred.Let_syntax
       end
     end
   end
 
   let _1 : int Command.Param.t =
-    let module Let_syntax = Command.Let_syntax in
+    let open Command.Let_syntax in
     [%map_open
       let x = flag "foo"
       and y = anon "bar"
@@ -205,7 +214,7 @@ module Async_command_override_example = struct
   ;;
 
   let _1 : (unit -> int Deferred.t) Command_override.Param.t =
-    let module Let_syntax = Command_override.Let_syntax in
+    let open Command_override.Let_syntax in
     [%map_open
       let x = flag "foo"
       and y = anon "bar"
@@ -218,7 +227,7 @@ module Async_command_override_example = struct
   ;;
 
   let _1 : (unit -> unit Deferred.t) Command.Param.t =
-    let module Let_syntax = Command_override.Let_syntax in
+    let open Command_override.Let_syntax in
     [%map_open
       let () = return () in
       fun () ->