diff --git a/META.ab b/META.ab index 1597907eb..6b930b3f2 100644 --- a/META.ab +++ b/META.ab @@ -1,6 +1,6 @@ version = "$(pkg_version)" description = "Monadic let-bindings" -requires = "ppx_core ppx_driver" +requires = "compiler-libs.common ppx_core ppx_driver" archive(ppx_driver, byte ) = "ppx_let.cma" archive(ppx_driver, native) = "ppx_let.cmxa" plugin(ppx_driver, byte ) = "ppx_let.cma" diff --git a/Makefile b/Makefile index 28998046d..8b90c0267 100644 --- a/Makefile +++ b/Makefile @@ -2,7 +2,7 @@ SETUP := setup.exe NAME := ppx_let -PREFIX = $(shell grep ^prefix= setup.data | cut -d\" -f 2) +PREFIX ?= $(shell grep ^prefix= setup.data | cut -d\" -f 2) # Default rule default: build diff --git a/README.md b/README.md index 7e50b0323..de43bbc63 100644 --- a/README.md +++ b/README.md @@ -132,25 +132,18 @@ module Let_syntax : sig val map : 'a t -> f:('a -> 'b) -> 'b t val both : 'a t -> 'b t -> ('a * 'b) t module Open_on_rhs : << some signature >> - module Open_in_body : << some signature >> end ``` -The `Open_on_rhs` and `Open_in_body` submodules are used by variants -of `%map` and `%bind` called `%map_open` and `%bind_open`. +The `Open_on_rhs` submodule is used by variants of `%map` and `%bind` +called `%map_open` and `%bind_open`. It is locally opened on the +right hand sides of the rewritten let bindings in `%map_open` and +`%bind_open` expressions. For `match%map_open` and `match%bind_open` +expressions, `Open_on_rhs` is opened for the expression being matched +on. -The `Open_on_rhs` submodule is locally opened on the right hand sides -of the rewritten let bindings in `%map_open` and `%bind_open` -expressions. This is useful when programming with applicatives, which +`Open_on_rhs` is useful when programming with applicatives, which operate in a staged manner where the operators used to construct the applicatives are distinct from the operators used to manipulate the values those applicatives produce. For monads, `Open_on_rhs` contains `return`. - -The `Open_in_body` submodule is locally opened in the body of either a -`let%map_open` or `let%bind_open`. It is often empty for -applicatives. For monads in `Core`, it contains `return`. - -For `match%map_open` and `match%bind_open` expressions, `Open_on_rhs` -is opened for the expression being matched on, and `Open_in_body` is -opened in the body of each pattern match clause. diff --git a/_oasis b/_oasis index 0ce6f20d9..eb863eaa6 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.33.03 +Version: 113.43+70 Synopsis: Monadic let-bindings Authors: Jane Street Group, LLC Copyrights: (C) 2015-2016 Jane Street Group LLC @@ -25,7 +25,8 @@ Library ppx_let Path: src Pack: false Modules: Ppx_let - BuildDepends: ppx_core, + BuildDepends: compiler-libs.common, + ppx_core, ppx_driver Executable ppx diff --git a/src/ppx_let.ml b/src/ppx_let.ml index 17e3a2777..b3079c11d 100644 --- a/src/ppx_let.ml +++ b/src/ppx_let.ml @@ -33,7 +33,6 @@ end let let_syntax = "Let_syntax" let open_on_rhs ~loc = Located.mk ~loc (Longident.Ldot (Lident let_syntax, "Open_on_rhs" )) -let open_in_body ~loc = Located.mk ~loc (Longident.Ldot (Lident let_syntax, "Open_in_body")) let eoperator ~loc func = let lid : Longident.t = Ldot (Longident.Lident let_syntax, func) in @@ -90,17 +89,10 @@ let expand_let extension_name ~loc bindings body = ppat_tuple ~loc [p; acc]) in bind_apply ~loc extension_name ~arg:nested_boths - ~fn:(pexp_fun ~loc "" None nested_patterns - (maybe_open extension_name ~to_open:open_in_body body)) + ~fn:(pexp_fun ~loc "" None nested_patterns 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 ~to_open:open_in_body case.pc_rhs; - }) - in bind_apply ~loc extension_name ~arg:(maybe_open extension_name ~to_open:open_on_rhs expr) ~fn:(pexp_function ~loc cases) @@ -132,7 +124,7 @@ let expand ~loc:_ ~path:_ extension_name expr = ;; let ext extension_name = - Extension.V2.declare + Extension.declare (Extension_name.to_string extension_name) Extension.Context.expression Ast_pattern.(single_expr_payload __) diff --git a/test/test-locations.mlt b/test/test-locations.mlt index 402dbc4e1..79027c87f 100644 --- a/test/test-locations.mlt +++ b/test/test-locations.mlt @@ -8,7 +8,6 @@ module Let_syntax = 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 ()] diff --git a/test/test.ml b/test/test.ml index 420b25b73..0dc4960fe 100644 --- a/test/test.ml +++ b/test/test.ml @@ -4,11 +4,13 @@ module Monad_example = struct type 'a t module Let_syntax : sig val return : 'a -> 'a t - val bind : 'a t -> ('a -> 'b t) -> 'b 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 + module Let_syntax : sig + val return : 'a -> 'a t + val bind : 'a t -> ('a -> 'b t) -> 'b 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 + end end end = struct type 'a t = 'a @@ -18,15 +20,17 @@ module Monad_example = struct let both x y = (x, y) module Let_syntax = struct let return = return - let bind = bind - let map = map - let both = both - 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 bind = bind + let map = map + let both = both + module Open_on_rhs = struct let return = return end + end end end - module Let_syntax = X.Let_syntax + open X.Let_syntax let _mf a : _ X.t = let%bind_open x = a in @@ -61,13 +65,15 @@ module Applicative_example = struct type 'a t module Let_syntax : sig 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 flag : int t - val anon : int t + module Let_syntax : sig + 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 flag : int t + val anon : int t + end end - module Open_in_body : sig end end end = struct type 'a t = 'a @@ -76,17 +82,19 @@ module Applicative_example = struct let both x y = (x, y) module Let_syntax = struct let return = return - let map = map - let both = both - module Open_on_rhs = struct - let flag = 66 - let anon = 77 + module Let_syntax = struct + let return = return + let map = map + let both = both + module Open_on_rhs = struct + let flag = 66 + let anon = 77 + end end - module Open_in_body = struct end end end - module Let_syntax = X.Let_syntax + open X.Let_syntax (* {[ let _af a : _ X.t = @@ -120,119 +128,3 @@ module Applicative_example = struct | 0 -> true | _ -> false end - -module Async_command_override_example = struct - - module Deferred : sig - type 'a t - val return : 'a -> 'a t - module Let_syntax : sig - 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 - 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 - - module Command : sig - module Param : sig - type 'a t - val return : 'a -> 'a t - val flag : 'a -> int t - val anon : 'a -> int t - end - module Let_syntax : sig - 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 - let return x = x - let map x ~f = f x - let both x y = (x, y) - let flag _ = 66 - let anon _ = 77 - end - module Let_syntax = struct - module Let_syntax = struct - include Param - module Open_on_rhs = Param - module Open_in_body = struct end - end - end - end - - module Command_override = struct - module Param = struct - include Command.Param - let special_flag = flag 88 - end - module Let_syntax = struct - 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 = Deferred.Let_syntax - end - end - end - - let _1 : int Command.Param.t = - let open Command.Let_syntax in - [%map_open - let x = flag "foo" - and y = anon "bar" - in - x + y - ] - ;; - - let _1 : (unit -> int Deferred.t) Command_override.Param.t = - let open Command_override.Let_syntax in - [%map_open - let x = flag "foo" - and y = anon "bar" - and z = special_flag - in - (fun () -> - let%map () = Deferred.return () in - x + y + z) - ] - ;; - - let _1 : (unit -> unit Deferred.t) Command.Param.t = - let open Command_override.Let_syntax in - [%map_open - let () = return () in - fun () -> - let%map () = Deferred.return () in - () - ] - ;; -end