commit f255c375a06ab1581ec70420963efd34ae89ea50 Author: Jeremie Dimino Date: Tue Jan 12 17:20:06 2016 +0000 113.24.00 diff --git a/.gitignore b/.gitignore new file mode 100644 index 000000000..8dac9f323 --- /dev/null +++ b/.gitignore @@ -0,0 +1,7 @@ +_build/ +/setup.data +/setup.log +/*.exe +/*.docdir +/*.native +/*.byte diff --git a/INRIA-DISCLAIMER.txt b/INRIA-DISCLAIMER.txt new file mode 100644 index 000000000..01d2976d7 --- /dev/null +++ b/INRIA-DISCLAIMER.txt @@ -0,0 +1,12 @@ +THIS SOFTWARE IS PROVIDED BY INRIA AND CONTRIBUTORS "AS IS" AND ANY +EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL INRIA OR ITS CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN +IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + diff --git a/LICENSE.txt b/LICENSE.txt new file mode 100644 index 000000000..d64569567 --- /dev/null +++ b/LICENSE.txt @@ -0,0 +1,202 @@ + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/META.ab b/META.ab new file mode 100644 index 000000000..8dc31d222 --- /dev/null +++ b/META.ab @@ -0,0 +1,8 @@ +version = "$(pkg_version)" +description = "Monadic let-bindings" +requires = "ppx_core ppx_driver" +archive(ppx_driver, byte ) = "ppx_let.cma" +archive(ppx_driver, native ) = "ppx_let.cmxa" +archive(ppx_driver, native, plugin) = "ppx_let.cmxs" +exists_if = "ppx_let.cma" +ppx(-ppx_driver) = "./ppx" diff --git a/Makefile b/Makefile new file mode 100644 index 000000000..d97d2e123 --- /dev/null +++ b/Makefile @@ -0,0 +1,68 @@ +# Generic Makefile for oasis project + +SETUP := setup.exe +NAME := ppx_let +PREFIX = $(shell grep ^prefix= setup.data | cut -d\" -f 2) + +# Default rule +default: build + +setup.exe: _oasis setup.ml + ocamlfind ocamlopt -o $@ -linkpkg -package ocamlbuild,oasis.dynrun setup.ml || \ + ocamlfind ocamlc -o $@ -linkpkg -package ocamlbuild,oasis.dynrun setup.ml || true + for f in setup.*; do [ $$f = $@ -o $$f = setup.ml ] || rm -f $$f; done + +build: $(SETUP) setup.data + ./$(SETUP) -build $(BUILDFLAGS) + $(MAKE) $(NAME).install + +doc: $(SETUP) setup.data build + ./$(SETUP) -doc $(DOCFLAGS) + +test: $(SETUP) setup.data build + ./$(SETUP) -test $(TESTFLAGS) + +all: $(SETUP) + ./$(SETUP) -all $(ALLFLAGS) + $(MAKE) $(NAME).install + +$(NAME).install: js-utils/gen_install.ml setup.log setup.data + ocaml -I js-utils js-utils/gen_install.ml + +install: $(NAME).install + opam-installer -i --prefix $(PREFIX) $(NAME).install + +uninstall: $(NAME).install + opam-installer -u --prefix $(PREFIX) $(NAME).install + +reinstall: $(NAME).install + opam-installer -u --prefix $(PREFIX) $(NAME).install &> /dev/null || true + opam-installer -i --prefix $(PREFIX) $(NAME).install + +bin.tar.gz: $(NAME).install + rm -rf _install + mkdir _install + opam-installer -i --prefix _install $(NAME).install + tar czf bin.tar.gz -C _install . + rm -rf _install + +bin.lzo: $(NAME).install + rm -rf _install + mkdir _install + opam-installer -i --prefix _install $(NAME).install + cd _install && lzop -1 -P -o ../bin.lzo `find . -type f` + rm -rf _install + +clean: $(SETUP) + ./$(SETUP) -clean $(CLEANFLAGS) + +distclean: $(SETUP) + ./$(SETUP) -distclean $(DISTCLEANFLAGS) + +configure: $(SETUP) + ./$(SETUP) -configure $(CONFIGUREFLAGS) + +setup.data: $(SETUP) + ./$(SETUP) -configure $(CONFIGUREFLAGS) + +.PHONY: default build doc test all install uninstall reinstall clean distclean configure diff --git a/README.md b/README.md new file mode 100644 index 000000000..cbd8c2ede --- /dev/null +++ b/README.md @@ -0,0 +1,156 @@ +A ppx rewriter for monadic and applicative let bindings and match statements. + +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 -> ('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\_monad 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 +``` + +### Match statements + +We found that this form was quite useful for match statements as +well. So for convenience ppx\_monad also accept `%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`. + +Syntactic forms and actual rewriting +------------------------------------ + +`ppx_let` adds four 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 | ... +``` + +that expand into + +```ocaml +bind M (fun P -> E) + +map M (fun P -> E) + +bind M (function P1 -> E1 | P2 -> E2 | ...) + +map M (function P1 -> E1 | P2 -> E2 | ...) +``` + +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))) + (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))) + (fun (P1, (P2, (P3, P4))) -> E) +``` + +respectively. (Instead of `x1`, `x2`, ... ppx\_monad 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`. + +For monads, `Core.Std.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 + 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 >> + module Open_in_body : << some signature >> +end +``` + +The `Open_on_rhs` and `Open_in_body` submodules are used by variants +of `%map` and `%bind` called `%map_open` and `%bind_open`. + +The `Open_on_rhs` submodule is locally opened on the right hand sides +of the rewritten let bindings in `%map_open` and `%bind_open` +expressions. This is useful when programming with applicatives, which +operate in a staged manner where the operators used to construct the +applicatives are distinct from the operators used to manipulate the +values those applicatives produce. For monads, `Open_on_rhs` contains +`return`. + +The `Open_in_body` submodule is locally opened in the body of either a +`let%map_open` or `let%bind_open`. It is often empty for +applicatives. For monads in `Core`, it contains `return`. + +For `match%map_open` and `match%bind_open` expressions, `Open_on_rhs` +is opened for the expression being matched on, and `Open_in_body` is +opened in the body of each pattern match clause. diff --git a/THIRD-PARTY.txt b/THIRD-PARTY.txt new file mode 100644 index 000000000..da8a77285 --- /dev/null +++ b/THIRD-PARTY.txt @@ -0,0 +1,18 @@ +The repository contains 3rd-party code in the following locations and +under the following licenses: + +- type_conv, sexplib and bin_prot: based on Tywith, by Martin + Sandin. License can be found in base/sexplib/LICENSE-Tywith.txt, + base/type_conv/LICENSE-Tywith.txt, and base/bin_prot/LICENSE-Tywith.txt. + +- Core's implementation of union-find: based on an implementation by + Henry Matthew Fluet, Suresh Jagannathan, and Stephen Weeks. License + can be found in base/core/MLton-license. + +- Various Core libraries are based on INRIA's OCaml + distribution. Relicensed under Apache 2.0, as permitted under the + Caml License for Consortium members: + + http://caml.inria.fr/consortium/license.en.html + + See also the disclaimer INRIA-DISCLAIMER.txt. diff --git a/_oasis b/_oasis new file mode 100644 index 000000000..98075ac8e --- /dev/null +++ b/_oasis @@ -0,0 +1,33 @@ +OASISFormat: 0.4 +OCamlVersion: >= 4.02.3 +FindlibVersion: >= 1.3.2 +Name: ppx_let +Version: 113.24.00 +Synopsis: Monadic let-bindings +Authors: Jane Street Group, LLC +Copyrights: (C) 2015-2016 Jane Street Group LLC +Maintainers: Jane Street Group, LLC +License: Apache-2.0 +LicenseFile: LICENSE.txt +Homepage: https://github.com/janestreet/ppx_let +Plugins: StdFiles (0.3), DevFiles (0.3), META (0.3) +XStdFilesAUTHORS: false +XStdFilesREADME: false +BuildTools: ocamlbuild +FilesAB: META.ab +Description: + Part of the Jane Street's PPX rewriters collection. + +Library ppx_let + Path: src + Pack: false + Modules: Ppx_let + BuildDepends: ppx_core, + ppx_driver + +Executable ppx + Path: as_ppx + MainIs: ppx.ml + CompiledObject: best + BuildDepends: ppx_let, + ppx_driver diff --git a/_tags b/_tags new file mode 100644 index 000000000..48f85ad4b --- /dev/null +++ b/_tags @@ -0,0 +1,8 @@ +<**/*.ml{,i}>: warn(-40), no_alias_deps +<**/*>: thread +# This prevents the implicit addition of -ppx options by ocamlfind +<**/*.ml{,i}>: predicate(ppx_driver) +: predicate(ppx_driver) +: linkall +# OASIS_START +# OASIS_STOP diff --git a/as_ppx/ppx.ml b/as_ppx/ppx.ml new file mode 100644 index 000000000..e0c207cce --- /dev/null +++ b/as_ppx/ppx.ml @@ -0,0 +1 @@ +Ppx_driver.run_as_ppx_rewriter () diff --git a/configure b/configure new file mode 100755 index 000000000..3234be22e --- /dev/null +++ b/configure @@ -0,0 +1,5 @@ +#!/bin/sh + +# OASIS_START +make configure CONFIGUREFLAGS="$*" +# OASIS_STOP diff --git a/descr b/descr new file mode 100644 index 000000000..fad50b245 --- /dev/null +++ b/descr @@ -0,0 +1,2 @@ +Monadic let-bindings +Part of the Jane Street's PPX rewriters collection. diff --git a/js-utils/gen_install.ml b/js-utils/gen_install.ml new file mode 100644 index 000000000..39db64239 --- /dev/null +++ b/js-utils/gen_install.ml @@ -0,0 +1,102 @@ +(* Generate .install from setup.log *) + +#use "install_tags.ml" + +module String_map = Map.Make(String) +let string_map_of_list = + List.fold_left + (fun acc (k, v) -> + assert (not (String_map.mem k acc)); + String_map.add k v acc) + String_map.empty + +let lines_of_file fn = + let ic = open_in fn in + let rec loop acc = + match input_line ic with + | exception End_of_file -> + close_in ic; + List.rev acc + | line -> + loop (line :: acc) + in + loop [] + +let read_setup_log () = + lines_of_file "setup.log" + |> List.map (fun line -> Scanf.sscanf line "%S %S" (fun tag arg -> (tag, arg))) + +let read_setup_data () = + lines_of_file "setup.data" + |> List.map (fun line -> Scanf.sscanf line "%[^=]=%S" (fun k v -> (k, v))) + +let remove_cwd = + let prefix = Sys.getcwd () ^ "/" in + let len_prefix = String.length prefix in + fun fn -> + let len = String.length fn in + if len >= len_prefix && String.sub fn 0 len_prefix = prefix then + String.sub fn len_prefix (len - len_prefix) + else + fn + +let gen_section oc name files = + let pr fmt = Printf.fprintf oc (fmt ^^ "\n") in + pr "%s: [" name; + List.iter + (fun (src, dst) -> + let src = remove_cwd src in + let dst = + match dst with + | None -> Filename.basename src + | Some fn -> fn + in + if src = dst then + pr " %S" src + else + pr " %S {%S}" src dst) + files; + pr "]" + +let rec filter_log tags log acc = + match log with + | [] -> acc + | (tag, fname) :: rest -> + match String_map.find tag tags with + | exception Not_found -> filter_log tags rest acc + | dst -> filter_log tags rest ((fname, dst) :: acc) + +let () = + let log = read_setup_log () in + let setup_data = read_setup_data () in + let ext_dll = + match List.assoc "ext_dll" setup_data with + | ext -> ext + | exception Not_found -> ".so" + in + let merge name files map = + match String_map.find name map with + | files' -> String_map.add name (files @ files') map + | exception Not_found -> String_map.add name files map + in + let sections = + List.fold_left + (fun acc (name, tags, extra_files) -> + let tags = string_map_of_list tags in + let files = filter_log tags log [] @ extra_files in + if name = "lib" then + let stubs, others = + List.partition + (fun (fn, _) -> Filename.check_suffix fn ext_dll) + files + in + merge "lib" others (merge "stublibs" stubs acc) + else + merge name files acc) + String_map.empty sections + |> String_map.bindings + |> List.filter (fun (_, l) -> l <> []) + in + let oc = open_out (package_name ^ ".install") in + List.iter (fun (name, files) -> gen_section oc name files) sections; + close_out oc diff --git a/js-utils/install_tags.ml b/js-utils/install_tags.ml new file mode 100644 index 000000000..c0c42dc6e --- /dev/null +++ b/js-utils/install_tags.ml @@ -0,0 +1,13 @@ +let package_name = "ppx_let" + +let sections = + [ ("lib", + [ ("built_lib_ppx_let", None) + ], + [ ("META", None) + ]) + ; ("libexec", + [ ("built_exec_ppx", Some "ppx") + ], + []) + ] diff --git a/myocamlbuild.ml b/myocamlbuild.ml new file mode 100644 index 000000000..46889547f --- /dev/null +++ b/myocamlbuild.ml @@ -0,0 +1,29 @@ +(* OASIS_START *) +(* OASIS_STOP *) +# 3 "myocamlbuild.ml" + +(* Temporary hacks *) +let js_hacks = function + | After_rules -> + rule "Generate a cmxs from a cmxa" + ~dep:"%.cmxa" + ~prod:"%.cmxs" + ~insert:`top + (fun env _ -> + Cmd (S [ !Options.ocamlopt + ; A "-shared" + ; A "-linkall" + ; A "-I"; A (Pathname.dirname (env "%")) + ; A (env "%.cmxa") + ; A "-o" + ; A (env "%.cmxs") + ])); + + (* Pass -predicates to ocamldep *) + pflag ["ocaml"; "ocamldep"] "predicate" (fun s -> S [A "-predicates"; A s]) + | _ -> () + +let () = + Ocamlbuild_plugin.dispatch (fun hook -> + js_hacks hook; + dispatch_default hook) diff --git a/opam b/opam new file mode 100644 index 000000000..ce1c4a254 --- /dev/null +++ b/opam @@ -0,0 +1,19 @@ +opam-version: "1.2" +maintainer: "opensource@janestreet.com" +authors: ["Jane Street Group, LLC "] +homepage: "https://github.com/janestreet/ppx_let" +bug-reports: "https://github.com/janestreet/ppx_let/issues" +dev-repo: "https://github.com/janestreet/ppx_let.git" +license: "Apache-2.0" +build: [ + ["./configure" "--prefix" prefix] + [make] +] +depends: [ + "ocamlbuild" {build} + "oasis" {build & >= "0.4"} + "ocamlfind" {build & >= "1.3.2"} + "ppx_core" + "ppx_driver" +] +available: [ ocaml-version >= "4.02.3" ] diff --git a/setup.ml b/setup.ml new file mode 100644 index 000000000..f6b6bc3b8 --- /dev/null +++ b/setup.ml @@ -0,0 +1,6 @@ +(* OASIS_START *) +open OASISDynRun;; +open OASISTypes;; +(* OASIS_STOP *) + +let () = setup () diff --git a/src/ppx_let.ml b/src/ppx_let.ml new file mode 100644 index 000000000..fa7a986e7 --- /dev/null +++ b/src/ppx_let.ml @@ -0,0 +1,149 @@ +open! StdLabels +open Ppx_core.Std +open Parsetree +open Ast_builder.Default + +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_name = struct + type t = + | Bind + | Bind_open + | Map + | Map_open + + let operator_name = function + | Bind | Bind_open -> "bind" + | Map | Map_open -> "map" + + let to_string = function + | Bind -> "bind" + | Bind_open -> "bind_open" + | Map -> "map" + | Map_open -> "map_open" +end + +let let_syntax = "Let_syntax" + +let open_on_rhs ~loc = Located.mk ~loc (Longident.Ldot (Lident let_syntax, "Open_on_rhs" )) +let open_in_body ~loc = Located.mk ~loc (Longident.Ldot (Lident let_syntax, "Open_in_body")) + +let eoperator ~loc func = + let lid : Longident.t = Ldot (Longident.Lident let_syntax, func) in + pexp_ident ~loc (Located.mk ~loc lid) +;; + +let expand_with_tmp_vars ~loc bindings expr ~f = + match bindings with + | [_] -> f ~loc bindings expr + | _ -> + let tmp_vars = List.map bindings ~f:(fun _ -> gen_symbol ~prefix:"__let_syntax" ()) in + let s_rhs_tmp_var (* s/rhs/tmp_var *) = + List.map2 bindings tmp_vars ~f:(fun vb var -> + { vb with pvb_expr = evar ~loc:vb.pvb_expr.pexp_loc var }) + in + let s_lhs_tmp_var (* s/lhs/tmp_var *) = + List.map2 bindings tmp_vars ~f:(fun vb var -> + { vb with pvb_pat = pvar ~loc:vb.pvb_pat.ppat_loc var }) + in + pexp_let ~loc Nonrecursive s_lhs_tmp_var (f ~loc s_rhs_tmp_var expr) +;; + +let bind_apply ~loc extension_name ~arg ~fn = + let fn_label = + match (extension_name : Extension_name.t) with + | Bind | Bind_open -> "" + | Map | Map_open -> "f" + in + pexp_apply ~loc + (eoperator ~loc (Extension_name.operator_name extension_name)) + [("", arg); (fn_label, fn)] +;; + +let maybe_open extension_name ~loc ~to_open:module_to_open expr = + match (extension_name : Extension_name.t) with + | Bind | Map -> expr + | Bind_open | Map_open -> pexp_open ~loc Override (module_to_open ~loc) expr +;; + +let expand_let extension_name ~loc bindings body = + (* 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 in + eapply ~loc (eoperator ~loc "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 in + ppat_tuple ~loc [p; acc]) + in + bind_apply ~loc extension_name ~arg:nested_boths + ~fn:(pexp_fun ~loc "" None nested_patterns + (maybe_open extension_name ~loc ~to_open:open_in_body body)) +;; + +let expand_match extension_name ~loc expr cases = + let cases = + List.map cases ~f:(fun case -> + { case with + pc_rhs = maybe_open extension_name ~loc ~to_open:open_in_body case.pc_rhs; + }) + in + bind_apply ~loc extension_name + ~arg:(maybe_open extension_name ~loc ~to_open:open_on_rhs expr) + ~fn:(pexp_function ~loc cases) +;; + +let expand ~loc:_ ~path:_ extension_name expr = + let loc = expr.pexp_loc in + let expansion = + match expr.pexp_desc with + | Pexp_let (Nonrecursive, bindings, expr) -> + let bindings = + List.map bindings ~f:(fun vb -> + { vb with + pvb_expr = maybe_open extension_name ~loc ~to_open:open_on_rhs vb.pvb_expr; + }) + in + expand_with_tmp_vars ~loc bindings expr ~f:(expand_let extension_name) + | Pexp_let (Recursive, _, _) -> + Location.raise_errorf ~loc "'let%%%s' may not be recursive" + (Extension_name.to_string extension_name) + | Pexp_match (expr, cases) -> + expand_match extension_name ~loc expr cases + | _ -> + Location.raise_errorf ~loc + "'%%%s' can only be used with 'let' and 'match'" + (Extension_name.to_string extension_name) + in + { expansion with pexp_attributes = expr.pexp_attributes @ expansion.pexp_attributes } +;; + +let ext extension_name = + Extension.V2.declare + (Extension_name.to_string extension_name) + Extension.Context.expression + Ast_pattern.(single_expr_payload __) + (expand extension_name) +;; + +let () = + Ppx_driver.register_transformation "let" + ~extensions:[ + ext Bind; + ext Bind_open; + ext Map; + ext Map_open; + ] +;; diff --git a/src/ppx_let.mli b/src/ppx_let.mli new file mode 100644 index 000000000..34976fd80 --- /dev/null +++ b/src/ppx_let.mli @@ -0,0 +1 @@ +(* This signature is deliberately empty. *) diff --git a/test/test.ml b/test/test.ml new file mode 100644 index 000000000..724543ce8 --- /dev/null +++ b/test/test.ml @@ -0,0 +1,229 @@ +module Monad_example = struct + + module X : sig + type 'a t + module Let_syntax : sig + val return : 'a -> 'a t + val bind : 'a t -> ('a -> 'b t) -> 'b t + val map : 'a t -> f:('a -> 'b) -> 'b t + val both : 'a t -> 'b t -> ('a * 'b) t + module Open_on_rhs : sig val return : 'a -> 'a t end + module Open_in_body : sig val return : 'a -> 'a t end + 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 + let bind = bind + let map = map + let both = both + module Open_on_rhs = struct let return = return end + module Open_in_body = struct let return = return end + end + end + + module Let_syntax = 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 = 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 +end + +module Applicative_example = struct + + module X : sig + type 'a t + module Let_syntax : sig + val return : 'a -> 'a t + val map : 'a t -> f:('a -> 'b) -> 'b t + val both : 'a t -> 'b t -> ('a * 'b) t + module Open_on_rhs : sig + val flag : int t + val anon : int t + end + module Open_in_body : sig 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 + let map = map + let both = both + module Open_on_rhs = struct + let flag = 66 + let anon = 77 + end + module Open_in_body = struct end + end + end + + module Let_syntax = 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 Async_command_override_example = struct + + module Deferred : sig + type 'a t + val return : 'a -> 'a t + module Let_syntax : sig + type 'a t + val return : 'a -> 'a t + val map : 'a t -> f:('a -> 'b) -> 'b t + val both : 'a t -> 'b t -> ('a * 'b) t + module Open_on_rhs : sig val return : 'a -> 'a t end + module Open_in_body : sig val return : 'a -> 'a t end + end with type 'a t := 'a t + end = struct + type 'a t = 'a + let return x = x + module Let_syntax = struct + let return = return + let map x ~f = f x + let both x y = (x, y) + module Open_on_rhs = struct let return = return end + module Open_in_body = struct let return = return end + end + end + + module Command : sig + module Param : sig + type 'a t + val return : 'a -> 'a t + val flag : 'a -> int t + val anon : 'a -> int t + end + module Let_syntax : sig + type 'a t + val return : 'a -> 'a t + val map : 'a t -> f:('a -> 'b) -> 'b t + val both : 'a t -> 'b t -> ('a * 'b) t + module Open_on_rhs = Param + module Open_in_body : sig end + end with type 'a t := 'a Param.t + end = struct + module Param = struct + type 'a t = 'a + let return x = x + let map x ~f = f x + let both x y = (x, y) + let flag _ = 66 + let anon _ = 77 + end + module Let_syntax = struct + include Param + module Open_on_rhs = Param + module Open_in_body = struct end + end + end + + module Command_override = struct + module Param = struct + include Command.Param + let special_flag = flag 88 + end + module Let_syntax = struct + include (Command.Let_syntax : module type of Command.Let_syntax + with module Open_on_rhs := Command.Let_syntax.Open_on_rhs + and module Open_in_body := Command.Let_syntax.Open_in_body) + + module Open_on_rhs = Param + module Open_in_body = struct + module Let_syntax = Deferred.Let_syntax + end + end + end + + let _1 : int Command.Param.t = + let module Let_syntax = Command.Let_syntax in + [%map_open + let x = flag "foo" + and y = anon "bar" + in + x + y + ] + ;; + + let _1 : (unit -> int Deferred.t) Command_override.Param.t = + let module Let_syntax = Command_override.Let_syntax in + [%map_open + let x = flag "foo" + and y = anon "bar" + and z = special_flag + in + (fun () -> + let%map () = Deferred.return () in + x + y + z) + ] + ;; + + let _1 : (unit -> unit Deferred.t) Command.Param.t = + let module Let_syntax = Command_override.Let_syntax in + [%map_open + let () = return () in + fun () -> + let%map () = Deferred.return () in + () + ] + ;; +end