From 4f498086fa76e32ddc35ecfd958d5f78b9a64e8d Mon Sep 17 00:00:00 2001 From: Thomas Refis Date: Wed, 9 Mar 2016 15:44:54 +0000 Subject: [PATCH] 113.33.00 --- _oasis | 2 +- js-utils/install_tags.ml | 4 +-- src/ppx_let.ml | 11 ++++--- test/test-locations.mlt | 19 +++++++++++ test/test.ml | 71 ++++++++++++++++++++++------------------ 5 files changed, 68 insertions(+), 39 deletions(-) create mode 100644 test/test-locations.mlt diff --git a/_oasis b/_oasis index 98075ac8e..0e8538ec4 100644 --- a/_oasis +++ b/_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 Copyrights: (C) 2015-2016 Jane Street Group LLC diff --git a/js-utils/install_tags.ml b/js-utils/install_tags.ml index c0c42dc6e..6f8f3879c 100644 --- a/js-utils/install_tags.ml +++ b/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") ], []) ] diff --git a/src/ppx_let.ml b/src/ppx_let.ml index fa7a986e7..17e3a2777 100644 --- a/src/ppx_let.ml +++ b/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) diff --git a/test/test-locations.mlt b/test/test-locations.mlt new file mode 100644 index 000000000..402dbc4e1 --- /dev/null +++ b/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 +|}] diff --git a/test/test.ml b/test/test.ml index 724543ce8..420b25b73 100644 --- a/test/test.ml +++ b/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 () ->