pax_global_header00006660000000000000000000000064142027330520014510gustar00rootroot0000000000000052 comment=9cd7d3cfc0dc5686036cb5b4453f0f58dfba0173 ppx_let-0.15.0/000077500000000000000000000000001420273305200132465ustar00rootroot00000000000000ppx_let-0.15.0/.gitignore000066400000000000000000000000411420273305200152310ustar00rootroot00000000000000_build *.install *.merlin _opam ppx_let-0.15.0/CHANGES.md000066400000000000000000000011661420273305200146440ustar00rootroot00000000000000## 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. ## 113.43.00 - Dropped `Open_in_body` support from ppx\_let, since it was only ever used in confusing chains of `Let_syntax` modules that introduced other `Let_syntax` modules in the "body" (e.g. for defining Commands whose bodies use Async). In this case it was decided that the better practice is to be explicit with `open ___.Let_syntax` at the different transition points, even though this is more verbose. ppx_let-0.15.0/CONTRIBUTING.md000066400000000000000000000044101420273305200154760ustar00rootroot00000000000000This repository contains open source software that is developed and maintained by [Jane Street][js]. Contributions to this project are welcome and should be submitted via GitHub pull requests. Signing contributions --------------------- We require that you sign your contributions. Your signature certifies that you wrote the patch or otherwise have the right to pass it on as an open-source patch. The rules are pretty simple: if you can certify the below (from [developercertificate.org][dco]): ``` Developer Certificate of Origin Version 1.1 Copyright (C) 2004, 2006 The Linux Foundation and its contributors. 1 Letterman Drive Suite D4700 San Francisco, CA, 94129 Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Developer's Certificate of Origin 1.1 By making a contribution to this project, I certify that: (a) The contribution was created in whole or in part by me and I have the right to submit it under the open source license indicated in the file; or (b) The contribution is based upon previous work that, to the best of my knowledge, is covered under an appropriate open source license and I have the right under that license to submit that work with modifications, whether created in whole or in part by me, under the same open source license (unless I am permitted to submit under a different license), as indicated in the file; or (c) The contribution was provided directly to me by some other person who certified (a), (b) or (c) and I have not modified it. (d) I understand and agree that this project and the contribution are public and that a record of the contribution (including all personal information I submit with it, including my sign-off) is maintained indefinitely and may be redistributed consistent with this project or the open source license(s) involved. ``` Then you just add a line to every git commit message: ``` Signed-off-by: Joe Smith ``` Use your real name (sorry, no pseudonyms or anonymous contributions.) If you set your `user.name` and `user.email` git configs, you can sign your commit automatically with git commit -s. [dco]: http://developercertificate.org/ [js]: https://opensource.janestreet.com/ ppx_let-0.15.0/LICENSE.md000066400000000000000000000021351420273305200146530ustar00rootroot00000000000000The MIT License Copyright (c) 2015--2022 Jane Street Group, LLC Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ppx_let-0.15.0/Makefile000066400000000000000000000004031420273305200147030ustar00rootroot00000000000000INSTALL_ARGS := $(if $(PREFIX),--prefix $(PREFIX),) default: dune build install: dune install $(INSTALL_ARGS) uninstall: dune uninstall $(INSTALL_ARGS) reinstall: uninstall install clean: dune clean .PHONY: default install uninstall reinstall clean ppx_let-0.15.0/README.md000066400000000000000000000263661420273305200145420ustar00rootroot00000000000000ppx_let ======= A ppx rewriter for monadic and applicative let bindings, match expressions, and if expressions. Overview -------- The aim of this rewriter is to make monadic and applicative code look nicer by writing custom binders the same way that we normally bind variables. In OCaml, the common way to bind the result of a computation to a variable is: ```ocaml let VAR = EXPR in BODY ``` ppx\_let simply adds two new binders: `let%bind` and `let%map`. These are rewritten into calls to the `bind` and `map` functions respectively. These functions are expected to have ```ocaml val map : 'a t -> f:('a -> 'b) -> 'b t val bind : 'a t -> f:('a -> 'b t) -> 'b t ``` for some type `t`, as one might expect. These functions are to be provided by the user, and are generally expected to be part of the signatures of monads and applicatives modules. This is the case for all monads and applicatives defined by the Jane Street's Core suite of libraries. (see the section below on getting the right names into scope). ### Parallel bindings ppx\_let understands parallel bindings as well. i.e.: ```ocaml let%bind VAR1 = EXPR1 and VAR2 = EXPR2 and VAR3 = EXPR3 in BODY ``` The `and` keyword is seen as a binding combination operator. To do so it expects the presence of a `both` function, that lifts the OCaml pair operation to the type `t` in question: ```ocaml val both : 'a t -> 'b t -> ('a * 'b) t ``` Some applicatives have optimized `map` functions for more than two arguments. These applicatives will export functions like `map4` shown below: ```ocaml val map4: 'a t -> 'b t -> 'c t -> 'd t -> f:('a -> 'b -> 'c -> 'd -> 'r) -> 'r t ``` In order to use these optmized functions, ppx\_let provides the `let%mapn` syntax, which picks the right `map{n}` function to call based on the amount of applicatives bound by the syntax. ### Match statements We found that this form was quite useful for match statements as well. So for convenience ppx\_let also accepts `%bind` and `%map` on the `match` keyword. Morally `match%bind expr with cases` is seen as `let%bind x = expr in match x with cases`. ### If statements As a further convenience, ppx\_let accepts `%bind` and `%map` on the `if` keyword. The expression `if%bind expr1 then expr2 else expr3` is morally equivalent to `let%bind p = expr1 in if p then expr2 else expr3`. ### Function statements We accept `function%bind` and `function%map` too. ```ocaml let f = function%bind | Some a -> g a | None -> h ``` is equivalent to ```ocaml let f = fun temp -> match%bind temp with | Some a -> g a | None -> h ``` ### While statements We also expand `while%bind expr1 do expr2 done` as ```ocaml let rec loop () = if%bind expr1 then ( let%bind () = expr2 in loop ()) else return () in loop () ``` Note that this form will (potentially) evaluate the textual form of expr1 multiple times! We do not support `while%map`, as that cannot be implemented without `bind`. Syntactic forms and actual rewriting ------------------------------------ `ppx_let` adds seven syntactic forms ```ocaml let%bind P = M in E let%map P = M in E let%sub P = M in E match%bind M with P1 -> E1 | P2 -> E2 | ... match%map M with P1 -> E1 | P2 -> E2 | ... if%bind M then E1 else E2 if%map M then E1 else E2 while%bind M do E done ``` that expand into ```ocaml bind M ~f:(fun P -> E) map M ~f:(fun P -> E) sub M ~f:(fun P -> E) bind M ~f:(function P1 -> E1 | P2 -> E2 | ...) map M ~f:(function P1 -> E1 | P2 -> E2 | ...) bind M ~f:(function true -> E1 | false -> E2) map M ~f:(function true -> E1 | false -> E2) let rec loop () = bind M ~f:(function true -> bind E ~f:loop | false -> return ()) in loop () ``` respectively. As with `let`, `let%bind` and `let%map` also support multiple *parallel* bindings via the `and` keyword: ```ocaml let%bind P1 = M1 and P2 = M2 and P3 = M3 and P4 = M4 in E let%map P1 = M1 and P2 = M2 and P3 = M3 and P4 = M4 in E ``` that expand into ```ocaml let x1 = M1 and x2 = M2 and x3 = M3 and x4 = M4 in bind (both x1 (both x2 (both x3 x4))) ~f:(fun (P1, (P2, (P3, P4))) -> E) let x1 = M1 and x2 = M2 and x3 = M3 and x4 = M4 in map (both x1 (both x2 (both x3 x4))) ~f:(fun (P1, (P2, (P3, P4))) -> E) ``` respectively. (Instead of `x1`, `x2`, ... ppx\_let uses variable names that are unlikely to clash with other names) Unlike `let%map` and `let%bind`, `let%sub` does _not_ permit multiple bindings via the `and` keyword. As with `let`, names introduced by left-hand sides of the let bindings are not available in subsequent right-hand sides of the same sequence. 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`. The intended way to do this is to create a module `Let_syntax` with a signature like: ```ocaml module Let_syntax : sig module Let_syntax : sig val bind : ... val map : ... ... end ... end ``` and then use `open Let_syntax` to make the inner `Let_syntax` module available. 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.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: ```ocaml module Let_syntax : sig 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 : << some signature >> end end ``` 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. `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`. let%sub ------- `let%sub` is a form almost equivalent to `let%bind` but calling a function called [sub] instead of [bind]. The intended use case is for things which have a "bind-like" operation with a type like: ```ocaml val sub : 'a t -> f:('a s -> 'b t) -> 'b t ``` (e.g. a relative monad) The name comes from the quintessential example of such an operation: substitution of terms for variables. We didn't want to just use [let%bind] for such functions as it might confuse people. There is one large difference between `let%sub` and `let%bind` stemming from the difference in the expected signatures of `sub` and `bind`. Since the value passed into `f` is not totally "unwrapped", it cannot be directly destructured. Because accessing the components of complex structures is often desirable, `let%sub` does the extra work. The below code snippet ```ocaml let%sub a, b = c in BODY ``` gets roughly translated to ```ocaml let%sub temp_var = c in let%sub a = return (map ~f:(fun (a, _) -> a) temp_var) in let%sub b = return (map ~f:(fun (_, b) -> a) temp_var) in BODY ``` The one potentially unexpected part of this is the usage of `return` followed immediately by `let%sub`, which seems like a no-op. Why not do this instead? ```ocaml let%sub temp_var = c in let a = map ~f:(fun (a, _) -> a) temp_var in let b = map ~f:(fun (_, b) -> a) temp_var in BODY ``` The difference is that the second option binds `a` and `b` to the *computations* that map `temp_var` to its components, but the first option binds `a` and `b` to the components *after the mappings have occurred*. Conceptually this means that for the first, correct desugaring, reusing `a` and `b` does not duplicate the mapping computation, but for the second desugaring, every usage of `a` or `b` refers to a duplicate of its computation. match%sub --------- Rather than depending on a `bind` operation, `match%sub` depends on the presence of a `switch` function (the concrete Bonsai version is shown below). Note that the type of the expression being matched is `Value.t` rather than `Computation.t`. ```ocaml val switch : match_:int Value.t -> branches:int -> with_:(int -> 'a Computation.t) -> 'a Computation.t ``` Example: ```ocaml let f (either_value : (_, _) Either.t Value.t) page1 page2 = let open Bonsai.Let_syntax in match%sub either_value with | First (a, b) -> page1 a b | Second x -> page2 x ;; ``` expands to roughly the following ```ocaml let f (either_value : (_, _) Either.t Value.t) page1 page2 = let open Bonsai.Let_syntax in let%sub either_value = return either_value in Let_syntax.switch ~match_: (match%map either_value with | First (_, _) -> 0 | Second _ -> 1) ~branches:2 ~with_:(function | 0 -> let%sub a = return (match%map either_value with | First (a, _) -> a | _ -> assert false) in let%sub b = return (match%map either_value with | First (_, b) -> b | _ -> assert false) in page1 a b | 1 -> let%sub x = Bonsai.Let_syntax.return (match%map either_value with | Second x -> x | _ -> assert false) in page2 x | _ -> assert false) ;; ``` let%arr ------- One way of looking at arrow programs (i.e. programs involving `let%sub`) is that `let%map...and` builds a computation that does work, and `let%sub` saves the work to a variable so that other computations can share the result. A common mistake is to forget to save a computation; when the computation gets used twice, the work must be done twice, rather than getting shared between the two occurrences. The form `let%arr...and` aims to eliminate such mistakes via the type-system. It extends the `Let_syntax` module with an `arr` function that lifts a function to an arrow. ```ocaml val arr : 'a Value.t -> f:('a -> 'b) -> 'b Computation.t ``` The signature is the same as `map` except the result is a `Computation.t`, and not a `Value.t`. The implementation of `arr` is equivalent to `return (map x ~f)`. Roughly the only thing you can do with a `Computation.t` is use `let%sub` to gain access to a `Value.t` handle to the computation. Thus, using `arr` forces the user to use as much sharing as possible. Of course, you can always duplicate work by copy-pasting code, but it won't happen accidentally. An unrelated distinction of `let%arr` is that it tracks `Lexing.position`. That is, the signature of `arr` is actually the following: ```ocaml val arr : ?here:Lexing.position -> 'a Value.t -> f:('a -> 'b) -> 'b Computation.t ``` The `let%arr` form is as a testing ground for source location tracking. It's likely that eventually all the other binding forms will also track location. ppx_let-0.15.0/dune000066400000000000000000000000001420273305200141120ustar00rootroot00000000000000ppx_let-0.15.0/dune-project000066400000000000000000000000201420273305200155600ustar00rootroot00000000000000(lang dune 1.10)ppx_let-0.15.0/expander/000077500000000000000000000000001420273305200150545ustar00rootroot00000000000000ppx_let-0.15.0/expander/dune000066400000000000000000000002111420273305200157240ustar00rootroot00000000000000(library (name ppx_let_expander) (public_name ppx_let.expander) (libraries base ppxlib ppx_here.expander) (preprocess no_preprocessing))ppx_let-0.15.0/expander/ppx_let_expander.ml000066400000000000000000000473541420273305200207640ustar00rootroot00000000000000open Base open Ppxlib open Ast_builder.Default let pexp_let ~loc rec_ bindings e = match bindings with | [] -> e | _ :: _ -> pexp_let ~loc rec_ bindings e ;; module List = struct include List let reduce_exn l ~f = match l with | [] -> invalid_arg "List.reduce_exn" | hd :: tl -> fold_left tl ~init:hd ~f ;; end module Extension_kind = struct type t = { do_open : bool ; collapse_binds : bool } let default = { do_open = false; collapse_binds = false } let default_open = { do_open = true; collapse_binds = false } let n = { do_open = false; collapse_binds = true } let n_open = { do_open = true; collapse_binds = true } end module type Ext = sig (* The base string of all the related extensions. For example, if the value is "bind", then other extensions will include "bind_open", "bindn", and "bindn_open" - all of which start with "bind" *) val name : string val with_location : bool (* Called before each expansion to ensure that the expression being expanded is supported. *) val disallow_expression : Extension_kind.t -> expression_desc -> (unit, string) Result.t (* Called when expanding a let-binding (and indirectly, when expanding a match-expression) to destructure [rhs]. The resulting expression should make each variable in [lhs] available for use in [body]. If the result is [None], then no special destructuring is necessary. *) val destruct : assume_exhaustive:bool -> loc:location -> modul:longident loc option -> lhs:pattern -> rhs:expression -> body:expression -> expression option (* Expands any match%[name] expressions. It is also used when expanding if%[name]. *) val expand_match : loc:location -> modul:longident loc option -> expression -> case list -> expression end type t = (module Ext) let ext_full_name (module Ext : Ext) { Extension_kind.do_open; collapse_binds; _ } = let result = Ext.name in let result = if collapse_binds then String.concat [ result; "n" ] else result in if do_open then String.concat [ result; "_open" ] else result ;; let let_syntax = "Let_syntax" let let_syntax ~modul : Longident.t = match modul with | None -> Lident let_syntax | Some id -> Ldot (Ldot (id.txt, let_syntax), let_syntax) ;; let open_on_rhs ~loc ~modul = pmod_ident ~loc (Located.mk ~loc (Longident.Ldot (let_syntax ~modul, "Open_on_rhs"))) ;; let eoperator ~loc ~modul func = let lid : Longident.t = Ldot (let_syntax ~modul, func) in pexp_ident ~loc (Located.mk ~loc lid) ;; let qualified_return ~loc ~modul expr = pexp_apply ~loc (eoperator ~loc ~modul "return") [ Nolabel, expr ] ;; let location_arg ~loc = Labelled "here", Ppx_here_expander.lift_position ~loc let bind_apply ~op_name ~loc ~modul ~with_location ~arg ~fn = let args = if with_location then [ location_arg ~loc; Nolabel, arg; Labelled "f", fn ] else [ Nolabel, arg; Labelled "f", fn ] in pexp_apply ~loc (eoperator ~loc ~modul op_name) args ;; let expand_with_tmp_vars ~loc bindings expr ~f = match bindings with | [ _ ] -> f ~loc bindings expr | _ -> (* s/rhs/tmp_var and s/lhs/tmp_var *) let s_rhs_tmp_var, s_lhs_tmp_var = List.map bindings ~f:(fun vb -> let var = gen_symbol ~prefix:"__let_syntax" () in let loc = { vb.pvb_expr.pexp_loc with loc_ghost = true } in let rhs = { vb with pvb_expr = evar ~loc var } in let loc = { vb.pvb_pat.ppat_loc with loc_ghost = true } in let lhs = { vb with pvb_pat = pvar ~loc var ; pvb_loc = { vb.pvb_loc with loc_ghost = true } } in rhs, lhs) |> List.unzip in pexp_let ~loc Nonrecursive s_lhs_tmp_var (f ~loc s_rhs_tmp_var expr) ;; let catch_all_case ~loc = case ~lhs:(ppat_any ~loc) ~guard:None ~rhs:(pexp_assert ~loc (ebool ~loc false)) ;; let maybe_destruct ~destruct ~loc ~modul ~lhs ~body = let whole_value_var = gen_symbol ~prefix:"__pattern_syntax" () in let whole_value_pattern = ppat_var ~loc { txt = whole_value_var; loc } in let whole_value_expr = pexp_ident ~loc { txt = Lident whole_value_var; loc } in match destruct ~assume_exhaustive:true ~loc ~modul ~lhs ~rhs:whole_value_expr ~body with | Some destruction -> pexp_fun ~loc Nolabel None whole_value_pattern destruction | None -> pexp_fun ~loc Nolabel None lhs body ;; let expand_letn (module Ext : Ext) ~loc ~modul bindings body = let n = List.length bindings in let operator = match n with | 1 -> eoperator ~loc ~modul Ext.name | n -> eoperator ~loc ~modul (Printf.sprintf "%s%d" Ext.name n) in let bindings_args = bindings |> List.map ~f:(fun { pvb_expr; _ } -> Nolabel, pvb_expr) in let func = List.fold_right bindings ~init:body ~f:(fun { pvb_pat; _ } lower -> maybe_destruct ~destruct:Ext.destruct ~modul ~loc ~lhs:pvb_pat ~body:lower) in let args = bindings_args @ if Ext.with_location then [ location_arg ~loc; Labelled "f", func ] else [ Labelled "f", func ] in pexp_apply ~loc operator args ;; let maybe_open ~extension_kind ~to_open:module_to_open expr = let loc = { expr.pexp_loc with loc_ghost = true } in if extension_kind.Extension_kind.do_open then pexp_open ~loc (open_infos ~loc ~override:Override ~expr:(module_to_open ~loc)) expr else expr ;; let expand_let (module Ext : Ext) ~loc ~modul bindings body = if List.length bindings = 0 then invalid_arg "expand_let: list of bindings must be non-empty"; (* 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 with loc_ghost = true } in eapply ~loc (eoperator ~loc ~modul "both") [ e; acc ]) in (* Build pattern [(P1, (P2, ...))] *) let nested_patterns = let rev_patts = List.rev_map bindings ~f:(fun vb -> vb.pvb_pat) in List.reduce_exn rev_patts ~f:(fun acc p -> let loc = { p.ppat_loc with loc_ghost = true } in ppat_tuple ~loc [ p; acc ]) in let fn = maybe_destruct ~destruct:Ext.destruct ~loc ~modul ~lhs:nested_patterns ~body in bind_apply ~op_name:Ext.name ~loc ~modul ~with_location:Ext.with_location ~arg:nested_boths ~fn ;; let expand_match (module Ext : Ext) ~extension_kind ~loc ~modul expr cases = let expr = maybe_open ~extension_kind ~to_open:(open_on_rhs ~modul) expr in Ext.expand_match ~loc ~modul expr cases ;; let expand_if t ~extension_kind ~loc ~modul expr then_ else_ = expand_match t ~extension_kind ~loc ~modul expr [ case ~lhs:(pbool ~loc true) ~guard:None ~rhs:then_ ; case ~lhs:(pbool ~loc false) ~guard:None ~rhs:else_ ] ;; let expand_while (module Ext : Ext) ~extension_kind ~loc ~modul ~cond ~body = let loop_name = gen_symbol ~prefix:"__let_syntax_loop" () in let ploop = pvar ~loc loop_name in let eloop = evar ~loc loop_name in let loop_call = pexp_apply ~loc eloop [ Nolabel, eunit ~loc ] in let loop_body = let then_ = bind_apply ~op_name:Ext.name ~loc ~modul ~with_location:Ext.with_location ~arg:body ~fn:eloop in let else_ = qualified_return ~loc ~modul (eunit ~loc) in expand_if (module Ext) ~extension_kind ~modul ~loc cond then_ else_ in let loop_func = pexp_fun ~loc Nolabel None (punit ~loc) loop_body in pexp_let ~loc Recursive [ value_binding ~loc ~pat:ploop ~expr:loop_func ] loop_call ;; module Map : Ext = struct let name = "map" let with_location = false let disallow_expression _ = function | Pexp_while (_, _) -> Error "while%%map is not supported. use while%%bind instead." | _ -> Ok () ;; let destruct ~assume_exhaustive:_ ~loc:_ ~modul:_ ~lhs:_ ~rhs:_ ~body:_ = None let expand_match ~loc ~modul expr cases = bind_apply ~loc ~modul ~with_location ~op_name:name ~arg:expr ~fn:(pexp_function ~loc cases) ;; end module Bind : Ext = struct let name = "bind" let with_location = false let disallow_expression { Extension_kind.collapse_binds; _ } = function | Pexp_while (_, _) when collapse_binds -> Error "while%%bindn is not supported. use while%%bind instead." | _ -> Ok () ;; let destruct ~assume_exhaustive:_ ~loc:_ ~modul:_ ~lhs:_ ~rhs:_ ~body:_ = None let expand_match ~loc ~modul expr cases = bind_apply ~loc ~modul ~with_location ~op_name:name ~arg:expr ~fn:(pexp_function ~loc cases) ;; end let variables_of = object inherit [string Ppxlib.loc list] Ast_traverse.fold as super method! pattern p acc = let acc = super#pattern p acc in match p.ppat_desc with | Ppat_var var -> var :: acc | Ppat_alias (_, var) -> var :: acc | _ -> acc end ;; let pattern_variables pattern = List.dedup_and_sort ~compare:(fun x y -> String.compare x.txt y.txt) (variables_of#pattern pattern []) ;; type pat_exh = { pat : pattern ; assume_exhaustive : bool } let replace_variable ~f = let replacer = object inherit Ast_traverse.map as super method! pattern p = let p = super#pattern p in let loc = { p.ppat_loc with loc_ghost = true } in match p.ppat_desc with | Ppat_var v -> (match f v with | `Rename tmpvar -> ppat_var ~loc { txt = tmpvar; loc = v.loc } | `Remove -> ppat_any ~loc) | Ppat_alias (sub, v) -> (match f v with | `Rename tmpvar -> ppat_alias ~loc sub { txt = tmpvar; loc = v.loc } | `Remove -> sub) | _ -> p end in replacer#pattern ;; let with_warning_attribute str expr = let loc = expr.pexp_loc in { expr with pexp_attributes = attribute ~loc ~name:(Loc.make ~loc "ocaml.warning") ~payload:(PStr [ pstr_eval ~loc (estring ~loc str) [] ]) :: expr.pexp_attributes } ;; let project_bound_var ~loc ~modul ~with_location exp ~pat:{ pat; assume_exhaustive } var = let project_the_var = (* We use a fresh var name because the compiler conflates all definitions with the name * location, for the purpose of emitting warnings. *) let tmpvar = gen_symbol ~prefix:"__pattern_syntax" () in let pattern = replace_variable pat ~f:(fun v -> if String.equal v.txt var.txt then `Rename tmpvar else `Remove) in case ~lhs:pattern ~guard:None ~rhs:(evar ~loc tmpvar) in let fn = if assume_exhaustive then pexp_function ~loc [ project_the_var ] else with_warning_attribute "-11" (* unused case warning *) (pexp_function ~loc [ project_the_var; catch_all_case ~loc ]) in bind_apply ~op_name:Map.name ~loc ~modul ~with_location ~arg:exp ~fn ;; let project_bound_vars ~loc ~modul ~with_location exp ~lhs = let loc = { loc with loc_ghost = true } in let variables = pattern_variables lhs.pat in List.map variables ~f:(fun var -> { txt = (let expr = project_bound_var ~loc ~modul ~with_location exp ~pat:lhs var in value_binding ~loc ~pat:(ppat_var ~loc:var.loc var) ~expr:(Merlin_helpers.hide_expression expr)) ; loc }) ;; let project_pattern_variables ~assume_exhaustive ~modul ~with_location vbs = List.concat_map vbs ~f:(fun vb -> let loc = { vb.pvb_loc with loc_ghost = true } in project_bound_vars ~loc ~modul ~with_location vb.pvb_expr ~lhs:{ pat = vb.pvb_pat; assume_exhaustive }) ;; let name_expr expr = (* to avoid duplicating non-value expressions *) match expr.pexp_desc with | Pexp_ident _ -> [], expr | _ -> let loc = { expr.pexp_loc with loc_ghost = true } in let var = gen_symbol ~prefix:"__pattern_syntax" () in [ value_binding ~loc ~pat:(pvar ~loc var) ~expr ], evar ~loc var ;; let case_number ~loc ~modul exp indexed_cases = with_warning_attribute "-26-27" (* unused variable warnings *) (expand_match (module Map) ~extension_kind:Extension_kind.default ~loc ~modul exp (List.map indexed_cases ~f:(fun (idx, case) -> { case with pc_rhs = eint ~loc idx }))) ;; let expand_case ~destruct expr (idx, match_case) = let loc = { match_case.pc_lhs.ppat_loc with loc_ghost = true } in let rhs = destruct ~lhs:match_case.pc_lhs ~rhs:expr ~body:match_case.pc_rhs |> Option.value ~default: (pexp_let ~loc Nonrecursive [ value_binding ~loc ~pat:match_case.pc_lhs ~expr ] match_case.pc_rhs) in case ~lhs:(pint ~loc idx) ~guard:None ~rhs ;; let case_number_cases ~loc ~destruct exp indexed_cases = List.map indexed_cases ~f:(expand_case ~destruct exp) @ [ catch_all_case ~loc ] ;; let indexed_match ~loc ~modul ~destruct ~switch expr cases = let expr_binding, expr = name_expr expr in let indexed_cases = List.mapi cases ~f:(fun idx case -> idx, case) in let case_number = case_number ~loc ~modul expr indexed_cases in let assume_exhaustive = List.length cases <= 1 in let destruct = destruct ~assume_exhaustive ~loc ~modul in let case_number_cases = case_number_cases ~loc ~destruct expr indexed_cases in pexp_let ~loc Nonrecursive expr_binding (switch ~loc ~modul case_number case_number_cases) ;; module Sub : Ext = struct let name = "sub" let with_location = true let disallow_expression _ = function (* It is worse to use let%sub...and instead of multiple let%sub in a row, so disallow it. *) | Pexp_let (Nonrecursive, _ :: _ :: _, _) -> Error "let%sub should not be used with 'and'." | Pexp_while (_, _) -> Error "while%sub is not supported" | _ -> Ok () ;; let sub_return ~loc ~modul ~lhs ~rhs ~body = let returned_rhs = qualified_return ~loc ~modul rhs in bind_apply ~op_name:name ~loc ~modul ~with_location ~arg:returned_rhs ~fn:(pexp_fun Nolabel None ~loc lhs body) ;; let destruct ~assume_exhaustive ~loc ~modul ~lhs ~rhs ~body = match lhs.ppat_desc with | Ppat_var _ -> None | _ -> let bindings = [ value_binding ~loc ~pat:lhs ~expr:rhs ] in let pattern_projections = project_pattern_variables ~assume_exhaustive ~modul ~with_location:Map.with_location bindings in Some (match pattern_projections with (* We handle the special case of having no pattern projections (which means there were no variables to be projected) by projecting the whole pattern once, just to ensure that the expression being projected matches the pattern. We only do this when the pattern is exhaustive, because otherwise the pattern matching is already happening inside the [switch] call. *) | [] when assume_exhaustive -> let projection_case = case ~lhs ~guard:None ~rhs:(eunit ~loc) in let fn = pexp_function ~loc [ projection_case ] in let rhs = bind_apply ~op_name:Map.name ~loc ~modul ~with_location:Map.with_location ~arg:rhs ~fn in sub_return ~loc ~modul ~lhs:(ppat_any ~loc) ~rhs ~body | _ -> List.fold pattern_projections ~init:body ~f:(fun expr { txt = binding; loc } -> sub_return ~loc ~modul ~lhs:binding.pvb_pat ~rhs:binding.pvb_expr ~body:expr)) ;; let switch ~loc ~modul case_number case_number_cases = Merlin_helpers.hide_expression (pexp_apply ~loc (eoperator ~loc ~modul "switch") [ Labelled "match_", case_number ; Labelled "branches", eint ~loc (List.length case_number_cases - 1) ; Labelled "with_", pexp_function ~loc case_number_cases ]) ;; let expand_match ~loc ~modul expr = function | [] -> assert false | [ (case : case) ] -> let returned_expr = qualified_return ~loc ~modul expr in let fn = maybe_destruct ~destruct ~loc ~modul ~lhs:case.pc_lhs ~body:case.pc_rhs in bind_apply ~op_name:name ~loc ~modul ~with_location ~arg:returned_expr ~fn | cases -> let var_name = gen_symbol ~prefix:"__pattern_syntax" () in let var_expression = evar ~loc var_name in let var_pattern = pvar ~loc var_name in let body = indexed_match ~loc ~modul ~destruct ~switch var_expression cases in sub_return ~loc ~modul ~lhs:var_pattern ~rhs:expr ~body ;; end module Arr : Ext = struct let name = "arr" let with_location = true let disallow_expression _ = function | Pexp_while (_, _) -> Error "while%%arr is not supported." | _ -> Ok () ;; let destruct ~assume_exhaustive:_ ~loc:_ ~modul:_ ~lhs:_ ~rhs:_ ~body:_ = None let expand_match ~loc ~modul expr cases = bind_apply ~loc ~modul ~with_location ~op_name:name ~arg:expr ~fn:(pexp_function ~loc cases) ;; end let expand (module Ext : Ext) extension_kind ~modul expr = let loc = { expr.pexp_loc with loc_ghost = true } in let expansion = let expr_desc = match Ext.disallow_expression extension_kind expr.pexp_desc with | Error message -> Location.raise_errorf ~loc "%s" message | Ok () -> expr.pexp_desc in match expr_desc with | Pexp_let (Nonrecursive, bindings, expr) -> let bindings = List.map bindings ~f:(fun vb -> let pvb_pat = (* Temporary hack tentatively detecting that the parser has expanded `let x : t = e` into `let x : t = (e : t)`. For reference, here is the relevant part of the parser: https://github.com/ocaml/ocaml/blob/4.07/parsing/parser.mly#L1628 *) match vb.pvb_pat.ppat_desc, vb.pvb_expr.pexp_desc with | ( Ppat_constraint (p, { ptyp_desc = Ptyp_poly ([], t1); _ }) , Pexp_constraint (_, t2) ) when phys_equal t1 t2 || Poly.equal t1 t2 -> p | _ -> vb.pvb_pat in { vb with pvb_pat ; pvb_expr = maybe_open ~extension_kind ~to_open:(open_on_rhs ~modul) vb.pvb_expr }) in let f = if extension_kind.collapse_binds then expand_letn (module Ext) ~modul else expand_let (module Ext) ~modul in expand_with_tmp_vars ~loc bindings expr ~f | Pexp_let (Recursive, _, _) -> let ext_full_name = ext_full_name (module Ext) extension_kind in Location.raise_errorf ~loc "'let%%%s' may not be recursive" ext_full_name | Pexp_match (expr, cases) -> expand_match (module Ext) ~extension_kind ~loc ~modul expr cases | Pexp_function cases -> let temp_var = gen_symbol ~prefix:"__let_syntax" () in let temp_pattern = ppat_var ~loc { txt = temp_var; loc } in let temp_expr = pexp_ident ~loc { txt = Lident temp_var; loc } in let match_expr = expand_match (module Ext) ~extension_kind ~loc ~modul temp_expr cases in pexp_fun ~loc Nolabel None temp_pattern match_expr | Pexp_ifthenelse (expr, then_, else_) -> let else_ = match else_ with | Some else_ -> else_ | None -> let ext_full_name = ext_full_name (module Ext) extension_kind in Location.raise_errorf ~loc "'if%%%s' must include an else branch" ext_full_name in expand_if (module Ext) ~extension_kind ~loc ~modul expr then_ else_ | Pexp_while (cond, body) -> expand_while (module Ext) ~extension_kind ~loc ~modul ~cond ~body | _ -> Location.raise_errorf ~loc "'%%%s' can only be used with 'let', 'match', 'while', and 'if'" (ext_full_name (module Ext) extension_kind) in { expansion with pexp_attributes = expr.pexp_attributes @ expansion.pexp_attributes } ;; let sub = (module Sub : Ext) let map = (module Map : Ext) let bind = (module Bind : Ext) let arr = (module Arr : Ext) ppx_let-0.15.0/expander/ppx_let_expander.mli000066400000000000000000000033061420273305200211220ustar00rootroot00000000000000open Ppxlib module Extension_kind : sig type t = { do_open : bool ; collapse_binds : bool } (* let%bind, let%map, etc. *) val default : t (* let%bind_open, let%map_open, etc. *) val default_open : t (* let%bindn, let%mapn, etc. *) val n : t (* let%bindn_open, let%mapn_open, etc. *) val n_open : t end type t val ext_full_name : t -> Extension_kind.t -> label val bind : t val map : t val sub : t val arr : t (* Bind each non-wildcard variable of each pattern to the expression which projects the bound expression to the variable's component. *) val project_pattern_variables : assume_exhaustive:bool -> modul:longident loc option -> with_location:bool -> value_binding list -> value_binding loc list (* Produces a match-like expression which first matches on the index of the inhabited case, and then on the case itself. [switch] is used to create a match-like statement, and [destruct] is used to bind each of the variables in the case patterns so that they are available in the case bodies *) val indexed_match : loc:location -> modul:longident loc option -> destruct: (assume_exhaustive:bool -> loc:location -> modul:longident loc option -> lhs:pattern -> rhs:expression -> body:expression -> expression option) -> switch: (loc:location -> modul:longident loc option -> expression -> case list -> expression) -> expression -> case list -> expression val qualified_return : loc:location -> modul:longident loc option -> expression -> expression val expand : t -> Extension_kind.t -> modul:longident loc option -> expression -> expression ppx_let-0.15.0/ppx_let.opam000066400000000000000000000012651420273305200156030ustar00rootroot00000000000000opam-version: "2.0" version: "v0.15.0" maintainer: "Jane Street developers" authors: ["Jane Street Group, LLC"] homepage: "https://github.com/janestreet/ppx_let" bug-reports: "https://github.com/janestreet/ppx_let/issues" dev-repo: "git+https://github.com/janestreet/ppx_let.git" doc: "https://ocaml.janestreet.com/ocaml-core/latest/doc/ppx_let/index.html" license: "MIT" build: [ ["dune" "build" "-p" name "-j" jobs] ] depends: [ "ocaml" {>= "4.08.0"} "base" {>= "v0.15" & < "v0.16"} "ppx_here" {>= "v0.15" & < "v0.16"} "dune" {>= "2.0.0"} "ppxlib" {>= "0.23.0"} ] synopsis: "Monadic let-bindings" description: " Part of the Jane Street's PPX rewriters collection. " ppx_let-0.15.0/src/000077500000000000000000000000001420273305200140355ustar00rootroot00000000000000ppx_let-0.15.0/src/dune000066400000000000000000000002051420273305200147100ustar00rootroot00000000000000(library (name ppx_let) (public_name ppx_let) (kind ppx_rewriter) (libraries ppxlib ppx_let_expander) (preprocess no_preprocessing))ppx_let-0.15.0/src/ppx_let.ml000066400000000000000000000015711420273305200160460ustar00rootroot00000000000000open Ppxlib let ext t extension_kind = Extension.declare_with_path_arg (Ppx_let_expander.ext_full_name t extension_kind) Extension.Context.expression Ast_pattern.(single_expr_payload __) (fun ~loc:_ ~path:_ ~arg expr -> Ppx_let_expander.expand t extension_kind ~modul:arg expr) ;; open Ppx_let_expander let () = Driver.register_transformation "let" ~extensions: [ ext bind Extension_kind.default ; ext bind Extension_kind.default_open ; ext bind Extension_kind.n ; ext bind Extension_kind.n_open ; ext map Extension_kind.default ; ext map Extension_kind.default_open ; ext map Extension_kind.n ; ext map Extension_kind.n_open ; ext sub Extension_kind.default ; ext sub Extension_kind.default_open ; ext arr Extension_kind.default ; ext arr Extension_kind.default_open ] ;; ppx_let-0.15.0/src/ppx_let.mli000066400000000000000000000000001420273305200162010ustar00rootroot00000000000000ppx_let-0.15.0/test/000077500000000000000000000000001420273305200142255ustar00rootroot00000000000000ppx_let-0.15.0/test/dune000066400000000000000000000000651420273305200151040ustar00rootroot00000000000000(executables (names test) (preprocess (pps ppx_let)))ppx_let-0.15.0/test/inline/000077500000000000000000000000001420273305200155035ustar00rootroot00000000000000ppx_let-0.15.0/test/inline/dune000066400000000000000000000002531420273305200163610ustar00rootroot00000000000000(library (name ppx_let_test) (libraries core ppx_let_expander) (preprocess (pps ppx_expect ppx_inline_test ppx_let ppx_sexp_message ppx_sexp_value ppxlib.metaquot)))ppx_let-0.15.0/test/inline/test_op_n.ml000066400000000000000000000074361420273305200200410ustar00rootroot00000000000000open Core open Ppxlib let loc = Location.none let print_expr expr = Pprintast.string_of_structure [%str let () = [%e expr]] |> print_string ;; let%expect_test "single pattern map" = Ppx_let_expander.expand Ppx_let_expander.map Ppx_let_expander.Extension_kind.n ~modul:None [%expr let MY_PAT = MY_EXPR in MY_BODY] |> print_expr; [%expect {| let () = Let_syntax.map MY_EXPR ~f:(fun (MY_PAT) -> MY_BODY) |}] ;; let%expect_test "single pattern map with modul" = Ppx_let_expander.expand Ppx_let_expander.map Ppx_let_expander.Extension_kind.n ~modul:(Some { txt = Longident.Lident "X"; loc = Location.none }) [%expr let MY_PAT = MY_EXPR in MY_BODY] |> print_expr; [%expect {| let () = X.Let_syntax.Let_syntax.map MY_EXPR ~f:(fun (MY_PAT) -> MY_BODY) |}] ;; let%expect_test "double pattern map" = Ppx_let_expander.expand Ppx_let_expander.map Ppx_let_expander.Extension_kind.n ~modul:None [%expr let MY_PAT_1 = MY_EXPR_1 and MY_PAT_2 = MY_EXPR_2 in MY_BODY] |> print_expr; [%expect {| let () = let __let_syntax__003_ = MY_EXPR_1 and __let_syntax__004_ = MY_EXPR_2 in Let_syntax.map2 __let_syntax__003_ __let_syntax__004_ ~f:(fun (MY_PAT_1) -> fun (MY_PAT_2) -> MY_BODY) |}] ;; let%expect_test "single pattern map open" = Ppx_let_expander.expand Ppx_let_expander.map Ppx_let_expander.Extension_kind.n_open ~modul:None [%expr let MY_PAT_1 = MY_EXPR_1 in MY_BODY] |> print_expr; [%expect {| let () = Let_syntax.map (let open! Let_syntax.Open_on_rhs in MY_EXPR_1) ~f:(fun (MY_PAT_1) -> MY_BODY) |}] ;; let%expect_test "double pattern map open" = Ppx_let_expander.expand Ppx_let_expander.map Ppx_let_expander.Extension_kind.n_open ~modul:None [%expr let MY_PAT_1 = MY_EXPR_1 and MY_PAT_2 = MY_EXPR_2 in MY_BODY] |> print_expr; [%expect {| let () = let __let_syntax__008_ = let open! Let_syntax.Open_on_rhs in MY_EXPR_1 and __let_syntax__009_ = let open! Let_syntax.Open_on_rhs in MY_EXPR_2 in Let_syntax.map2 __let_syntax__008_ __let_syntax__009_ ~f:(fun (MY_PAT_1) -> fun (MY_PAT_2) -> MY_BODY) |}] ;; let%expect_test "quadruple pattern map" = Ppx_let_expander.expand Ppx_let_expander.map Ppx_let_expander.Extension_kind.n ~modul:None [%expr let MY_PAT_1 = MY_EXPR_1 and MY_PAT_2 = MY_EXPR_2 and SUB_PATTERN_1, SUB_PATTERN_2 = MY_EXPR_3 and MY_PAT_4 = MY_EXPR_4 in MY_BODY] |> print_expr; [%expect {| let () = let __let_syntax__012_ = MY_EXPR_1 and __let_syntax__013_ = MY_EXPR_2 and __let_syntax__014_ = MY_EXPR_3 and __let_syntax__015_ = MY_EXPR_4 in Let_syntax.map4 __let_syntax__012_ __let_syntax__013_ __let_syntax__014_ __let_syntax__015_ ~f:(fun (MY_PAT_1) -> fun (MY_PAT_2) -> fun (SUB_PATTERN_1, SUB_PATTERN_2) -> fun (MY_PAT_4) -> MY_BODY) |}] ;; let%expect_test "quadruple pattern bind" = Ppx_let_expander.expand Ppx_let_expander.bind Ppx_let_expander.Extension_kind.n ~modul:None [%expr let MY_PAT_1 = MY_EXPR_1 and MY_PAT_2 = MY_EXPR_2 and SUB_PATTERN_1, SUB_PATTERN_2 = MY_EXPR_3 and MY_PAT_4 = MY_EXPR_4 in MY_BODY] |> print_expr; [%expect {| let () = let __let_syntax__020_ = MY_EXPR_1 and __let_syntax__021_ = MY_EXPR_2 and __let_syntax__022_ = MY_EXPR_3 and __let_syntax__023_ = MY_EXPR_4 in Let_syntax.bind4 __let_syntax__020_ __let_syntax__021_ __let_syntax__022_ __let_syntax__023_ ~f:(fun (MY_PAT_1) -> fun (MY_PAT_2) -> fun (SUB_PATTERN_1, SUB_PATTERN_2) -> fun (MY_PAT_4) -> MY_BODY) |}] ;; ppx_let-0.15.0/test/inline/test_op_n.mli000066400000000000000000000000551420273305200202000ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_let-0.15.0/test/inline/test_subst.ml000066400000000000000000000433711420273305200202440ustar00rootroot00000000000000open Core open Ppxlib let loc = Location.none let print_expr expr = Pprintast.string_of_structure [%str let () = [%e expr]] |> print_string ;; let%expect_test "single let%sub " = Ppx_let_expander.expand Ppx_let_expander.sub Ppx_let_expander.Extension_kind.default ~modul:None [%expr let a = MY_EXPR in MY_BODY] |> print_expr; [%expect {| let () = Let_syntax.sub ~here:{ Ppx_here_lib.pos_fname = "_none_"; pos_lnum = 1; pos_cnum = (-1); pos_bol = 0 } MY_EXPR ~f:(fun a -> MY_BODY) |}] ;; let%expect_test "single pattern sub with modul" = Ppx_let_expander.expand Ppx_let_expander.sub Ppx_let_expander.Extension_kind.default ~modul:(Some { txt = Longident.Lident "X"; loc = Location.none }) [%expr let a = MY_EXPR in MY_BODY] |> print_expr; [%expect {| let () = X.Let_syntax.Let_syntax.sub ~here:{ Ppx_here_lib.pos_fname = "_none_"; pos_lnum = 1; pos_cnum = (-1); pos_bol = 0 } MY_EXPR ~f:(fun a -> MY_BODY) |}] ;; let assert_fails_with_syntax_error ~f = try ignore (f ()); assert false with | ex -> Location.Error.of_exn ex |> (fun a -> Option.value_exn a) |> Location.Error.message |> print_endline ;; let%expect_test "double pattern let%sub" = assert_fails_with_syntax_error ~f:(fun () -> Ppx_let_expander.expand Ppx_let_expander.sub Ppx_let_expander.Extension_kind.default ~modul:None [%expr let a = MY_EXPR_1 and b = MY_EXPR_2 in MY_BODY]); [%expect {| let%sub should not be used with 'and'. |}] ;; let%expect_test "single pattern sub open" = Ppx_let_expander.expand Ppx_let_expander.sub Ppx_let_expander.Extension_kind.default ~modul:None [%expr let a = MY_EXPR_1 in MY_BODY] |> print_expr; [%expect {| let () = Let_syntax.sub ~here:{ Ppx_here_lib.pos_fname = "_none_"; pos_lnum = 1; pos_cnum = (-1); pos_bol = 0 } MY_EXPR_1 ~f:(fun a -> MY_BODY) |}] ;; let%expect_test "double pattern map open" = assert_fails_with_syntax_error ~f:(fun () -> Ppx_let_expander.expand Ppx_let_expander.sub Ppx_let_expander.Extension_kind.default_open ~modul:None [%expr let a = MY_EXPR_1 and b = MY_EXPR_2 in MY_BODY]); [%expect {| let%sub should not be used with 'and'. |}] ;; let%expect_test "while%sub is banned" = assert_fails_with_syntax_error ~f:(fun () -> Ppx_let_expander.expand Ppx_let_expander.sub Ppx_let_expander.Extension_kind.default_open ~modul:None [%expr while a = MY_EXPR_1 do MY_BODY done]); [%expect {| while%sub is not supported |}] ;; let%expect_test "if%sub is supported" = Ppx_let_expander.expand Ppx_let_expander.sub Ppx_let_expander.Extension_kind.default ~modul:None [%expr if MY_EXPR_1 then BODY_1 else BODY_2] |> print_expr; [%expect {| let () = Let_syntax.sub ~here:{ Ppx_here_lib.pos_fname = "_none_"; pos_lnum = 1; pos_cnum = (-1); pos_bol = 0 } (Let_syntax.return MY_EXPR_1) ~f:(fun __pattern_syntax__004_ -> ((Let_syntax.switch ~match_:((Let_syntax.map __pattern_syntax__004_ ~f:(function | true -> 0 | false -> 1)) [@ocaml.warning "-26-27"]) ~branches:2 ~with_:(function | 0 -> BODY_1 | 1 -> BODY_2 | _ -> assert false)) [@merlin.hide ])) |}] ;; let%expect_test "very simple match%sub" = Ppx_let_expander.expand Ppx_let_expander.sub Ppx_let_expander.Extension_kind.default ~modul:None [%expr match MY_EXPR_1 with | a -> BODY_1] |> print_expr; [%expect {| let () = Let_syntax.sub ~here:{ Ppx_here_lib.pos_fname = "_none_"; pos_lnum = 1; pos_cnum = (-1); pos_bol = 0 } (Let_syntax.return MY_EXPR_1) ~f:(fun a -> BODY_1) |}] ;; let%expect_test "destructuring let%sub" = Ppx_let_expander.expand Ppx_let_expander.sub Ppx_let_expander.Extension_kind.default ~modul:None [%expr let a, { b; c } = MY_EXPR in MY_BODY] |> print_expr; [%expect {| let () = Let_syntax.sub ~here:{ Ppx_here_lib.pos_fname = "_none_"; pos_lnum = 1; pos_cnum = (-1); pos_bol = 0 } MY_EXPR ~f:(fun __pattern_syntax__006_ -> Let_syntax.sub ~here:{ Ppx_here_lib.pos_fname = "_none_"; pos_lnum = 1; pos_cnum = (-1); pos_bol = 0 } (Let_syntax.return ((Let_syntax.map __pattern_syntax__006_ ~f:(function | (_, { b = _; c = __pattern_syntax__009_ }) -> __pattern_syntax__009_))[@merlin.hide ])) ~f:(fun c -> Let_syntax.sub ~here:{ Ppx_here_lib.pos_fname = "_none_"; pos_lnum = 1; pos_cnum = (-1); pos_bol = 0 } (Let_syntax.return ((Let_syntax.map __pattern_syntax__006_ ~f:(function | (_, { b = __pattern_syntax__008_; c = _ }) -> __pattern_syntax__008_)) [@merlin.hide ])) ~f:(fun b -> Let_syntax.sub ~here:{ Ppx_here_lib.pos_fname = "_none_"; pos_lnum = 1; pos_cnum = (-1); pos_bol = 0 } (Let_syntax.return ((Let_syntax.map __pattern_syntax__006_ ~f:(function | (__pattern_syntax__007_, { b = _; c = _ }) -> __pattern_syntax__007_)) [@merlin.hide ])) ~f:(fun a -> MY_BODY)))) |}] ;; let%expect_test "destructuring match%sub" = Ppx_let_expander.expand Ppx_let_expander.sub Ppx_let_expander.Extension_kind.default ~modul:None [%expr match MY_EXPR with | Choice_1 (a, b) -> CHOICE_1_BODY | Choice_2 _ -> CHOICE_2_BODY | Choice_3 -> CHOICE_3_BODY] |> print_expr; [%expect {| let () = Let_syntax.sub ~here:{ Ppx_here_lib.pos_fname = "_none_"; pos_lnum = 1; pos_cnum = (-1); pos_bol = 0 } (Let_syntax.return MY_EXPR) ~f:(fun __pattern_syntax__010_ -> ((Let_syntax.switch ~match_:((Let_syntax.map __pattern_syntax__010_ ~f:(function | Choice_1 (a, b) -> 0 | Choice_2 _ -> 1 | Choice_3 -> 2))[@ocaml.warning "-26-27"]) ~branches:3 ~with_:(function | 0 -> Let_syntax.sub ~here:{ Ppx_here_lib.pos_fname = "_none_"; pos_lnum = 1; pos_cnum = (-1); pos_bol = 0 } (Let_syntax.return ((Let_syntax.map __pattern_syntax__010_ ~f:((function | Choice_1 (_, __pattern_syntax__012_) -> __pattern_syntax__012_ | _ -> assert false) [@ocaml.warning "-11"]))[@merlin.hide ])) ~f:(fun b -> Let_syntax.sub ~here:{ Ppx_here_lib.pos_fname = "_none_"; pos_lnum = 1; pos_cnum = (-1); pos_bol = 0 } (Let_syntax.return ((Let_syntax.map __pattern_syntax__010_ ~f:((function | Choice_1 (__pattern_syntax__011_, _) -> __pattern_syntax__011_ | _ -> assert false) [@ocaml.warning "-11"])) [@merlin.hide ])) ~f:(fun a -> CHOICE_1_BODY)) | 1 -> CHOICE_2_BODY | 2 -> CHOICE_3_BODY | _ -> assert false)) [@merlin.hide ])) |}] ;; let%expect_test "single-case match%sub doesn't call switch" = let modul = Some { txt = lident "Module"; loc } in Ppx_let_expander.expand Ppx_let_expander.sub Ppx_let_expander.Extension_kind.default ~modul [%expr match MY_EXPR with | Choice_1 x -> CHOICE_1_BODY] |> print_expr; [%expect {| let () = Module.Let_syntax.Let_syntax.sub ~here:{ Ppx_here_lib.pos_fname = "_none_"; pos_lnum = 1; pos_cnum = (-1); pos_bol = 0 } (Module.Let_syntax.Let_syntax.return MY_EXPR) ~f:(fun __pattern_syntax__013_ -> Module.Let_syntax.Let_syntax.sub ~here:{ Ppx_here_lib.pos_fname = "_none_"; pos_lnum = 1; pos_cnum = (-1); pos_bol = 0 } (Module.Let_syntax.Let_syntax.return ((Module.Let_syntax.Let_syntax.map __pattern_syntax__013_ ~f:(function | Choice_1 __pattern_syntax__014_ -> __pattern_syntax__014_))[@merlin.hide ])) ~f:(fun x -> CHOICE_1_BODY)) |}] ;; let%expect_test "module-qualified match%sub" = let modul = Some { txt = lident "Module"; loc } in Ppx_let_expander.expand Ppx_let_expander.sub Ppx_let_expander.Extension_kind.default ~modul [%expr match MY_EXPR with | Choice_1 x -> CHOICE_1_BODY | Choice_2 x -> CHOICE_2_BODY] |> print_expr; [%expect {| let () = Module.Let_syntax.Let_syntax.sub ~here:{ Ppx_here_lib.pos_fname = "_none_"; pos_lnum = 1; pos_cnum = (-1); pos_bol = 0 } (Module.Let_syntax.Let_syntax.return MY_EXPR) ~f:(fun __pattern_syntax__015_ -> ((Module.Let_syntax.Let_syntax.switch ~match_:((Module.Let_syntax.Let_syntax.map __pattern_syntax__015_ ~f:(function | Choice_1 x -> 0 | Choice_2 x -> 1)) [@ocaml.warning "-26-27"]) ~branches:2 ~with_:(function | 0 -> Module.Let_syntax.Let_syntax.sub ~here:{ Ppx_here_lib.pos_fname = "_none_"; pos_lnum = 1; pos_cnum = (-1); pos_bol = 0 } (Module.Let_syntax.Let_syntax.return ((Module.Let_syntax.Let_syntax.map __pattern_syntax__015_ ~f:((function | Choice_1 __pattern_syntax__016_ -> __pattern_syntax__016_ | _ -> assert false) [@ocaml.warning "-11"]))[@merlin.hide ])) ~f:(fun x -> CHOICE_1_BODY) | 1 -> Module.Let_syntax.Let_syntax.sub ~here:{ Ppx_here_lib.pos_fname = "_none_"; pos_lnum = 1; pos_cnum = (-1); pos_bol = 0 } (Module.Let_syntax.Let_syntax.return ((Module.Let_syntax.Let_syntax.map __pattern_syntax__015_ ~f:((function | Choice_2 __pattern_syntax__017_ -> __pattern_syntax__017_ | _ -> assert false) [@ocaml.warning "-11"]))[@merlin.hide ])) ~f:(fun x -> CHOICE_2_BODY) | _ -> assert false)) [@merlin.hide ])) |}] ;; let%expect_test "type annotations are preserved" = Ppx_let_expander.expand Ppx_let_expander.sub Ppx_let_expander.Extension_kind.default ~modul:None [%expr let (_ : int) = EXPR in BODY] |> print_expr; [%expect {| let () = Let_syntax.sub ~here:{ Ppx_here_lib.pos_fname = "_none_"; pos_lnum = 1; pos_cnum = (-1); pos_bol = 0 } EXPR ~f:(fun __pattern_syntax__018_ -> Let_syntax.sub ~here:{ Ppx_here_lib.pos_fname = "_none_"; pos_lnum = 1; pos_cnum = (-1); pos_bol = 0 } (Let_syntax.return (Let_syntax.map __pattern_syntax__018_ ~f:(function | (_ : int) -> ()))) ~f:(fun _ -> BODY)) |}] ;; let%expect_test "function%sub" = Ppx_let_expander.expand Ppx_let_expander.sub Ppx_let_expander.Extension_kind.default ~modul:None [%expr function | Some a -> EXPR_SOME | None -> EXPR_NONE] |> print_expr; [%expect {| let () = fun __let_syntax__019_ -> Let_syntax.sub ~here:{ Ppx_here_lib.pos_fname = "_none_"; pos_lnum = 1; pos_cnum = (-1); pos_bol = 0 } (Let_syntax.return __let_syntax__019_) ~f:(fun __pattern_syntax__020_ -> ((Let_syntax.switch ~match_:((Let_syntax.map __pattern_syntax__020_ ~f:(function | Some a -> 0 | None -> 1)) [@ocaml.warning "-26-27"]) ~branches:2 ~with_:(function | 0 -> Let_syntax.sub ~here:{ Ppx_here_lib.pos_fname = "_none_"; pos_lnum = 1; pos_cnum = (-1); pos_bol = 0 } (Let_syntax.return ((Let_syntax.map __pattern_syntax__020_ ~f:((function | Some __pattern_syntax__021_ -> __pattern_syntax__021_ | _ -> assert false) [@ocaml.warning "-11"]))[@merlin.hide ])) ~f:(fun a -> EXPR_SOME) | 1 -> EXPR_NONE | _ -> assert false)) [@merlin.hide ])) |}] ;; let%expect_test "function%arr" = Ppx_let_expander.expand Ppx_let_expander.arr Ppx_let_expander.Extension_kind.default ~modul:None [%expr function | Some a -> EXPR_SOME | None -> EXPR_NONE] |> print_expr; [%expect {| let () = fun __let_syntax__022_ -> Let_syntax.arr ~here:{ Ppx_here_lib.pos_fname = "_none_"; pos_lnum = 1; pos_cnum = (-1); pos_bol = 0 } __let_syntax__022_ ~f:(function | Some a -> EXPR_SOME | None -> EXPR_NONE) |}] ;; ppx_let-0.15.0/test/inline/test_subst.mli000066400000000000000000000000551420273305200204050ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_let-0.15.0/test/inline/test_while.ml000066400000000000000000000026061420273305200202100ustar00rootroot00000000000000open Core open Ppxlib let loc = Location.none let print_expr expr = Pprintast.string_of_structure [%str let () = [%e expr]] |> print_string ;; let%expect_test "while%bind expansion" = Ppx_let_expander.expand Ppx_let_expander.bind Ppx_let_expander.Extension_kind.default ~modul:None [%expr while MY_CONDITION do MY_BODY done] |> print_expr; [%expect {| let () = let rec __let_syntax_loop__001_ () = Let_syntax.bind MY_CONDITION ~f:(function | true -> Let_syntax.bind MY_BODY ~f:__let_syntax_loop__001_ | false -> Let_syntax.return ()) in __let_syntax_loop__001_ () |}] ;; let%expect_test "while%bind trivial test" = let i = ref 0 in while%bind.Monad.Ident incr i; !i <= 5 do printf "%d\n" !i done; [%expect {| 1 2 3 4 5 |}] ;; let%expect_test "monadic use" = let open Or_error.Let_syntax in let next i = if i < 5 then Ok (i + 1) else error_s [%message "too big"] in let t n = let i = ref 0 in let result = while%bind let%map i' = next !i in i := i'; !i <= n do printf "%d\n" !i; Ok () done in print_s [%sexp (result : unit Or_error.t)] in t 3; [%expect {| 1 2 3 (Ok ()) |}]; t 10; [%expect {| 1 2 3 4 5 (Error "too big") |}] ;; ppx_let-0.15.0/test/inline/test_while.mli000066400000000000000000000000551420273305200203550ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_let-0.15.0/test/test-dup-pattern.mlt000066400000000000000000000007451420273305200201710ustar00rootroot00000000000000(* -*- 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 end let (_ : _) = (* This tests whether we correctly detect that `let x : t = e` has been rewritten into `let x : t = (e : t)` (and undo the change). A typing error occurs *) let%map_open _x : int Let_syntax.t = return 42 in () ;; ppx_let-0.15.0/test/test-locations.mlt000066400000000000000000000007651420273305200177230ustar00rootroot00000000000000(* -*- 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 end let (_ : _) = [%map_open let x = return 42 and y = f 42 in ()] ;; [%%expect {| Line _, characters _-_: Error: This expression has type doc:string -> (int * string) Let_syntax.t but an expression was expected of type 'a Let_syntax.t |}] ppx_let-0.15.0/test/test.ml000066400000000000000000000144121420273305200155400ustar00rootroot00000000000000module Monad_example = struct module X : sig type 'a t module Let_syntax : sig val return : 'a -> 'a t module Let_syntax : sig val return : 'a -> 'a t val bind : 'a t -> f:('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 let return x = x let bind x ~f = f x let map x ~f = f x let both x y = x, y module Let_syntax = struct let return = return 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 open X.Let_syntax let _mf a : _ X.t = let%bind_open x = a in return (x + 1) ;; let _mf' a b c : _ X.t = let%bind_open x = a and y = b and u, v = c in return (x + y + (u * v)) ;; let _mg a : _ X.t = let%map x : int X.t = a in x + 1 ;; let _mg' a b c : _ X.t = let%map x = a and y = b and u, v = c in x + y + (u * v) ;; let _mh a : _ X.t = match%bind_open a with | 0 -> return true | _ -> return false ;; let _mi a : _ X.t = match%map a with | 0 -> true | _ -> false ;; let _mif a : _ X.t = if%bind_open a then return true else return false let _mif' a : _ X.t = if%map a then true else false let _mj : int X.t -> bool X.t = function%bind | 0 -> return true | _ -> return false ;; let _mk : int X.t -> bool X.t = function%map | 0 -> true | _ -> false ;; end module Applicative_example = struct module X : sig type 'a t module Let_syntax : sig val return : 'a -> '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 end end end end = struct type 'a t = 'a let return x = x let map x ~f = f x let both x y = x, y module Let_syntax = struct let return = return 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 end end open X.Let_syntax (* {[ let _af a : _ X.t = let%bind x = a in (* "Error: Unbound value Let_syntax.bind" *) return (x + 1) ]} *) (* {[ let _af' a b c : _ X.t = let%bind x = a and y = b and (u, v) = c in (* "Error: Unbound value Let_syntax.bind" *) return (x + y + (u * v)) ]} *) let _ag a : _ X.t = let%map x = a in x + 1 ;; let _ag' a b c : _ X.t = let%map x = a and y = b and u, v = c in x + y + (u * v) ;; (* {[ let _ah a : _ X.t = match%bind a with (* "Error: Unbound value Let_syntax.bind" *) | 0 -> return true | _ -> return false ]} *) let _ai a : _ X.t = match%map a with | 0 -> true | _ -> false ;; end module Example_without_open = struct let _ag a : _ Applicative_example.X.t = let%map.Applicative_example.X x = a in x + 1 ;; end module Example_with_mapn = struct module Let_syntax = struct let return = Monad_example.X.Let_syntax.return module Let_syntax = struct include Monad_example.X.Let_syntax.Let_syntax let map2 a b ~f = map (both a b) ~f:(fun (a, b) -> f a b) let map3 a b c ~f = map2 (both a b) c ~f:(fun (a, b) c -> f a b c) let map4 a b c d ~f = map2 (both a b) (both c d) ~f:(fun (a, b) (c, d) -> f a b c d) end end let _x = let open Let_syntax in let%mapn a = return 1 and b = return "hi" and c = return 2.34 and d = return true in Printf.sprintf "%d %s %f %b" a b c d ;; end module Arrow_example = struct module X : sig type 'a c type 'a v val return_v : 'a -> 'a v module Let_syntax : sig val return : 'a v -> 'a c module Let_syntax : sig val return : 'a v -> 'a c val sub : ?here:Lexing.position -> 'a c -> f:('a v -> 'b c) -> 'b c val map : 'a v -> f:('a -> 'b) -> 'b v val both : 'a v -> 'b v -> ('a * 'b) v val switch : match_:int v -> branches:int -> with_:(int -> 'b c) -> 'b c val arr : ?here:Lexing.position -> 'a v -> f:('a -> 'b) -> 'b c end end end = struct type 'a v = 'a type 'a c = 'a let return_v x = x let return x = x let sub ?here:_ x ~f = f x let map x ~f = f x let both a b = a, b let switch ~match_ ~branches:_ ~with_ = with_ match_ let arr ?here:_ x ~f = return (f x) module Let_syntax = struct let return = return module Let_syntax = struct let return = return let sub = sub let map = map let both = both let switch = switch let arr = arr end end end open X.Let_syntax let _arrow_example_1 a : _ X.c = match%sub a with | 0 -> return (X.return_v true) | _ -> return (X.return_v false) ;; let _arrow_example_2 a : _ X.c = match%sub a with | 0 -> return (X.return_v true) | b -> return (let%map b = b in b = 1) ;; let _arrow_example_3 a : _ X.c = match%sub a with | 0 -> return (X.return_v true) | _ as b -> return (let%map b = b in b = 1) ;; type abc = A of int let _arrow_example_4 a : _ X.c = match%sub a with | A b -> return (let%map b = b in b = 1) ;; let _arrow_example_5 (a : _ X.v) : _ X.c = let%arr a = a in a ;; let _arrow_example_6 : 'a X.v -> 'a X.c = function%arr | a -> a ;; let _arrow_example_7 : 'a X.v -> 'a X.c = function%sub | a -> return a ;; let _arrow_example_8 : default:'a -> 'a option X.v -> 'a X.c = fun ~default -> function%arr | Some a -> a | None -> default ;; let _arrow_example_9 : default:'a X.v -> 'a option X.v -> 'a X.c = fun ~default -> function%sub | Some a -> return a | None -> return default ;; end