From de8312ead02b59379c718e08e0796dc31613225b Mon Sep 17 00:00:00 2001 From: Xavier Clerc Date: Wed, 16 Jan 2019 10:57:51 +0000 Subject: [PATCH] v0.12-preview.120.18+252 --- LICENSE.md | 2 +- Makefile | 9 ++-- dune | 0 dune-project | 1 + expander/dune | 2 + expander/jbuild | 7 --- expander/ppx_let_expander.ml | 79 ++++++++++++++++++++++------------ expander/ppx_let_expander.mli | 8 +--- jbuild | 2 - ppx_let.opam | 16 +++---- src/dune | 2 + src/jbuild | 8 ---- src/ppx_let.ml | 10 ++--- src/ppx_let.mli | 1 + test/dune | 1 + test/jbuild | 6 --- test/test-locations.mlt | 17 ++++++-- test/test.ml | 81 +++++++++++++++++++++++------------ 18 files changed, 143 insertions(+), 109 deletions(-) create mode 100644 dune create mode 100644 dune-project create mode 100644 expander/dune delete mode 100644 expander/jbuild delete mode 100644 jbuild create mode 100644 src/dune delete mode 100644 src/jbuild create mode 100644 test/dune delete mode 100644 test/jbuild diff --git a/LICENSE.md b/LICENSE.md index 3a1a8084a..54ac5432f 100644 --- a/LICENSE.md +++ b/LICENSE.md @@ -1,6 +1,6 @@ The MIT License -Copyright (c) 2015--2018 Jane Street Group, LLC +Copyright (c) 2015--2019 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 diff --git a/Makefile b/Makefile index 2773ca916..1965878e4 100644 --- a/Makefile +++ b/Makefile @@ -1,18 +1,17 @@ INSTALL_ARGS := $(if $(PREFIX),--prefix $(PREFIX),) -# Default rule default: - jbuilder build @install + dune build install: - jbuilder install $(INSTALL_ARGS) + dune install $(INSTALL_ARGS) uninstall: - jbuilder uninstall $(INSTALL_ARGS) + dune uninstall $(INSTALL_ARGS) reinstall: uninstall install clean: - rm -rf _build + dune clean .PHONY: default install uninstall reinstall clean diff --git a/dune b/dune new file mode 100644 index 000000000..e69de29bb diff --git a/dune-project b/dune-project new file mode 100644 index 000000000..598db5612 --- /dev/null +++ b/dune-project @@ -0,0 +1 @@ +(lang dune 1.5) \ No newline at end of file diff --git a/expander/dune b/expander/dune new file mode 100644 index 000000000..2ced86cfa --- /dev/null +++ b/expander/dune @@ -0,0 +1,2 @@ +(library (name ppx_let_expander) (public_name ppx_let.expander) + (libraries base ppxlib) (preprocess no_preprocessing)) \ No newline at end of file diff --git a/expander/jbuild b/expander/jbuild deleted file mode 100644 index f1666c496..000000000 --- a/expander/jbuild +++ /dev/null @@ -1,7 +0,0 @@ -(library ( - (name ppx_let_expander) - (public_name ppx_let.expander) - (libraries (base ppxlib)) - (preprocess no_preprocessing))) - -(jbuild_version 1) diff --git a/expander/ppx_let_expander.ml b/expander/ppx_let_expander.ml index a48740a2b..c6eabf695 100644 --- a/expander/ppx_let_expander.ml +++ b/expander/ppx_let_expander.ml @@ -9,6 +9,7 @@ module List = struct match l with | [] -> invalid_arg "List.reduce_exn" | hd :: tl -> fold_left tl ~init:hd ~f + ;; end module Extension_name = struct @@ -20,22 +21,26 @@ module Extension_name = struct let operator_name = function | Bind | Bind_open -> "bind" - | Map | Map_open -> "map" + | Map | Map_open -> "map" + ;; - let to_string = function - | Bind -> "bind" + let to_string = function + | Bind -> "bind" | Bind_open -> "bind_open" - | Map -> "map" - | Map_open -> "map_open" + | Map -> "map" + | Map_open -> "map_open" + ;; end let let_syntax ~modul : Longident.t = match modul with | None -> Lident "Let_syntax" | Some id -> Ldot (id.txt, "Let_syntax") +;; let open_on_rhs ~loc ~modul = - Located.mk ~loc (Longident.Ldot (let_syntax ~modul, "Open_on_rhs" )) + 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 @@ -44,30 +49,33 @@ let eoperator ~loc ~modul func = let expand_with_tmp_vars ~loc bindings expr ~f = match bindings with - | [_] -> f ~loc bindings expr + | [ _ ] -> f ~loc bindings expr | _ -> - let tmp_vars = List.map bindings ~f:(fun _ -> gen_symbol ~prefix:"__let_syntax" ()) in + 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 -> + 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 ~arg ~fn = - pexp_apply ~loc + pexp_apply + ~loc (eoperator ~loc ~modul (Extension_name.operator_name extension_name)) - [(Nolabel, arg); (Labelled "f", fn)] + [ Nolabel, arg; Labelled "f", fn ] ;; let maybe_open extension_name ~to_open:module_to_open expr = let loc = expr.pexp_loc in match (extension_name : Extension_name.t) with - | Bind | Map -> expr + | Bind | Map -> expr | Bind_open | Map_open -> pexp_open ~loc Override (module_to_open ~loc) expr ;; @@ -79,30 +87,41 @@ let expand_let extension_name ~loc ~modul bindings body = 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]) + 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]) + ppat_tuple ~loc [ p; acc ]) in - bind_apply ~loc ~modul extension_name ~arg:nested_boths + bind_apply + ~loc + ~modul + extension_name + ~arg:nested_boths ~fn:(pexp_fun ~loc Nolabel None nested_patterns body) ;; let expand_match extension_name ~loc ~modul expr cases = - bind_apply ~loc ~modul extension_name + bind_apply + ~loc + ~modul + extension_name ~arg:(maybe_open extension_name ~to_open:(open_on_rhs ~modul) 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_ + 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 expr = let loc = expr.pexp_loc in @@ -118,32 +137,38 @@ let expand ~modul extension_name expr = 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 + | ( 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 extension_name ~to_open:(open_on_rhs ~modul) vb.pvb_expr; + pvb_pat + ; pvb_expr = + maybe_open extension_name ~to_open:(open_on_rhs ~modul) vb.pvb_expr }) in expand_with_tmp_vars ~loc bindings expr ~f:(expand_let extension_name ~modul) | Pexp_let (Recursive, _, _) -> - Location.raise_errorf ~loc "'let%%%s' may not be recursive" + Location.raise_errorf + ~loc + "'let%%%s' may not be recursive" (Extension_name.to_string extension_name) - | Pexp_match (expr, cases) -> - expand_match extension_name ~loc ~modul expr cases + | Pexp_match (expr, cases) -> expand_match extension_name ~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" + Location.raise_errorf + ~loc + "'if%%%s' must include an else branch" (Extension_name.to_string extension_name) in expand_if extension_name ~loc ~modul expr then_ else_ | _ -> - Location.raise_errorf ~loc + Location.raise_errorf + ~loc "'%%%s' can only be used with 'let', 'match', and 'if'" (Extension_name.to_string extension_name) in diff --git a/expander/ppx_let_expander.mli b/expander/ppx_let_expander.mli index f000b2b24..71333f8a8 100644 --- a/expander/ppx_let_expander.mli +++ b/expander/ppx_let_expander.mli @@ -6,12 +6,8 @@ module Extension_name : sig | Bind_open | Map | Map_open + val to_string : t -> string end -val expand - : modul:longident loc option - -> Extension_name.t - -> expression - -> expression - +val expand : modul:longident loc option -> Extension_name.t -> expression -> expression diff --git a/jbuild b/jbuild deleted file mode 100644 index ea8e23449..000000000 --- a/jbuild +++ /dev/null @@ -1,2 +0,0 @@ - -(jbuild_version 1) diff --git a/ppx_let.opam b/ppx_let.opam index 909b792b8..331f34e78 100644 --- a/ppx_let.opam +++ b/ppx_let.opam @@ -1,21 +1,21 @@ -opam-version: "1.2" +opam-version: "2.0" 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: "git+https://github.com/janestreet/ppx_let.git" +doc: "https://ocaml.janestreet.com/ocaml-core/latest/doc/ppx_let/index.html" license: "MIT" build: [ - ["jbuilder" "build" "-p" name "-j" jobs] + ["dune" "build" "-p" name "-j" jobs] ] depends: [ + "ocaml" {>= "4.04.2"} "base" - "jbuilder" {build & >= "1.0+beta18.1"} - "ppxlib" {>= "0.1.0"} + "dune" {build & >= "1.5.1"} + "ppxlib" {>= "0.4.0"} ] -available: [ ocaml-version >= "4.04.2" ] -descr: " -Monadic let-bindings - +synopsis: "Monadic let-bindings" +description: " Part of the Jane Street's PPX rewriters collection. " diff --git a/src/dune b/src/dune new file mode 100644 index 000000000..ffbf7292a --- /dev/null +++ b/src/dune @@ -0,0 +1,2 @@ +(library (name ppx_let) (public_name ppx_let) (kind ppx_rewriter) + (libraries base ppxlib ppx_let_expander) (preprocess no_preprocessing)) \ No newline at end of file diff --git a/src/jbuild b/src/jbuild deleted file mode 100644 index 3c8e6e818..000000000 --- a/src/jbuild +++ /dev/null @@ -1,8 +0,0 @@ -(library ( - (name ppx_let) - (public_name ppx_let) - (kind ppx_rewriter) - (libraries (base ppxlib ppx_let_expander)) - (preprocess no_preprocessing))) - -(jbuild_version 1) diff --git a/src/ppx_let.ml b/src/ppx_let.ml index 5b821786a..3f9985502 100644 --- a/src/ppx_let.ml +++ b/src/ppx_let.ml @@ -10,11 +10,7 @@ let ext extension_name = ;; let () = - Driver.register_transformation "let" - ~extensions:[ - ext Bind; - ext Bind_open; - ext Map; - ext Map_open; - ] + 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 index e69de29bb..8b1378917 100644 --- a/src/ppx_let.mli +++ b/src/ppx_let.mli @@ -0,0 +1 @@ + diff --git a/test/dune b/test/dune new file mode 100644 index 000000000..c53c7966b --- /dev/null +++ b/test/dune @@ -0,0 +1 @@ +(executables (names test) (preprocess (pps ppx_let))) \ No newline at end of file diff --git a/test/jbuild b/test/jbuild deleted file mode 100644 index 6bf70a34f..000000000 --- a/test/jbuild +++ /dev/null @@ -1,6 +0,0 @@ -(executables ( - (names (test)) - (preprocess (pps (ppx_let ppxlib.runner))))) - - -(jbuild_version 1) diff --git a/test/test-locations.mlt b/test/test-locations.mlt index 765b8b345..47a5009e1 100644 --- a/test/test-locations.mlt +++ b/test/test-locations.mlt @@ -2,17 +2,26 @@ 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) + 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 45-49: +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 |}] diff --git a/test/test.ml b/test/test.ml index 0f035fa18..ac502de51 100644 --- a/test/test.ml +++ b/test/test.ml @@ -1,31 +1,41 @@ 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 + 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) + 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 + let bind = bind + let map = map + let both = both + + module Open_on_rhs = struct + let return = return + end end end end @@ -35,50 +45,55 @@ module Monad_example = struct 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 + 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 + 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 _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 + 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 @@ -87,15 +102,19 @@ module Applicative_example = struct end end = struct type 'a t = 'a + let return x = x let map x ~f = f x - let both x y = (x, y) + 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 + let map = map + let both = both + module Open_on_rhs = struct let flag = 66 let anon = 77 @@ -121,10 +140,14 @@ module Applicative_example = struct 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 + let%map x = a + and y = b + and u, v = c in x + y + (u * v) + ;; (* {[ let _ah a : _ X.t = @@ -137,10 +160,12 @@ module Applicative_example = struct 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