pax_global_header00006660000000000000000000000064146164733610014525gustar00rootroot0000000000000052 comment=39636b261bc99d355b82077c806f516e1b9701fc ppx_let-0.17.0/000077500000000000000000000000001461647336100132655ustar00rootroot00000000000000ppx_let-0.17.0/.gitignore000066400000000000000000000000411461647336100152500ustar00rootroot00000000000000_build *.install *.merlin _opam ppx_let-0.17.0/.ocamlformat000066400000000000000000000000231461647336100155650ustar00rootroot00000000000000profile=janestreet ppx_let-0.17.0/CHANGES.md000066400000000000000000000017541461647336100146660ustar00rootroot00000000000000## Release v0.17.0 * Introduce a mechanism by which to prevent the PPX from inserting a function call in tail position. This is necessary as a result of the current implementation of local allocations. ## Release v0.16.0 * Exposed more internals to allow other ppxes to build similar extensions of `let`. ## Old pre-v0.15 changelogs (very likely stale and incomplete) ## 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.17.0/CONTRIBUTING.md000066400000000000000000000044101461647336100155150ustar00rootroot00000000000000This 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.17.0/LICENSE.md000066400000000000000000000021461461647336100146740ustar00rootroot00000000000000The MIT License Copyright (c) 2015--2024 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.17.0/Makefile000066400000000000000000000004031461647336100147220ustar00rootroot00000000000000INSTALL_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.17.0/README.md000066400000000000000000000160661461647336100145550ustar00rootroot00000000000000ppx_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 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) 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) 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`. Local values ------------ `ppx_let` can operate on local values. This requires a compiler that supports the `local_` keyword and stack allocation, which as of 2023-03 is a nonstandard compiler extension. 1. Use `%mapl` and `%bindl` instead of `%map` and `%bind`. 2. Implement a `Let_syntax` module that matches the following signature: ```ocaml module Let_syntax : sig module Let_syntax : sig val return : local_ 'a -> local_ 'a t val map : local_ 'a t -> f:local_ (local_ 'a -> local_ 'b) -> local_ 'b t val both : local_ 'a t -> local_ 'b t -> local_ ('a * 'b) t module Open_on_rhs : << some signature >> end end ``` ppx_let-0.17.0/dune000066400000000000000000000000001461647336100141310ustar00rootroot00000000000000ppx_let-0.17.0/dune-project000066400000000000000000000000211461647336100156000ustar00rootroot00000000000000(lang dune 3.11) ppx_let-0.17.0/expander/000077500000000000000000000000001461647336100150735ustar00rootroot00000000000000ppx_let-0.17.0/expander/dune000066400000000000000000000002241461647336100157470ustar00rootroot00000000000000(library (name ppx_let_expander) (public_name ppx_let.expander) (libraries base ppxlib ppx_here.expander) (preprocess (pps ppxlib.metaquot))) ppx_let-0.17.0/expander/ppx_let_expander.ml000066400000000000000000000375471461647336100210060ustar00rootroot00000000000000open 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 val prevent_tail_call : 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 -> locality:[ `local | `global ] -> expression -> case list -> expression (* [expand] is the function that normally expands let%[name]. [wrap_expansion] can be used to change the parameters given to [expand] and can also tranform the output of [expand]. *) val wrap_expansion : loc:location -> modul:longident loc option -> value_binding list -> expression -> expand:(loc:location -> value_binding list -> expression -> expression) -> expression end let wrap_expansion_identity ~loc ~modul:_ bindings expression ~expand = expand ~loc bindings expression ;; (* When generating [local_] binds, we need to avoid tail calls so that local allocations can be released. Determining precisely when to annotate [@nontail] is finicky. Instead, we wrap the whole expression in a [let] to force calls to be non-tail. *) let prevent_tail_calls ~loc expr = let var = gen_symbol ~prefix:"__nontail" () in pexp_let ~loc Nonrecursive [ value_binding ~loc ~pat:(pvar ~loc var) ~expr ] (evar ~loc var) ;; (* Wrap an expression in [local_] *) let wrap_local ~loc expr = [%expr [%e prevent_tail_calls ~loc expr]] let maybe_wrap_local ~loc ~locality expr = match locality with | `global -> expr | `local -> wrap_local ~loc expr ;; type t = (module Ext) let ext_full_name (module Ext : Ext) ~locality (kind : Extension_kind.t) = let result = Ext.name in let result = match locality with | `local -> String.concat [ result; "l" ] | `global -> result in let result = if kind.collapse_binds then String.concat [ result; "n" ] else result in if kind.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 nontail ~loc expr = let attr = attribute ~loc ~name:{ txt = "nontail"; loc } ~payload:(PStr []) in { expr with pexp_attributes = attr :: expr.pexp_attributes } ;; let bind_apply ?(fn_label = "f") ~prevent_tail_call ~op_name ~loc ~modul ~with_location ~arg ~fn () = let args = if with_location then [ location_arg ~loc; Nolabel, arg; Labelled fn_label, fn ] else [ Nolabel, arg; Labelled fn_label, fn ] in let expr = pexp_apply ~loc (eoperator ~loc ~modul op_name) args in if prevent_tail_call then nontail ~loc expr else expr ;; let do_not_enter_value vb = let loc = vb.pvb_loc in let attr = { attr_loc = loc ; attr_name = { loc; txt = Attribute.name Ast_traverse.do_not_enter_value_binding } ; attr_payload = PStr [] } in { vb with pvb_attributes = attr :: vb.pvb_attributes } ;; 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 lhs = do_not_enter_value { 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 maybe_destruct ~destruct ~loc ~modul ~locality ~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 -> maybe_wrap_local ~loc ~locality destruction |> pexp_fun ~loc Nolabel None whole_value_pattern | None -> maybe_wrap_local ~loc ~locality body |> pexp_fun ~loc Nolabel None lhs ;; let expand_letn (module Ext : Ext) ~loc ~modul ~locality 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:(maybe_wrap_local ~loc ~locality body) ~f:(fun { pvb_pat; _ } lower -> maybe_destruct ~destruct:Ext.destruct ~modul ~locality:`global ~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 : Extension_kind.t) ~to_open:module_to_open expr = let loc = { expr.pexp_loc with loc_ghost = true } in if 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 ~locality 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 let min_position, max_position = match rev_patts with | hd :: tl -> let init = hd.ppat_loc.loc_start, hd.ppat_loc.loc_end in List.fold ~init tl ~f:(fun (min, max) pattern -> ( Location.min_pos pattern.ppat_loc.loc_start min , Location.max_pos pattern.ppat_loc.loc_end max )) | [] -> assert false in let tuple_loc = { loc_start = min_position; loc_end = max_position; loc_ghost = true } in List.reduce_exn rev_patts ~f:(fun acc p -> ppat_tuple ~loc:tuple_loc [ p; acc ]) in let fn = maybe_destruct ~destruct:Ext.destruct ~loc ~modul ~locality ~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 ~locality expr cases = let expr = maybe_open ~extension_kind ~to_open:(open_on_rhs ~modul) expr in Ext.expand_match ~loc ~modul ~locality expr cases ;; let expand_if t ~extension_kind ~loc ~modul ~locality expr then_ else_ = expand_match t ~extension_kind ~loc ~modul ~locality 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) ~locality ~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 ~prevent_tail_call:Ext.prevent_tail_call () in let else_ = qualified_return ~loc ~modul (eunit ~loc) in expand_if (module Ext) ~extension_kind ~modul ~locality ~loc cond then_ else_ in let loop_body = maybe_wrap_local ~loc ~locality loop_body in let loop_func = pexp_fun ~loc Nolabel None (punit ~loc) loop_body in pexp_let ~loc Recursive [ do_not_enter_value (value_binding ~loc ~pat:ploop ~expr:loop_func) ] loop_call ;; let expand_function ~loc ~locality cases = match locality with | `global -> pexp_function ~loc cases | `local -> let var = gen_symbol ~prefix:"__let_syntax" () in pexp_match ~loc (evar ~loc var) cases |> wrap_local ~loc |> pexp_fun ~loc Nolabel None (pvar ~loc var) ;; module Map : Ext = struct let name = "map" let with_location = false let wrap_expansion = wrap_expansion_identity let prevent_tail_call = 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 ~locality expr cases = bind_apply ~loc ~modul ~with_location ~op_name:name ~arg:expr ~fn:(expand_function ~loc ~locality cases) ~prevent_tail_call () ;; end module Bind : Ext = struct let name = "bind" let with_location = false let wrap_expansion = wrap_expansion_identity let prevent_tail_call = false let disallow_expression (extension_kind : Extension_kind.t) = function | Pexp_while (_, _) when extension_kind.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 ~locality expr cases = bind_apply ~loc ~modul ~with_location ~op_name:name ~arg:expr ~fn:(expand_function ~loc ~locality cases) ~prevent_tail_call () ;; 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 []) ;; let maybe_enter_value pat expr = match pattern_variables pat with | [ { loc; txt } ] -> let loc = { loc with loc_ghost = true } in let attr = { attr_loc = loc ; attr_name = { loc; txt = Attribute.name Ast_traverse.enter_value } ; attr_payload = PStr [ pstr_eval ~loc (evar ~loc txt) [] ] } in { expr with pexp_attributes = attr :: expr.pexp_attributes } | [] | _ :: _ :: _ -> expr ;; let expand ((module Ext : Ext) as ext) extension_kind ~modul ~locality 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, pvb_expr = (* 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_expr with pexp_loc = { vb.pvb_expr.pexp_loc with loc_ghost = true } } ) | _ -> vb.pvb_pat, vb.pvb_expr in { vb with pvb_pat ; pvb_expr = maybe_open ~extension_kind ~to_open:(open_on_rhs ~modul) (maybe_enter_value pvb_pat pvb_expr) }) in let f ~loc value_bindings expression = let expand = if extension_kind.collapse_binds then expand_letn ext ~modul ~locality else expand_let ext ~modul ~locality ~prevent_tail_call:Ext.prevent_tail_call in Ext.wrap_expansion ~loc ~modul value_bindings expression ~expand in expand_with_tmp_vars ~loc bindings expr ~f | Pexp_let (Recursive, _, _) -> let ext_full_name = ext_full_name ext ~locality extension_kind in Location.raise_errorf ~loc "'let%%%s' may not be recursive" ext_full_name | Pexp_match (expr, cases) -> expand_match ext ~extension_kind ~loc ~modul ~locality 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 ext ~extension_kind ~loc ~modul ~locality 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 ext ~locality extension_kind in Location.raise_errorf ~loc "'if%%%s' must include an else branch" ext_full_name in expand_if ext ~extension_kind ~loc ~modul ~locality expr then_ else_ | Pexp_while (cond, body) -> expand_while ext ~extension_kind ~loc ~modul ~locality ~cond ~body | _ -> Location.raise_errorf ~loc "'%%%s' can only be used with 'let', 'match', 'while', and 'if'" (ext_full_name ext ~locality extension_kind) in { expansion with pexp_attributes = expr.pexp_attributes @ expansion.pexp_attributes } ;; let map = (module Map : Ext) let bind = (module Bind : Ext) ppx_let-0.17.0/expander/ppx_let_expander.mli000066400000000000000000000101711461647336100211370ustar00rootroot00000000000000open 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 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 (* When true, prevent_tail_call will keep the resulting function application from being in tail position by introducing a local variable. This is useful when working in with locals, and was added in order to allow ppx_bonsai to transform {[ let%sub a = foo in a ]} into {[ ((sub foo ~f:(fun a -> a))[@nontail]) ]} instead of {[ sub foo ~f:(fun a -> a) ]} *) val prevent_tail_call : 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 -> locality:[ `local | `global ] -> expression -> case list -> expression (* [expand] is the function that normally expands let%[name]. [wrap_expansion] can be used to change the parameters given to [expand] and can also tranform the output of [expand]. *) val wrap_expansion : loc:location -> modul:longident loc option -> value_binding list -> expression -> expand:(loc:location -> value_binding list -> expression -> expression) -> expression end (* A trivial implementation of [Ext.wrap_expansion] that does nothing to change the expansion behavior. *) val wrap_expansion_identity : loc:location -> modul:longident loc option -> value_binding list -> expression -> expand:(loc:location -> value_binding list -> expression -> expression) -> expression type t = (module Ext) val ext_full_name : t -> locality:[ `local | `global ] -> Extension_kind.t -> label val bind : t val map : t val variables_of : label loc list Ast_traverse.fold module Map : sig val name : string val with_location : bool end val eoperator : loc:location -> modul:longident loc option -> label -> expression val expand_match : t -> extension_kind:Extension_kind.t -> loc:location -> modul:longident loc option -> locality:[ `local | `global ] -> expression -> case list -> expression val maybe_destruct : destruct: (assume_exhaustive:bool -> loc:location -> modul:'a -> lhs:pattern -> rhs:expression -> body:expression -> expression option) -> loc:location -> modul:'a -> locality:[ `local | `global ] -> lhs:pattern -> body:expression -> expression val bind_apply : ?fn_label:string (** default: "f" *) -> prevent_tail_call:bool -> op_name:label -> loc:location -> modul:longident loc option -> with_location:bool -> arg:expression -> fn:expression -> unit -> expression val qualified_return : loc:location -> modul:longident loc option -> expression -> expression val expand : t -> Extension_kind.t -> modul:longident loc option -> locality:[ `local | `global ] -> expression -> expression val do_not_enter_value : value_binding -> value_binding val nontail : loc:location -> expression -> expression ppx_let-0.17.0/ppx_let.opam000066400000000000000000000013431461647336100156170ustar00rootroot00000000000000opam-version: "2.0" version: "v0.17.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" {>= "5.1.0"} "base" {>= "v0.17" & < "v0.18"} "ppx_here" {>= "v0.17" & < "v0.18"} "dune" {>= "3.11.0"} "ppxlib" {>= "0.28.0"} ] available: arch != "arm32" & arch != "x86_32" synopsis: "Monadic let-bindings" description: " Part of the Jane Street's PPX rewriters collection. " ppx_let-0.17.0/src/000077500000000000000000000000001461647336100140545ustar00rootroot00000000000000ppx_let-0.17.0/src/dune000066400000000000000000000002121461647336100147250ustar00rootroot00000000000000(library (name ppx_let) (public_name ppx_let) (kind ppx_rewriter) (libraries ppxlib ppx_let_expander) (preprocess no_preprocessing)) ppx_let-0.17.0/src/ppx_let.ml000066400000000000000000000014551461647336100160660ustar00rootroot00000000000000open Ppxlib let ext t ~locality extension_kind = Extension.declare_with_path_arg (Ppx_let_expander.ext_full_name t ~locality extension_kind) Extension.Context.expression Ast_pattern.(single_expr_payload __) (fun ~loc:_ ~path:_ ~arg expr -> Ppx_let_expander.expand t extension_kind ~modul:arg ~locality expr) ;; open Ppx_let_expander module List = struct include List let concat_map list ~f = List.concat_map f list let map list ~f = List.map f list end let () = let extensions = List.concat_map [ bind; map ] ~f:(fun t -> List.concat_map [ `local; `global ] ~f:(fun locality -> List.map Extension_kind.[ default; default_open; n; n_open ] ~f:(fun kind -> ext t ~locality kind))) in Driver.register_transformation "let" ~extensions ;; ppx_let-0.17.0/src/ppx_let.mli000066400000000000000000000000001461647336100162200ustar00rootroot00000000000000ppx_let-0.17.0/test/000077500000000000000000000000001461647336100142445ustar00rootroot00000000000000ppx_let-0.17.0/test/dune000066400000000000000000000001141461647336100151160ustar00rootroot00000000000000(executables (modes byte exe) (names test) (preprocess (pps ppx_let))) ppx_let-0.17.0/test/inline/000077500000000000000000000000001461647336100155225ustar00rootroot00000000000000ppx_let-0.17.0/test/inline/dune000066400000000000000000000001611461647336100163760ustar00rootroot00000000000000(library (name ppx_let_test) (libraries core ppx_let_expander) (preprocess (pps ppx_jane ppxlib.metaquot))) ppx_let-0.17.0/test/inline/local_option.ml000066400000000000000000000014101461647336100205320ustar00rootroot00000000000000type 'a t = 'a option let return x = Some x let map t ~f = match t with | None -> None | Some x -> Some (f x) ;; let bind t ~f = match t with | None -> None | Some x -> f x ;; let both t1 t2 = match t1, t2 with | Some t1, Some t2 -> Some (t1, t2) | _ -> None ;; let bind4 t1 t2 t3 t4 ~f = match t1, t2, t3, t4 with | Some t1, Some t2, Some t3, Some t4 -> f t1 t2 t3 t4 | _ -> None ;; let map4 t1 t2 t3 t4 ~f = match t1, t2, t3, t4 with | Some t1, Some t2, Some t3, Some t4 -> Some (f t1 t2 t3 t4) | _ -> None ;; module Let_syntax = struct module Let_syntax = struct let return = return let map = map let bind = bind let both = both let map4 = map4 let bind4 = bind4 module Open_on_rhs = struct end end end ppx_let-0.17.0/test/inline/local_option.mli000066400000000000000000000010151461647336100207040ustar00rootroot00000000000000(** A local option monad, to demonstrate [let%mapl] and [let%bindl]. *) type 'a t = 'a option module Let_syntax : sig module Let_syntax : sig val return : 'a -> 'a t val map : 'a t -> f:('a -> 'b) -> 'b t val bind : 'a t -> f:('a -> 'b t) -> 'b t val both : 'a t -> 'b t -> ('a * 'b) t val map4 : 'a t -> 'b t -> 'c t -> 'd t -> f:('a -> 'b -> 'c -> 'd -> 'e) -> 'e t val bind4 : 'a t -> 'b t -> 'c t -> 'd t -> f:('a -> 'b -> 'c -> 'd -> 'e t) -> 'e t module Open_on_rhs : sig end end end ppx_let-0.17.0/test/inline/test_local.ml000066400000000000000000000075631461647336100202200ustar00rootroot00000000000000open Core open Ppxlib let loc = Location.none let print_expr expr = Pprintast.string_of_expression expr |> print_string (* Doesn't actually check anything except within JS walls -- the public compiler doesn't yet support local allocations. *) let assert_zero_alloc f = let allocations_before = Gc.major_plus_minor_words () in let r = f () in let allocations_after = Gc.major_plus_minor_words () in let allocations = allocations_after - allocations_before in [%test_result: int] allocations ~expect:0; r ;; let check_some n = match n with | Some () -> () | None -> failwith "must be some" ;; let%expect_test "while%bindl trivial test" = let i = ref 0 in let (r : unit option) = assert_zero_alloc (fun () -> while%bindl.Local_option incr i; Some (!i <= 5) do Some () done) in check_some r [@nontail] ;; let%expect_test "let%bindl expansion" = Ppx_let_expander.expand Ppx_let_expander.bind Ppx_let_expander.Extension_kind.default ~modul:None ~locality:`local [%expr let PATTERN1 = return EXPRESSION1 and PATTERN2 = return EXPRESSION2 in return EXPRESSION3] |> print_expr; [%expect {| let __let_syntax__001_ = return EXPRESSION1[@@ppxlib.do_not_enter_value ] and __let_syntax__002_ = return EXPRESSION2[@@ppxlib.do_not_enter_value ] in Let_syntax.bind (Let_syntax.both __let_syntax__001_ __let_syntax__002_) ~f:(fun (PATTERN1, PATTERN2) -> local_ let __nontail__004_ = return EXPRESSION3 in __nontail__004_) |}] ;; let%expect_test "let%mapl expansion" = Ppx_let_expander.expand Ppx_let_expander.map Ppx_let_expander.Extension_kind.default ~modul:None ~locality:`local [%expr let PATTERN1 = return EXPRESSION1 and PATTERN2 = return EXPRESSION2 in return EXPRESSION3] |> print_expr; [%expect {| let __let_syntax__005_ = return EXPRESSION1[@@ppxlib.do_not_enter_value ] and __let_syntax__006_ = return EXPRESSION2[@@ppxlib.do_not_enter_value ] in Let_syntax.map (Let_syntax.both __let_syntax__005_ __let_syntax__006_) ~f:(fun (PATTERN1, PATTERN2) -> local_ let __nontail__008_ = return EXPRESSION3 in __nontail__008_) |}] ;; let something_to_tail_call () = Some () let%expect_test "make sure let%bindl and let%mapl work well together" = let r : unit option option option = assert_zero_alloc (fun () -> match%bindl.Local_option Some () with | () -> let open Local_option.Let_syntax in let%bindl () = Some () and () = Some () in let%mapl () = Some () and () = Some () in let%bindl () = Some () in let%mapl () = Some () in something_to_tail_call () [@nontail]) in match r with | Some (Some x) -> check_some x [@nontail] | _ -> failwith "how?" ;; let%expect_test "bind4" = let r : unit option = assert_zero_alloc (fun () -> let%bindln.Local_option () = Some () and () = Some () and () = Some () and () = Some () in Some ()) in check_some r [@nontail] ;; let%expect_test "map4" = let r : unit option = assert_zero_alloc (fun () -> let%mapln.Local_option () = Some () and () = Some () and () = Some () and () = Some () in ()) in check_some r [@nontail] ;; let%expect_test "match%bindl" = let r : unit option = assert_zero_alloc (fun () -> match%bindl.Local_option Some `hello with | `hello -> Some ()) in check_some r [@nontail] ;; let%expect_test "if%bindl" = let r : unit option = assert_zero_alloc (fun () -> if%bindl.Local_option Some true then Some () else failwith "impossible") in check_some r [@nontail] ;; let%expect_test "if%mapl" = let r : unit option = assert_zero_alloc (fun () -> if%mapl.Local_option Some true then () else failwith "impossible") in check_some r [@nontail] ;; ppx_let-0.17.0/test/inline/test_local.mli000066400000000000000000000000551461647336100203560ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_let-0.17.0/test/inline/test_op_n.ml000066400000000000000000000150001461647336100200420ustar00rootroot00000000000000open Core open Ppxlib let all_localities = [ `global; `local ] let loc = Location.none let print_expr expr = Pprintast.string_of_expression expr |> print_string let expand extension kind ~modul expr = List.iteri all_localities ~f:(fun i locality -> if i > 0 then printf "----\n"; printf !"locality = %{sexp:[`local|`global]}:\n" locality; Ppx_let_expander.expand extension kind ~modul ~locality expr |> print_expr; printf "\n") ;; let%expect_test "single pattern map" = expand Ppx_let_expander.map Ppx_let_expander.Extension_kind.n ~modul:None [%expr let MY_PAT = MY_EXPR in MY_BODY]; [%expect {| locality = global: Let_syntax.map MY_EXPR ~f:(fun (MY_PAT) -> MY_BODY) ---- locality = local: Let_syntax.map MY_EXPR ~f:(fun (MY_PAT) -> local_ let __nontail__002_ = MY_BODY in __nontail__002_) |}] ;; let%expect_test "single pattern map with modul" = 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]; [%expect {| locality = global: X.Let_syntax.Let_syntax.map MY_EXPR ~f:(fun (MY_PAT) -> MY_BODY) ---- locality = local: X.Let_syntax.Let_syntax.map MY_EXPR ~f:(fun (MY_PAT) -> local_ let __nontail__005_ = MY_BODY in __nontail__005_) |}] ;; let%expect_test "double pattern map" = 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]; [%expect {| locality = global: let __let_syntax__007_ = MY_EXPR_1[@@ppxlib.do_not_enter_value ] and __let_syntax__008_ = MY_EXPR_2[@@ppxlib.do_not_enter_value ] in Let_syntax.map2 __let_syntax__007_ __let_syntax__008_ ~f:(fun (MY_PAT_1) (MY_PAT_2) -> MY_BODY) ---- locality = local: let __let_syntax__011_ = MY_EXPR_1[@@ppxlib.do_not_enter_value ] and __let_syntax__012_ = MY_EXPR_2[@@ppxlib.do_not_enter_value ] in Let_syntax.map2 __let_syntax__011_ __let_syntax__012_ ~f:(fun (MY_PAT_1) (MY_PAT_2) -> local_ let __nontail__013_ = MY_BODY in __nontail__013_) |}] ;; let%expect_test "single pattern map open" = 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]; [%expect {| locality = global: Let_syntax.map (let open! Let_syntax.Open_on_rhs in MY_EXPR_1) ~f:(fun (MY_PAT_1) -> MY_BODY) ---- locality = local: Let_syntax.map (let open! Let_syntax.Open_on_rhs in MY_EXPR_1) ~f:(fun (MY_PAT_1) -> local_ let __nontail__017_ = MY_BODY in __nontail__017_) |}] ;; let%expect_test "double pattern map open" = 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]; [%expect {| locality = global: let __let_syntax__019_ = let open! Let_syntax.Open_on_rhs in MY_EXPR_1 [@@ppxlib.do_not_enter_value ] and __let_syntax__020_ = let open! Let_syntax.Open_on_rhs in MY_EXPR_2 [@@ppxlib.do_not_enter_value ] in Let_syntax.map2 __let_syntax__019_ __let_syntax__020_ ~f:(fun (MY_PAT_1) (MY_PAT_2) -> MY_BODY) ---- locality = local: let __let_syntax__023_ = let open! Let_syntax.Open_on_rhs in MY_EXPR_1 [@@ppxlib.do_not_enter_value ] and __let_syntax__024_ = let open! Let_syntax.Open_on_rhs in MY_EXPR_2 [@@ppxlib.do_not_enter_value ] in Let_syntax.map2 __let_syntax__023_ __let_syntax__024_ ~f:(fun (MY_PAT_1) (MY_PAT_2) -> local_ let __nontail__025_ = MY_BODY in __nontail__025_) |}] ;; let%expect_test "quadruple pattern map" = 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]; [%expect {| locality = global: let __let_syntax__028_ = MY_EXPR_1[@@ppxlib.do_not_enter_value ] and __let_syntax__029_ = MY_EXPR_2[@@ppxlib.do_not_enter_value ] and __let_syntax__030_ = MY_EXPR_3[@@ppxlib.do_not_enter_value ] and __let_syntax__031_ = MY_EXPR_4[@@ppxlib.do_not_enter_value ] in Let_syntax.map4 __let_syntax__028_ __let_syntax__029_ __let_syntax__030_ __let_syntax__031_ ~f:(fun (MY_PAT_1) (MY_PAT_2) (SUB_PATTERN_1, SUB_PATTERN_2) (MY_PAT_4) -> MY_BODY) ---- locality = local: let __let_syntax__036_ = MY_EXPR_1[@@ppxlib.do_not_enter_value ] and __let_syntax__037_ = MY_EXPR_2[@@ppxlib.do_not_enter_value ] and __let_syntax__038_ = MY_EXPR_3[@@ppxlib.do_not_enter_value ] and __let_syntax__039_ = MY_EXPR_4[@@ppxlib.do_not_enter_value ] in Let_syntax.map4 __let_syntax__036_ __let_syntax__037_ __let_syntax__038_ __let_syntax__039_ ~f:(fun (MY_PAT_1) (MY_PAT_2) (SUB_PATTERN_1, SUB_PATTERN_2) (MY_PAT_4) -> local_ let __nontail__040_ = MY_BODY in __nontail__040_) |}] ;; let%expect_test "quadruple pattern bind" = 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]; [%expect {| locality = global: let __let_syntax__045_ = MY_EXPR_1[@@ppxlib.do_not_enter_value ] and __let_syntax__046_ = MY_EXPR_2[@@ppxlib.do_not_enter_value ] and __let_syntax__047_ = MY_EXPR_3[@@ppxlib.do_not_enter_value ] and __let_syntax__048_ = MY_EXPR_4[@@ppxlib.do_not_enter_value ] in Let_syntax.bind4 __let_syntax__045_ __let_syntax__046_ __let_syntax__047_ __let_syntax__048_ ~f:(fun (MY_PAT_1) (MY_PAT_2) (SUB_PATTERN_1, SUB_PATTERN_2) (MY_PAT_4) -> MY_BODY) ---- locality = local: let __let_syntax__053_ = MY_EXPR_1[@@ppxlib.do_not_enter_value ] and __let_syntax__054_ = MY_EXPR_2[@@ppxlib.do_not_enter_value ] and __let_syntax__055_ = MY_EXPR_3[@@ppxlib.do_not_enter_value ] and __let_syntax__056_ = MY_EXPR_4[@@ppxlib.do_not_enter_value ] in Let_syntax.bind4 __let_syntax__053_ __let_syntax__054_ __let_syntax__055_ __let_syntax__056_ ~f:(fun (MY_PAT_1) (MY_PAT_2) (SUB_PATTERN_1, SUB_PATTERN_2) (MY_PAT_4) -> local_ let __nontail__057_ = MY_BODY in __nontail__057_) |}] ;; ppx_let-0.17.0/test/inline/test_op_n.mli000066400000000000000000000000551461647336100202170ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_let-0.17.0/test/inline/test_while.ml000066400000000000000000000045621461647336100202320ustar00rootroot00000000000000open Core open Ppxlib let all_localities = [ `global; `local ] let loc = Location.none let print_expr expr = Pprintast.string_of_expression expr |> print_string let expand extension kind ~modul expr = List.iteri all_localities ~f:(fun i locality -> if i > 0 then printf "----\n"; printf !"locality = %{sexp:[`local|`global]}:\n" locality; Ppx_let_expander.expand extension kind ~modul ~locality expr |> print_expr; printf "\n") ;; let%expect_test "while%bind expansion" = expand Ppx_let_expander.bind Ppx_let_expander.Extension_kind.default ~modul:None [%expr while MY_CONDITION do MY_BODY done]; [%expect {| locality = global: 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 ())[@@ppxlib.do_not_enter_value ] in __let_syntax_loop__001_ () ---- locality = local: let rec __let_syntax_loop__002_ () = local_ let __nontail__005_ = Let_syntax.bind MY_CONDITION ~f:(fun __let_syntax__003_ -> local_ let __nontail__004_ = match __let_syntax__003_ with | true -> Let_syntax.bind MY_BODY ~f:__let_syntax_loop__002_ | false -> Let_syntax.return () in __nontail__004_) in __nontail__005_[@@ppxlib.do_not_enter_value ] in __let_syntax_loop__002_ () |}] ;; 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.17.0/test/inline/test_while.mli000066400000000000000000000000551461647336100203740ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_let-0.17.0/test/test-code-path.mlt000066400000000000000000000037521461647336100176120ustar00rootroot00000000000000open Base open Stdio open Ppxlib open Ast_builder.Default open Monad.Ident.Let_syntax let () = Driver.register_transformation "code_path" ~rules: [ Context_free.Rule.extension (Extension.V3.declare "code_path" Expression Ast_pattern.(pstr nil) (fun ~ctxt -> estring ~loc:(Expansion_context.Extension.extension_point_loc ctxt) (Code_path.enclosing_value (Expansion_context.Extension.code_path ctxt) |> Option.value ~default:"_"))) ] ;; let () = let without_bind = [%code_path] in let%bind with_bind = [%code_path] in let%bind with_bind_and_left = [%code_path] and with_bind_and_right = [%code_path] in print_endline without_bind; print_endline with_bind; print_endline with_bind_and_left; print_endline with_bind_and_right ;; [%%expect {| without_bind with_bind with_bind_and_left with_bind_and_right |}] let () = let without_bind_fst, without_bind_snd = [%code_path], [%code_path] in let%bind with_bind_fst, with_bind_snd = [%code_path], [%code_path] in print_endline without_bind_fst; print_endline without_bind_snd; print_endline with_bind_fst; print_endline with_bind_snd ;; [%%expect {| _ _ _ _ |}] let () = let a, b = [%code_path], [%code_path] and c = [%code_path] in let%bind x, y = [%code_path], [%code_path] and z = [%code_path] in print_endline a; print_endline b; print_endline c; print_endline x; print_endline y; print_endline z ;; [%%expect {| _ _ c _ _ z |}] let () = let without_bind_outer = let without_bind_inner = [%code_path] in print_endline without_bind_inner; [%code_path] in print_endline without_bind_outer; let%bind with_bind_outer = let%bind with_bind_inner = [%code_path] in print_endline with_bind_inner; [%code_path] in print_endline with_bind_outer ;; [%%expect {| without_bind_inner without_bind_outer with_bind_inner with_bind_outer |}] ppx_let-0.17.0/test/test-dup-pattern.mlt000066400000000000000000000007171461647336100202070ustar00rootroot00000000000000module 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.17.0/test/test-locations.mlt000066400000000000000000000007741461647336100177420ustar00rootroot00000000000000#print_line_numbers true 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 18, characters 12-16: 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.17.0/test/test.ml000066400000000000000000000116641461647336100155650ustar00rootroot00000000000000module 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 let () = (* Use this code to test if :MerlinTypeOf behaves properly. In particular, [lhs_*] variables should have type 'a instead of 'a Monad_example.X.t. *) let open Monad_example.X.Let_syntax in let rhs_a = return 1 in let rhs_b = return 1. in let rhs_c = return 'c' in let (_ : _) = (* Non-parallel sequence of binds. *) let%bind lhs_a = rhs_a in let%bind lhs_b = rhs_b in let%bind lhs_c = rhs_c in return (lhs_a, lhs_b, lhs_c) in let tuple = (* Parallel bind. *) let%bind lhs_a = rhs_a and lhs_b = rhs_b and lhs_c = rhs_c in return (lhs_a, lhs_b, lhs_c) in let (_ : _) = (* Destructuring parallel bind. *) let%bind lhs_a, lhs_b, lhs_c = tuple and lhs_a', lhs_b', lhs_c' = tuple in return (lhs_a, lhs_b, lhs_c, lhs_a', lhs_b', lhs_c') in let (_ : _) = (* Body is a function *) let%map lhs_a, lhs_b, lhs_c = tuple in fun () -> lhs_c, lhs_b, lhs_a in () ;;