Merge ppx_let

src/ppx_let/.gitignore

@@ -0,0 +1,5 @@
+_build
+*.install
+*.merlin
+_opam
+

src/ppx_let/CHANGES.md

@@ -0,0 +1,17 @@
+## 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.

src/ppx_let/CONTRIBUTING.md

@@ -0,0 +1,67 @@
+This 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 <joe.smith@email.com>
+```
+
+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/

src/ppx_let/CREDITS

@@ -0,0 +1,4 @@
+This folder contains a generalization of ppx_let from Jane Street.
+See git log this_folder for the development history.
+
+https://github.com/janestreet/ppx_let.git

src/ppx_let/LICENSE.md

@@ -0,0 +1,21 @@
+The MIT License
+
+Copyright (c) 2015--2019 Jane Street Group, LLC <opensource@janestreet.com>
+
+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.

src/ppx_let/Makefile

@@ -0,0 +1,17 @@
+INSTALL_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

src/ppx_let/README.md

@@ -0,0 +1,169 @@
+ppx_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
+```
+
+### 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`.
+
+Syntactic forms and actual rewriting
+------------------------------------
+
+`ppx_let` adds six 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
+```
+
+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)
+```
+
+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`.
+
+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.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
+  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
+```
+
+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`.

src/ppx_let/dune-project

@@ -0,0 +1 @@
+(lang dune 1.5)

src/ppx_let/expander/dune

@@ -0,0 +1,2 @@
+(library (name ppx_let_expander) (public_name ppx_let.expander)
+ (libraries base ppxlib) (preprocess no_preprocessing))

src/ppx_let/expander/ppx_let_expander.ml

@@ -0,0 +1,155 @@
+open Base
+open Ppxlib
+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
+
+let let_syntax ~modul : Longident.t =
+  match modul with
+  | None -> Lident "Let_syntax"
+  | Some id -> Ldot (id.txt, "Let_syntax")
+;;
+
+let open_on_rhs ~loc ~modul ~extension_name_s =
+  Located.mk ~loc (Longident.Ldot (let_syntax ~modul, "Open_on_rhs_" ^ extension_name_s))
+;;
+
+let eoperator ~loc ~modul func =
+  let lid : Longident.t = Ldot (let_syntax ~modul, 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_exn 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_exn 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 ~modul extension_name_s ~arg ~fn =
+  pexp_apply
+    ~loc
+    (eoperator ~loc ~modul extension_name_s)
+    [ Nolabel, arg; Labelled "f", fn ]
+;;
+
+(* Change by Georges: Always open for all extension names. *)
+let maybe_open ~to_open:module_to_open expr =
+  let loc = expr.pexp_loc in
+  pexp_open ~loc Override (module_to_open ~loc) expr
+;;
+
+let expand_let extension_name_s ~loc ~modul bindings body =
+  if List.is_empty bindings
+  then invalid_arg "expand_let: list of bindings must be non-empty";
+  (* Build expression [both E1 (both E2 (both ...))] *)
+  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 ~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 in
+      ppat_tuple ~loc [ p; acc ])
+  in
+  bind_apply
+    ~loc
+    ~modul
+    extension_name_s
+    ~arg:nested_boths
+    ~fn:(pexp_fun ~loc Nolabel None nested_patterns body)
+;;
+
+let expand_match extension_name_s ~loc ~modul expr cases =
+  bind_apply
+    ~loc
+    ~modul
+    extension_name_s
+    ~arg:(maybe_open ~to_open:(open_on_rhs ~modul ~extension_name_s) expr)
+    ~fn:(pexp_function ~loc cases)
+;;
+
+let expand_if extension_name ~loc expr then_ else_ =
+  expand_match
+    extension_name
+    ~loc
+    expr
+    [ case ~lhs:(pbool ~loc true) ~guard:None ~rhs:then_
+    ; case ~lhs:(pbool ~loc false) ~guard:None ~rhs:else_
+    ]
+;;
+
+let expand ~modul extension_name_s 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 ->
+          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 -> p
+            | _ -> vb.pvb_pat
+          in
+          { vb with
+            pvb_pat
+          ; pvb_expr =
+              maybe_open ~to_open:(open_on_rhs ~modul ~extension_name_s) vb.pvb_expr
+          })
+      in
+      expand_with_tmp_vars ~loc bindings expr ~f:(expand_let extension_name_s ~modul)
+    | Pexp_let (Recursive, _, _) ->
+      Location.raise_errorf
+        ~loc
+        "'let%%%s' may not be recursive"
+        extension_name_s
+    | Pexp_match (expr, cases) -> expand_match extension_name_s ~loc ~modul expr cases
+    | Pexp_ifthenelse (expr, then_, else_) ->
+      let else_ =
+        match else_ with
+        | Some else_ -> else_
+        | None ->
+          Location.raise_errorf
+            ~loc
+            "'if%%%s' must include an else branch"
+            extension_name_s
+      in
+      expand_if extension_name_s ~loc ~modul expr then_ else_
+    | _ ->
+      Location.raise_errorf
+        ~loc
+        "'%%%s' can only be used with 'let', 'match', and 'if'"
+        extension_name_s
+  in
+  { expansion with pexp_attributes = expr.pexp_attributes @ expansion.pexp_attributes }
+;;

src/ppx_let/expander/ppx_let_expander.mli

@@ -0,0 +1,3 @@
+open Ppxlib
+
+val expand : modul:longident loc option -> string -> expression -> expression

src/ppx_let/ppx_let.opam

@@ -0,0 +1,21 @@
+opam-version: "2.0"
+maintainer: "opensource@janestreet.com"
+authors: ["Jane Street Group, LLC <opensource@janestreet.com>"]
+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.04.2" & < "4.08.0"}
+  "base"
+  "dune"   {build & >= "1.5.1"}
+  "ppxlib" {>= "0.5.0"}
+]
+synopsis: "Monadic let-bindings"
+description: "
+Part of the Jane Street's PPX rewriters collection.
+"

src/ppx_let/src/dune

@@ -0,0 +1,2 @@
+(library (name ppx_let) (public_name ppx_let) (kind ppx_rewriter)
+ (libraries ppxlib ppx_let_expander) (preprocess no_preprocessing))

src/ppx_let/src/ppx_let.ml

@@ -0,0 +1,19 @@
+open Ppxlib
+
+let ext extension_name_s =
+  Extension.declare_with_path_arg
+    extension_name_s
+    Extension.Context.expression
+    Ast_pattern.(single_expr_payload __)
+    (fun ~loc:_ ~path:_ ~arg expr ->
+       Ppx_let_expander.expand extension_name_s ~modul:arg expr)
+;;
+
+let () =
+  Driver.register_transformation
+    "let"
+    ~extensions:(List.map ext [
+      "bind";
+      "xxx";
+    ])
+;;

src/ppx_let/src/ppx_let.mli

@@ -0,0 +1 @@
+

src/ppx_let/test/dune

@@ -0,0 +1 @@
+(executables (names test) (preprocess (pps ppx_let)))

src/ppx_let/test/test-locations.mlt

@@ -0,0 +1,27 @@
+(* -*- 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 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
+|}]

src/ppx_let/test/test.ml

@@ -0,0 +1,189 @@
+module Monad_example = struct
+  module Let_syntax = struct
+    let bind x ~f = f x
+    module Open_on_rhs_bind = struct
+      let return _ = "foo"
+    end
+  end
+
+  let _mf a =
+    let%bind xyz = return a in
+    (int_of_string xyz + 1)
+  ;;
+end
+
+(* TODO: re-enable some tests *)
+
+(*
+module Monad_example = struct
+  module X : sig
+    type 'a t
+
+    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
+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.Let_syntax x = a in
+    x + 1
+  ;;
+end
+*)