From abe81261518513e62d395c214e3e568c447ea540 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Fri, 19 Apr 2019 11:59:32 +0200 Subject: [PATCH] Single point of configuration to add many let%foo directives --- expander/ppx_let_expander.ml | 61 ++++++++++++----------------------- expander/ppx_let_expander.mli | 12 +------ src/ppx_let.ml | 11 ++++--- test/test.ml | 18 +++++++++++ 4 files changed, 46 insertions(+), 56 deletions(-) diff --git a/expander/ppx_let_expander.ml b/expander/ppx_let_expander.ml index c6eabf695..9a41e63c4 100644 --- a/expander/ppx_let_expander.ml +++ b/expander/ppx_let_expander.ml @@ -12,34 +12,14 @@ module List = struct ;; end -module Extension_name = struct - type t = - | Bind - | Bind_open - | Map - | Map_open - - let operator_name = function - | Bind | Bind_open -> "bind" - | Map | Map_open -> "map" - ;; - - let to_string = function - | Bind -> "bind" - | Bind_open -> "bind_open" - | Map -> "map" - | Map_open -> "map_open" - ;; -end - 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 ~modul = - Located.mk ~loc (Longident.Ldot (let_syntax ~modul, "Open_on_rhs")) +let open_on_rhs ~loc ~modul ~extension_name_s = + Located.mk ~loc (Longident.Ldot (let_syntax ~modul, "Open_on_rhs_" ^ extension_name_s)) ;; let eoperator ~loc ~modul func = @@ -65,21 +45,20 @@ 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 ~modul extension_name ~arg ~fn = +let bind_apply ~loc ~modul extension_name_s ~arg ~fn = pexp_apply ~loc - (eoperator ~loc ~modul (Extension_name.operator_name extension_name)) + (eoperator ~loc ~modul extension_name_s) [ Nolabel, arg; Labelled "f", fn ] ;; -let maybe_open extension_name ~to_open:module_to_open expr = +(* Change by Georges: Always open for all extension names. *) +let maybe_open ~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 + pexp_open ~loc Override (module_to_open ~loc) expr ;; -let expand_let extension_name ~loc ~modul bindings body = +let expand_let extension_name_s ~loc ~modul bindings body = if List.is_empty bindings then invalid_arg "expand_let: list of bindings must be non-empty"; (* Build expression [both E1 (both E2 (both ...))] *) @@ -99,17 +78,17 @@ let expand_let extension_name ~loc ~modul bindings body = bind_apply ~loc ~modul - extension_name + extension_name_s ~arg:nested_boths ~fn:(pexp_fun ~loc Nolabel None nested_patterns body) ;; -let expand_match extension_name ~loc ~modul expr cases = +let expand_match extension_name_s ~loc ~modul expr cases = bind_apply ~loc ~modul - extension_name - ~arg:(maybe_open extension_name ~to_open:(open_on_rhs ~modul) expr) + extension_name_s + ~arg:(maybe_open ~to_open:(open_on_rhs ~modul ~extension_name_s) expr) ~fn:(pexp_function ~loc cases) ;; @@ -123,7 +102,7 @@ let expand_if extension_name ~loc expr then_ else_ = ] ;; -let expand ~modul extension_name expr = +let expand ~modul extension_name_s expr = let loc = expr.pexp_loc in let expansion = match expr.pexp_desc with @@ -145,16 +124,16 @@ let expand ~modul extension_name expr = { vb with pvb_pat ; pvb_expr = - maybe_open extension_name ~to_open:(open_on_rhs ~modul) vb.pvb_expr + maybe_open ~to_open:(open_on_rhs ~modul ~extension_name_s) vb.pvb_expr }) in - expand_with_tmp_vars ~loc bindings expr ~f:(expand_let extension_name ~modul) + expand_with_tmp_vars ~loc bindings expr ~f:(expand_let extension_name_s ~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 ~modul expr cases + extension_name_s + | Pexp_match (expr, cases) -> expand_match extension_name_s ~loc ~modul expr cases | Pexp_ifthenelse (expr, then_, else_) -> let else_ = match else_ with @@ -163,14 +142,14 @@ let expand ~modul extension_name expr = Location.raise_errorf ~loc "'if%%%s' must include an else branch" - (Extension_name.to_string extension_name) + extension_name_s in - expand_if extension_name ~loc ~modul expr then_ else_ + expand_if extension_name_s ~loc ~modul expr then_ else_ | _ -> Location.raise_errorf ~loc "'%%%s' can only be used with 'let', 'match', and 'if'" - (Extension_name.to_string extension_name) + extension_name_s in { expansion with pexp_attributes = expr.pexp_attributes @ expansion.pexp_attributes } ;; diff --git a/expander/ppx_let_expander.mli b/expander/ppx_let_expander.mli index 71333f8a8..be89bf69d 100644 --- a/expander/ppx_let_expander.mli +++ b/expander/ppx_let_expander.mli @@ -1,13 +1,3 @@ open Ppxlib -module Extension_name : sig - type t = - | Bind - | Bind_open - | Map - | Map_open - - val to_string : t -> string -end - -val expand : modul:longident loc option -> Extension_name.t -> expression -> expression +val expand : modul:longident loc option -> string -> expression -> expression diff --git a/src/ppx_let.ml b/src/ppx_let.ml index 3f9985502..257c3bb09 100644 --- a/src/ppx_let.ml +++ b/src/ppx_let.ml @@ -1,16 +1,19 @@ open Ppxlib -let ext extension_name = +let ext extension_name_s = Extension.declare_with_path_arg - (Ppx_let_expander.Extension_name.to_string extension_name) + extension_name_s Extension.Context.expression Ast_pattern.(single_expr_payload __) (fun ~loc:_ ~path:_ ~arg expr -> - Ppx_let_expander.expand extension_name ~modul:arg expr) + Ppx_let_expander.expand extension_name_s ~modul:arg expr) ;; let () = Driver.register_transformation "let" - ~extensions:[ ext Bind; ext Bind_open; ext Map; ext Map_open ] + ~extensions:(List.map ext [ + "bind"; + "xxx"; + ]) ;; diff --git a/test/test.ml b/test/test.ml index ac502de51..d42d663b6 100644 --- a/test/test.ml +++ b/test/test.ml @@ -1,3 +1,20 @@ +module Monad_example = struct + module Let_syntax = struct + let bind x ~f = f x + module Open_on_rhs_bind = struct + let return _ = "foo" + end + end + + let _mf a = + let%bind xyz = return a in + (int_of_string xyz + 1) + ;; +end + +(* TODO: re-enable some tests *) + +(* module Monad_example = struct module X : sig type 'a t @@ -169,3 +186,4 @@ module Example_without_open = struct x + 1 ;; end +*)