pax_global_header00006660000000000000000000000064146164733610014525gustar00rootroot0000000000000052 comment=3c5348bdcfba1fcd8471286939adfd03535cf67e ppx_enumerate-0.17.0/000077500000000000000000000000001461647336100144665ustar00rootroot00000000000000ppx_enumerate-0.17.0/.gitignore000066400000000000000000000000411461647336100164510ustar00rootroot00000000000000_build *.install *.merlin _opam ppx_enumerate-0.17.0/.ocamlformat000066400000000000000000000000231461647336100167660ustar00rootroot00000000000000profile=janestreet ppx_enumerate-0.17.0/CHANGES.md000066400000000000000000000002521461647336100160570ustar00rootroot00000000000000## v0.11 Depend on ppxlib instead of (now deprecated) ppx\_core, ppx\_driver, ppx\_metaquot and ppx\_type\_conv. ## 113.24.00 - Update to follow type\_conv evolution. ppx_enumerate-0.17.0/CONTRIBUTING.md000066400000000000000000000044101461647336100167160ustar00rootroot00000000000000This 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_enumerate-0.17.0/LICENSE.md000066400000000000000000000021461461647336100160750ustar00rootroot00000000000000The 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_enumerate-0.17.0/Makefile000066400000000000000000000004031461647336100161230ustar00rootroot00000000000000INSTALL_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_enumerate-0.17.0/README.md000066400000000000000000000057201461647336100157510ustar00rootroot00000000000000ppx_enumerate ============= Generate a list containing all values of a finite type. `ppx_enumerate` is a ppx rewriter which generates a definition for the list of all values of a type with (for a type which only has finitely many values). Basic Usage ----------- The basic usage is simply to add "[@@deriving enumerate]" after the type definition. For example: ```ocaml type t = | Foo | Bar of bool | Baz of [`A | `B of unit option] [@@deriving enumerate] ``` will produce a value `val all : t list`, whose value is equal to ```ocaml [ Foo; Bar true; Bar false; Baz `A; Baz (`B None); Baz (`B Some ()) ] ``` in some order (that is, there is no guarantee about the order of the list). Polymorphic types ----------------- In a similar fashion as sexplib, using '[@@deriving enumerate]' on polymorphic types produces a function for [all]. For example, ```ocaml type 'a t = | Foo | Bar of 'a option [@@deriving enumerate] ``` will produce a value `val all : 'a list -> 'a t list`, whose value is semantically equal to ```ocaml fun all_of_a -> Foo :: Bar None :: List.map all_of_a ~f:(fun x -> Bar (Some x)) ``` Types not named `t` ------------------- If the type is not named `t`, then the enumeration is called `all_of_` instead of `all`. Records and Tuples ------------------ Product types are supported as well as sum types. For example, ```ocaml type t = { foo : [`A | `B] ; bar : [`C | `D] } [@@deriving enumerate] ``` produces a `val all : t list` whose value is equal (up to order) to: ```ocaml [ { foo = `A; bar = `C }; { foo = `A; bar = `D }; { foo = `B; bar = `C }; { foo = `B; bar = `D }; ] ``` Tuples and variants with multiple arguments are similarly supported. Overriding the `all` value --------------------------- Just like with sexplib, it can sometimes be useful to provide a custom value of `all`. For example, you might define a type of bounded integers: ```ocaml module Small_int : sig type t = private int [@@deriving enumerate] val create_exn : int -> t end = struct type t = int let limit = 100 let create_exn i = if i < 0 || i >= limit then failwith "out of bounds"; i let all = List.init limit ~f:(fun i -> i) end ``` You could then use `Small_int.t` as normal with other types using `[@@deriving enumerate]`: ```ocaml type t = | Foo | Bar of Small_int.t option [@@deriving enumerate] ``` Using `all` without defining a type name ---------------------------------------- You don't have to define a type name to be able to create the list of values of a type. You do it for any type expression by using the `all` quotation. For example: ```ocaml [%all: bool * bool] ``` which will evaluate to: ```ocaml [ (true, true); (true, false); (false, false); (false, true) ] ``` Known issues ------------ Using `all` for polymorphic variants with duplicated constructors leads to duplicate values in the resulting lists: ```ocaml type t = [ `A ] [@@deriving enumerate] let () = assert ([%all: [ t | t ] ] = [ `A; `A ]) ``` ppx_enumerate-0.17.0/dune000066400000000000000000000000001461647336100153320ustar00rootroot00000000000000ppx_enumerate-0.17.0/dune-project000066400000000000000000000000211461647336100170010ustar00rootroot00000000000000(lang dune 3.11) ppx_enumerate-0.17.0/example/000077500000000000000000000000001461647336100161215ustar00rootroot00000000000000ppx_enumerate-0.17.0/example/dune000066400000000000000000000001561461647336100170010ustar00rootroot00000000000000(library (name enumerate_sample) (preprocess (pps ppx_jane))) (alias (name DEFAULT) (deps test.ml.pp)) ppx_enumerate-0.17.0/example/test.ml000066400000000000000000000155561461647336100174460ustar00rootroot00000000000000type t = | A | B [@@deriving enumerate] let%test _ = all = [ A; B ] type s = | C | D [@@deriving enumerate] let%test _ = all_of_s = [ C; D ] type u = | E | F of s [@@deriving enumerate] let%test _ = all_of_u = [ E; F C; F D ] module V = struct type v = | G of t | H of u [@@deriving enumerate] let%test _ = all_of_v = [ G A; G B; H E; H (F C); H (F D) ] end type w = I of V.v [@@deriving enumerate] let%test _ = all_of_w = [ I (V.G A); I (V.G B); I (V.H E); I (V.H (F C)); I (V.H (F D)) ] type x = [ `A | `B of t ] [@@deriving enumerate] let%test _ = all_of_x = [ `A; `B A; `B B ] (* variant with multiple arguments are not special *) type xx = [ `A of s * s ] [@@deriving enumerate] let%test _ = all_of_xx = [ `A (C, C); `A (D, C); `A (C, D); `A (D, D) ] type variant_inclusion = [ x | `C | x ] [@@deriving enumerate] let%test _ = all_of_variant_inclusion = (all_of_x :> variant_inclusion list) @ [ `C ] @ (all_of_x :> variant_inclusion list) ;; type y = J of t * s [@@deriving enumerate] let%test _ = all_of_y = [ J (A, C); J (B, C); J (A, D); J (B, D) ] type z = t * s [@@deriving enumerate] let%test _ = all_of_z = [ A, C; B, C; A, D; B, D ] type a = { foo : t ; bar : s } [@@deriving enumerate] let%test _ = all_of_a = [ { foo = A; bar = C } ; { foo = B; bar = C } ; { foo = A; bar = D } ; { foo = B; bar = D } ] ;; type b = K of t * t * s [@@deriving enumerate] let%test _ = all_of_b = [ K (A, A, C) ; K (B, A, C) ; K (A, B, C) ; K (B, B, C) ; K (A, A, D) ; K (B, A, D) ; K (A, B, D) ; K (B, B, D) ] ;; type c = t * t * s [@@deriving enumerate] let%test _ = all_of_c = [ A, A, C; B, A, C; A, B, C; B, B, C; A, A, D; B, A, D; A, B, D; B, B, D ] ;; type d = { a : t ; b : t ; c : s } [@@deriving enumerate] let%test _ = all_of_d = [ { a = A; b = A; c = C } ; { a = B; b = A; c = C } ; { a = A; b = B; c = C } ; { a = B; b = B; c = C } ; { a = A; b = A; c = D } ; { a = B; b = A; c = D } ; { a = A; b = B; c = D } ; { a = B; b = B; c = D } ] ;; type e = { foo : t } [@@deriving enumerate] module M = struct type nonrec e = { bar : e } [@@deriving enumerate] end let%test _ = M.all_of_e = [ { M.bar = { foo = A } }; { M.bar = { foo = B } } ] type f = L of [ `A | `B ] [@@deriving enumerate] let%test _ = all_of_f = [ L `A; L `B ] type g = f [@@deriving enumerate] let%test _ = all_of_g = all_of_f type h = | M | N type i = h = | M | N [@@deriving enumerate] let%test _ = all_of_i = [ M; N ] type 'a j = 'a [@@deriving enumerate] type k = i j [@@deriving enumerate] let%test _ = all_of_k = [ M; N ] let%test _ = [%all: [ `A of [ `B | `C ] | `D of [ `E of [ `F ] ] ]] = [ `A `B; `A `C; `D (`E `F) ] ;; type l = { baz : bool ; quux : unit } [@@deriving enumerate] let%test _ = all_of_l = [ { baz = false; quux = () }; { baz = true; quux = () } ] type o = [ `A ] option [@@deriving enumerate] let%test _ = all_of_o = [ None; Some `A ] (* Check that enumerations are only computed once *) type 'a count = 'a let number_of_computations = ref 0 let all_of_count all_of_a = incr number_of_computations; all_of_a ;; type p = { baz : bool count ; quux : unit count } [@@deriving enumerate] let%test _ = !number_of_computations = 2 let () = number_of_computations := 0 type p_nested = [ `A of [ `B of unit count * unit count ] * [ `C of unit count * unit count ] ] [@@deriving enumerate] let%test _ = !number_of_computations = 4 (* checking the lack of unused value warning *) type 'a phantom_variable = unit [@@deriving enumerate] type empty let%test _ = all_of_phantom_variable ([] : empty list) = [ () ] (* check that the coercions happen correctly when nested *) type q = [ x | `C ] option option [@@deriving enumerate] let%test _ = all_of_q = [ None ; Some None ; Some (Some `A) ; Some (Some (`B A)) ; Some (Some (`B B)) ; Some (Some `C) ] ;; type 'tt tt = [ `G of 'tt | x ] [@@deriving enumerate] let%test _ = all_of_tt [ () ] = [ `G (); `A; `B A; `B B ] type ir = | A of { foo : i } | B [@@deriving enumerate] let%test _ = all_of_ir = [ A { foo = M }; A { foo = N }; B ] (* Tricky case where the scoping of type variable prevents generalization. If the constraints looked like (... :> [ a tt | `F ]) (instead of the same thing with s/a/'a/) where there is a fun (type a) somewhere in scope it would work, but it is simpler to remove variables than replace them by local types consistently. *) type 'a nested_include_with_variable = [ 'a tt | `F ] option [@@deriving enumerate] type +'a variance = 'a [@@deriving enumerate] module Check_sigs = struct module type S1 = sig type t = | A | B [@@deriving_inline enumerate] include sig [@@@ocaml.warning "-32"] include Ppx_enumerate_lib.Enumerable.S with type t := t end [@@ocaml.doc "@inline"] [@@@end] end module type S2 = sig type t = | A | B val all : t list end let _ = fun (module M : S1) -> let module M : S2 = M in let module _ : S1 = M in () ;; end module Check_sigs_with_params_and_variance = struct module type S1 = sig type (+'a, 'b) t = | A of 'a | B of 'b [@@deriving enumerate] end module type S2 = sig type ('a, +'b) t = | A of 'a | B of 'b val all : 'a list -> 'b list -> ('a, 'b) t list end let _ = fun (module M : S1) -> let module M : S2 = M in let module _ : S1 = M in () ;; end (* if you remove the "~no_exhaustiveness_check" flag to enumerate, the compilation time will noticeably spike. *) type big_record = { field1 : t ; field2 : t ; field3 : t ; field4 : t ; field5 : s ; field6 : s ; field7 : t ; field8 : t ; field9 : t ; fielda : t ; fieldb : t ; fieldc : t ; fieldd : t ; fielde : t ; fieldf : t ; fieldg : u ; fieldh : t ; fieldi : t ; fieldj : t ; fieldk : t ; fieldl : t (* (* just keep adding fields to make things worse. *) fieldm: t; fieldn: t; fieldo: s; fieldp: t; fieldq: s; fieldr: s; fields: u; *) } [@@deriving enumerate ~no_exhaustiveness_check] module Wildcard : sig type 'a transparent = | A | B of bool [@@deriving_inline enumerate] include sig [@@@ocaml.warning "-32"] val all_of_transparent : 'a list -> 'a transparent list end [@@ocaml.doc "@inline"] [@@@end] type 'a opaque [@@deriving_inline enumerate] include sig [@@@ocaml.warning "-32"] val all_of_opaque : 'a list -> 'a opaque list end [@@ocaml.doc "@inline"] [@@@end] end = struct type _ transparent = | A | B of bool [@@deriving enumerate] let%test _ = all_of_transparent all_of_x = [ A; B false; B true ] type 'a opaque = 'a option [@@deriving enumerate] let%test _ = all_of_opaque all_of_x = [ None; Some `A; Some (`B A); Some (`B B) ] end ppx_enumerate-0.17.0/ppx_enumerate.opam000066400000000000000000000014541461647336100202240ustar00rootroot00000000000000opam-version: "2.0" version: "v0.17.0" maintainer: "Jane Street developers" authors: ["Jane Street Group, LLC"] homepage: "https://github.com/janestreet/ppx_enumerate" bug-reports: "https://github.com/janestreet/ppx_enumerate/issues" dev-repo: "git+https://github.com/janestreet/ppx_enumerate.git" doc: "https://ocaml.janestreet.com/ocaml-core/latest/doc/ppx_enumerate/index.html" license: "MIT" build: [ ["dune" "build" "-p" name "-j" jobs] ] depends: [ "ocaml" {>= "5.1.0"} "base" {>= "v0.17" & < "v0.18"} "ppxlib_jane" {>= "v0.17" & < "v0.18"} "dune" {>= "3.11.0"} "ppxlib" {>= "0.28.0"} ] available: arch != "arm32" & arch != "x86_32" synopsis: "Generate a list containing all values of a finite type" description: " Part of the Jane Street's PPX rewriters collection. " ppx_enumerate-0.17.0/runtime-lib/000077500000000000000000000000001461647336100167155ustar00rootroot00000000000000ppx_enumerate-0.17.0/runtime-lib/dune000066400000000000000000000001541461647336100175730ustar00rootroot00000000000000(library (name ppx_enumerate_lib) (public_name ppx_enumerate.runtime-lib) (preprocess no_preprocessing)) ppx_enumerate-0.17.0/runtime-lib/ppx_enumerate_lib.ml000066400000000000000000000006411461647336100227520ustar00rootroot00000000000000module List = List module Enumerable = struct module type S = sig type t val all : t list end module type S1 = sig type 'a t val all : 'a list -> 'a t list end module type S2 = sig type ('a, 'b) t val all : 'a list -> 'b list -> ('a, 'b) t list end module type S3 = sig type ('a, 'b, 'c) t val all : 'a list -> 'b list -> 'c list -> ('a, 'b, 'c) t list end end ppx_enumerate-0.17.0/src/000077500000000000000000000000001461647336100152555ustar00rootroot00000000000000ppx_enumerate-0.17.0/src/dune000066400000000000000000000003441461647336100161340ustar00rootroot00000000000000(library (name ppx_enumerate) (public_name ppx_enumerate) (kind ppx_deriver) (libraries base ppxlib ppxlib_jane compiler-libs.common) (ppx_runtime_libraries ppx_enumerate.runtime-lib) (preprocess (pps ppxlib.metaquot))) ppx_enumerate-0.17.0/src/ppx_enumerate.ml000066400000000000000000000257251461647336100204760ustar00rootroot00000000000000open Base open Ppxlib open Ast_builder.Default let name_of_type_name = function | "t" -> "all" | type_name -> "all_of_" ^ type_name ;; let name_of_type_variable str = "_" ^ name_of_type_name str (* Utility functions *) let enumeration_type_of_td td = let init = let tp = core_type_of_type_declaration td in let loc = tp.ptyp_loc in [%type: [%t tp] list] in List.fold_right td.ptype_params ~init ~f:(fun (tp, _variance) acc -> let loc = tp.ptyp_loc in [%type: [%t tp] list -> [%t acc]]) ;; let sig_of_td td = let td = name_type_params_in_td td in let enumeration_type = enumeration_type_of_td td in let name = name_of_type_name td.ptype_name.txt in let loc = td.ptype_loc in psig_value ~loc (value_description ~loc ~name:(Located.mk ~loc name) ~type_:enumeration_type ~prim:[]) ;; let sig_of_tds ~loc ~path:_ (_rec_flag, tds) = let sg_name = "Ppx_enumerate_lib.Enumerable.S" in match mk_named_sig tds ~loc ~sg_name ~handle_polymorphic_variant:true with | Some include_infos -> [ psig_include ~loc include_infos ] | None -> List.map tds ~f:sig_of_td ;; let gen_symbol = gen_symbol ~prefix:"enumerate" let tuple loc exprs = assert (List.length exprs >= 2); pexp_tuple ~loc exprs ;; let patt_tuple loc pats = assert (List.length pats >= 2); ppat_tuple ~loc pats ;; let apply e el = eapply ~loc:e.pexp_loc e el let labeled_tuple loc ltps exprs = let ltuple = List.map2_exn ~f:(fun (lbl, _) exp -> lbl, exp) ltps exprs in Ppxlib_jane.Jane_syntax.Expression.expr_of ~loc ~attrs:[] (Jexp_tuple ltuple) ;; let replace_variables_by_underscores = let map = object inherit Ast_traverse.map as super method! core_type_desc ty = match super#core_type_desc ty with | Ptyp_var _ -> Ptyp_any | ty -> ty end in map#core_type ;; let list_map loc l ~f = let element = gen_symbol () in let applied = f (evar ~loc element) in [%expr let rec map l acc = match l with | [] -> Ppx_enumerate_lib.List.rev acc | [%p pvar ~loc element] :: l -> map l ([%e applied] :: acc) in map [%e l] []] ;; (* [cartesian_product_map l's f loc] takes a list of expressions of type list, and returns code generating the Cartesian product of those lists, with [f] applied to each tuple. *) let cartesian_product_map ~exhaust_check l's ~f loc = match l's with | [] -> Location.raise_errorf ~loc "cartesian_product_map passed list of zero length" | [ l ] -> list_map loc l ~f:(fun x -> f [ x ]) | _ -> let lid x = evar ~loc x in let patt_lid x = pvar ~loc x in let alias_vars = List.map l's ~f:(fun _ -> gen_symbol ()) in let init = let len = List.length l's in let hd_vars = List.map l's ~f:(fun _ -> gen_symbol ()) in let args_vars = List.map l's ~f:(fun _ -> gen_symbol ()) in let tl_var = gen_symbol () in let base_case = let patts = List.rev ([%pat? []] :: List.init (len - 1) ~f:(fun _ -> [%pat? _])) in case ~guard:None ~lhs:(patt_tuple loc patts) ~rhs:[%expr Ppx_enumerate_lib.List.rev acc] in let apply_case = let patts = List.mapi hd_vars ~f:(fun i x -> [%pat? [%p pvar ~loc x] :: [%p if i = 0 then patt_lid tl_var else ppat_any ~loc]]) in case ~guard:None ~lhs:(patt_tuple loc patts) ~rhs: (apply [%expr loop ([%e f (List.map hd_vars ~f:lid)] :: acc)] (evar ~loc tl_var :: List.map (List.tl_exn args_vars) ~f:lid)) in let decrement_cases = List.init (len - 1) ~f:(fun i -> let patts = List.init i ~f:(fun _ -> ppat_any ~loc) @ [ [%pat? []]; [%pat? _ :: [%p pvar ~loc tl_var]] ] @ List.init (len - i - 2) ~f:(fun _ -> ppat_any ~loc) in case ~guard:None ~lhs:(patt_tuple loc patts) ~rhs: (apply [%expr loop acc] (List.map ~f:lid (List.take alias_vars (i + 1)) @ (evar ~loc tl_var :: List.map ~f:lid (List.drop args_vars (i + 2)))))) in let decrement_cases = if exhaust_check then decrement_cases else decrement_cases @ [ case ~guard:None ~lhs:(ppat_any ~loc) ~rhs:[%expr assert false] ] in let match_exp = pexp_match ~loc (tuple loc (List.map args_vars ~f:lid)) (base_case :: apply_case :: decrement_cases) in let match_exp = if exhaust_check then match_exp else ( let loc = Location.none in { match_exp with pexp_attributes = [ attribute ~loc ~name:Location.{ txt = "ocaml.warning"; loc } ~payload:(PStr [ pstr_eval ~loc (estring ~loc "-11") [] ]) ] }) in [%expr let rec loop acc = [%e eabstract ~loc (List.map args_vars ~f:patt_lid) match_exp] in [%e apply [%expr loop []] (List.map ~f:lid alias_vars)]] in Stdlib.ListLabels.fold_right2 alias_vars l's ~init ~f:(fun alias_var input_list acc -> [%expr let [%p pvar ~loc alias_var] = [%e input_list] in [%e acc]]) ;; (* Here we do two things: simplify append on static lists, to make the generated code more readable and rewrite (List.append (List.append a b) c) as (List.append a (List.append b c)), to avoid a quadratic behaviour with long nesting to the left. *) let rec list_append loc l1 l2 = match l2 with | [%expr []] -> l1 | _ -> (match l1 with | [%expr []] -> l2 | [%expr [%e? hd] :: [%e? tl]] -> [%expr [%e hd] :: [%e list_append loc tl l2]] | [%expr Ppx_enumerate_lib.List.append [%e? ll] [%e? lr]] -> list_append loc ll (list_append loc lr l2) | _ -> [%expr Ppx_enumerate_lib.List.append [%e l1] [%e l2]]) ;; let rec enum ~exhaust_check ~main_type ty = let loc = { ty.ptyp_loc with loc_ghost = true } in match Ppxlib_jane.Jane_syntax.Core_type.of_ast ty with | Some (Jtyp_tuple ltps, _attrs) -> product ~exhaust_check loc (List.map ~f:snd ltps) (fun exprs -> labeled_tuple loc ltps exprs) | Some (Jtyp_layout _, _) | None -> (match ty.ptyp_desc with | Ptyp_constr ({ txt = Lident "bool"; _ }, []) -> [%expr [ false; true ]] | Ptyp_constr ({ txt = Lident "unit"; _ }, []) -> [%expr [ () ]] | Ptyp_constr ({ txt = Lident "option"; _ }, [ tp ]) -> [%expr None :: [%e list_map loc (enum ~exhaust_check ~main_type:tp tp) ~f:(fun e -> [%expr Some [%e e]])]] | Ptyp_constr (id, args) -> type_constr_conv ~loc id ~f:name_of_type_name (List.map args ~f:(fun t -> enum ~exhaust_check t ~main_type:t)) | Ptyp_tuple tps -> product ~exhaust_check loc tps (fun exprs -> tuple loc exprs) | Ptyp_variant (row_fields, Closed, None) -> List.fold_left row_fields ~init:[%expr []] ~f:(fun acc rf -> list_append loc acc (variant_case ~exhaust_check loc rf ~main_type)) | Ptyp_var id -> evar ~loc (name_of_type_variable id) | _ -> Location.raise_errorf ~loc "ppx_enumerate: unsupported type") and variant_case ~exhaust_check loc row_field ~main_type = match row_field.prf_desc with | Rtag ({ txt = cnstr; _ }, true, _) | Rtag ({ txt = cnstr; _ }, _, []) -> [%expr [ [%e pexp_variant ~loc cnstr None] ]] | Rtag ({ txt = cnstr; _ }, false, tp :: _) -> list_map loc (enum ~exhaust_check tp ~main_type:tp) ~f:(fun e -> pexp_variant ~loc cnstr (Some e)) | Rinherit ty -> let e = enum ~exhaust_check ~main_type ty in [%expr ([%e e] :> [%t replace_variables_by_underscores main_type] list)] and constructor_case ~exhaust_check loc cd = match cd.pcd_args with | Pcstr_tuple [] -> [%expr [ [%e econstruct cd None] ]] | Pcstr_tuple tps -> product ~exhaust_check loc tps (fun x -> econstruct cd (Some (pexp_tuple ~loc x))) | Pcstr_record lds -> enum_of_lab_decs ~exhaust_check ~loc lds ~k:(fun x -> econstruct cd (Some x)) and enum_of_lab_decs ~exhaust_check ~loc lds ~k = let field_names, types = List.unzip (List.map lds ~f:(fun ld -> ld.pld_name, ld.pld_type)) in product ~exhaust_check loc types (function l -> let fields = List.map2_exn field_names l ~f:(fun field_name x -> Located.map lident field_name, x) in k (pexp_record ~loc fields None)) and product ~exhaust_check loc tps f = let all = List.map tps ~f:(fun tp -> enum ~exhaust_check ~main_type:tp tp) in cartesian_product_map ~exhaust_check all loc ~f ;; let quantify loc tps typ = match tps with | [] -> typ | _ -> ptyp_poly ~loc (List.map tps ~f:(fun x -> get_type_param_name x)) typ ;; let enum_of_td ~exhaust_check td = let td = name_type_params_in_td td in let loc = td.ptype_loc in let all = let main_type = ptyp_constr ~loc (Located.map lident td.ptype_name) (List.map td.ptype_params ~f:(fun _ -> ptyp_any ~loc)) in match td.ptype_kind with | Ptype_variant cds -> (* Process [cd] elements in same order as camlp4 to avoid code-gen diffs caused by different order of [gen_symbol] calls *) List.fold_left cds ~init:[%expr []] ~f:(fun acc cd -> list_append loc acc (constructor_case ~exhaust_check loc cd)) | Ptype_record lds -> enum_of_lab_decs ~exhaust_check ~loc lds ~k:(fun x -> x) | Ptype_open -> Location.raise_errorf ~loc "ppx_enumerate: open types not supported" | Ptype_abstract -> (match td.ptype_manifest with | None -> [%expr []] | Some tp -> enum ~exhaust_check tp ~main_type) in let name = name_of_type_name td.ptype_name.txt in let args = List.map td.ptype_params ~f:(fun ((tp, _) as x) -> let name = name_of_type_variable (get_type_param_name x).txt in let loc = tp.ptyp_loc in pvar ~loc name) in let enumeration_type = let typ = enumeration_type_of_td td in quantify loc td.ptype_params typ in let body = eabstract ~loc args all in let zero_args = List.length args = 0 in if zero_args (* constrain body rather than pattern *) then [%str let [%p pvar ~loc name] = ([%e body] : [%t enumeration_type])] else [%str let ([%p pvar ~loc name] : [%t enumeration_type]) = [%e body]] ;; let enumerate = let str_args = Deriving.Args.(empty +> flag "no_exhaustiveness_check") in Deriving.add "enumerate" ~str_type_decl: (Deriving.Generator.make str_args (fun ~loc ~path:_ (_rec, tds) no_exhaustiveness_check -> match tds with | [ td ] -> enum_of_td ~exhaust_check:(not no_exhaustiveness_check) td | _ -> Location.raise_errorf ~loc "only one type at a time is support by ppx_enumerate")) ~sig_type_decl:(Deriving.Generator.make Deriving.Args.empty sig_of_tds) ;; let () = Deriving.add "all" ~extension:(fun ~loc:_ ~path:_ ty -> enum ~exhaust_check:true ty ~main_type:ty) |> Deriving.ignore ;; ppx_enumerate-0.17.0/src/ppx_enumerate.mli000066400000000000000000000000501461647336100206270ustar00rootroot00000000000000open Ppxlib val enumerate : Deriving.t