pax_global_header00006660000000000000000000000064144217506710014521gustar00rootroot0000000000000052 comment=d42ec826a994d80ba1aee3c7db018286419168c2 ppx_variants_conv-0.16.0/000077500000000000000000000000001442175067100153505ustar00rootroot00000000000000ppx_variants_conv-0.16.0/.gitignore000066400000000000000000000000411442175067100173330ustar00rootroot00000000000000_build *.install *.merlin _opam ppx_variants_conv-0.16.0/CHANGES.md000066400000000000000000000021061442175067100167410ustar00rootroot00000000000000## git version - Make sure we don't generate functions whose name matches a keyword, e.g. when doing `type t = If | Then | Else [@@deriving variants]`. We suffix such function names with an underscore. ## v0.11 - Depend on ppxlib instead of (now deprecated) ppx\_core, ppx\_driver and ppx\_metaquot. ## 113.43.00 - Implemented `Variants.to_rank`. Somewhat surprisingly, the preprocessor didn't reject variant inclusion despite what the documentation says, but instead would consider that they use one rank (??). Also the generated signature didn't match the generated code in that case. Removed completely the support for polymorphic variant inclusion. ## 113.24.00 - The `iter` function generated by ppx\_variants\_conv and ppx\_fields\_conv allowed one to give function which returned values of arbitrary types as iter function. This feature constraint these functions to return unit. N.B. the signature generated by the use of `@@deriving variants` (resp. fields) in interface already constrained the type to unit. - Update to follow `Type_conv` evolution. ppx_variants_conv-0.16.0/CONTRIBUTING.md000066400000000000000000000044101442175067100176000ustar00rootroot00000000000000This 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_variants_conv-0.16.0/LICENSE.md000066400000000000000000000021461442175067100167570ustar00rootroot00000000000000The MIT License Copyright (c) 2015--2023 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_variants_conv-0.16.0/Makefile000066400000000000000000000004031442175067100170050ustar00rootroot00000000000000INSTALL_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_variants_conv-0.16.0/README.md000066400000000000000000000076601442175067100166400ustar00rootroot00000000000000ppx_variants_conv ================= Generation of accessor and iteration functions for ocaml variant types. `ppx_variants_conv` is a ppx rewriter that can be used to define first class values representing variant constructors, some helper functions to identify or match on individual constructors, and additional routines to fold, iterate and map over all constructors of a variant type. It provides corresponding functionality for variant types as `ppx_fields_conv` provides for record types. # Basic use of `[@@deriving variants]` and variantslib This code: ```ocaml type 'a t = | A of 'a | B of char | C | D of int * int [@@deriving variants] ``` generates the following values: ```ocaml (** first-class constructor functions *) val a : 'a -> 'a t val b : char -> 'a t val c : 'a t val d : int -> int -> 'a t val is_a : _ t -> bool val is_b : _ t -> bool val is_c : _ t -> bool val is_d : _ t -> bool val a_val : 'a t -> 'a option val b_val : _ t -> char option val c_val : _ t -> unit option val d_val : _ t -> (int * int) option (** higher order variants and functions over all variants *) module Variants : sig val a : ('a -> 'a t) Variant.t val b : (char -> 'a t) Variant.t val c : ('a t) Variant.t val d : (int -> int -> 'a t) Variant.t val fold : init: 'acc1 -> a:('acc1 -> ('a -> 'a t) Variant.t -> 'acc2) -> b:('acc2 -> (char -> 'a t) Variant.t -> 'acc3) -> c:('acc3 -> ('a t) Variant.t -> 'acc4) -> d:('acc4 -> (int -> int -> 'a t) Variant.t -> 'acc5) -> 'acc5 val iter : a: (('a -> 'a t) Variant.t -> unit) -> b: ((char -> 'a t) Variant.t -> unit) -> c: (('a t) Variant.t -> unit) -> d: ((int -> int -> 'a t) Variant.t -> unit) -> unit val map : 'a t -> a: (('a -> 'a t) Variant.t -> 'a -> 'r) -> b: ((char -> 'a t) Variant.t -> char -> 'r) -> c: (('a t) Variant.t -> 'r) -> d: ((int -> int -> 'a t) Variant.t -> int -> int -> 'a t -> 'r) -> 'r val make_matcher : a:(('b -> 'b t) Variant.t -> 'acc1 -> ('a -> 'r) * 'acc2) -> b:((char -> _ t) Variant.t -> 'acc2 -> (char -> 'r) * 'acc3) -> c:(_ t Variant.t -> 'acc3 -> (unit -> 'r) * 'acc4) -> d:((int -> int -> _ t) Variant.t -> 'acc4 -> (int -> int -> 'r) * 'acc5) -> 'acc1 -> ('a t -> 'r) * 'acc5 val to_rank : _ t -> int val to_name : _ t -> string (** name * number of arguments, ie [("A", 1); ("B", 1); ("C", 0); ("D", 2)]. *) val descriptions : (string * int) list end ``` Variant.t is defined in Variantslib as follows: ```ocaml module Variant = struct type 'constructor t = { name : string; (* the position of the constructor in the type definition, starting from 0 *) rank : int; constructor : 'constructor } end ``` The fold, iter, and map functions are useful in dealing with the totality of variants. For example, to get a list of all variants when all the constructors are nullary: ```ocaml type t = | First | Second | Third [@@deriving variants] ``` ```ocaml let all = let add acc var = var.Variantslib.Variant.constructor :: acc in Variants.fold ~init:[] ~first:add ~second:add ~third:add ``` Just like with `[@@deriving fields]`, if the type changes, the compiler will complain until this definition is updated as well. # Polymorphic Variants `ppx_variants_conv` works similarly on simple polymorphic variants (without row variables and without inclusion). # GADTs `ppx_variants_conv` can be used with GADTs but with some limitations. The preprocessor will not generate `*_val` functions for the GADTs constructors, because it's not clear which type such functions should have. This may be revisited in the future. As a consequence neither `Variants.map` nor `Variants.make_matcher` functions will be generated either. ppx_variants_conv-0.16.0/dune000066400000000000000000000000001442175067100162140ustar00rootroot00000000000000ppx_variants_conv-0.16.0/dune-project000066400000000000000000000000201442175067100176620ustar00rootroot00000000000000(lang dune 1.10)ppx_variants_conv-0.16.0/example/000077500000000000000000000000001442175067100170035ustar00rootroot00000000000000ppx_variants_conv-0.16.0/example/dune000066400000000000000000000002011442175067100176520ustar00rootroot00000000000000(executables (names test) (libraries) (preprocess (pps ppx_variants_conv))) (alias (name DEFAULT) (deps test.ml.pp test.mli.pp))ppx_variants_conv-0.16.0/example/test.ml000066400000000000000000000005161442175067100203160ustar00rootroot00000000000000module Normal = struct type t = | Foo of int | Bar [@@deriving variants] end module Normal_inline_record = struct type t = | Foo of { a : int ; b : string } | Bar [@@deriving variants] end module Poly = struct type t = [ `Foo of int | `Bar ] [@@deriving variants] end ppx_variants_conv-0.16.0/example/test.mli000066400000000000000000000005051442175067100204650ustar00rootroot00000000000000module Normal : sig type t = | Foo of int | Bar [@@deriving variants] end module Normal_inline_record : sig type t = | Foo of { a : int ; b : string } | Bar [@@deriving variants] end module Poly : sig type t = [ `Foo of int | `Bar ] [@@deriving variants] end ppx_variants_conv-0.16.0/ppx_variants_conv.opam000066400000000000000000000015141442175067100217720ustar00rootroot00000000000000opam-version: "2.0" version: "v0.16.0" maintainer: "Jane Street developers" authors: ["Jane Street Group, LLC"] homepage: "https://github.com/janestreet/ppx_variants_conv" bug-reports: "https://github.com/janestreet/ppx_variants_conv/issues" dev-repo: "git+https://github.com/janestreet/ppx_variants_conv.git" doc: "https://ocaml.janestreet.com/ocaml-core/latest/doc/ppx_variants_conv/index.html" license: "MIT" build: [ ["dune" "build" "-p" name "-j" jobs] ] depends: [ "ocaml" {>= "4.14.0"} "base" {>= "v0.16" & < "v0.17"} "variantslib" {>= "v0.16" & < "v0.17"} "dune" {>= "2.0.0"} "ppxlib" {>= "0.28.0"} ] available: arch != "arm32" & arch != "x86_32" synopsis: "Generation of accessor and iteration functions for ocaml variant types" description: " Part of the Jane Street's PPX rewriters collection. " ppx_variants_conv-0.16.0/src/000077500000000000000000000000001442175067100161375ustar00rootroot00000000000000ppx_variants_conv-0.16.0/src/dune000066400000000000000000000002661442175067100170210ustar00rootroot00000000000000(library (name ppx_variants_conv) (public_name ppx_variants_conv) (kind ppx_deriver) (ppx_runtime_libraries variantslib) (libraries base ppxlib) (preprocess (pps ppxlib.metaquot)))ppx_variants_conv-0.16.0/src/ppx_variants_conv.ml000066400000000000000000000635221442175067100222440ustar00rootroot00000000000000(* Generated code should depend on the environment in scope as little as possible. E.g. rather than [foo = []] do [match foo with [] ->], to eliminate the use of [=]. It is especially important to not use polymorphic comparisons, since we are moving more and more to code that doesn't have them in scope. *) open Base open Ppxlib open Ast_builder.Default let raise_unsupported loc = Location.raise_errorf ~loc "Unsupported use of variants (you can only use it on variant types)." ;; module Create = struct let lambda loc xs body = List.fold_right xs ~init:body ~f:(fun (label, p) e -> pexp_fun ~loc label None p e) ;; let lambda_sig loc arg_tys body_ty = List.fold_right arg_tys ~init:body_ty ~f:(fun (label, arg_ty) acc -> ptyp_arrow ~loc label arg_ty acc) ;; end module Variant_constructor = struct type t = { name : string ; loc : Location.t ; kind : [ `Normal of core_type list * core_type option | `Normal_inline_record of label_declaration list * core_type option | `Polymorphic of core_type option ] } let args t = match t.kind with | `Normal (pcd_args, _) -> List.mapi pcd_args ~f:(fun i _ -> Nolabel, "v" ^ Int.to_string i) | `Normal_inline_record (fields, _) -> List.mapi fields ~f:(fun i f -> Labelled f.pld_name.txt, "v" ^ Int.to_string i) | `Polymorphic None -> [] | `Polymorphic (Some _) -> [ Nolabel, "v0" ] ;; let return_ty_opt t = match t.kind with | `Normal (_, return_ty_opt) | `Normal_inline_record (_, return_ty_opt) -> return_ty_opt | `Polymorphic _ -> None ;; let return_ty t ~variant_type = Option.value (return_ty_opt t) ~default:variant_type (* We could be smarter and avoid treating as GADT constructors that use the GADT syntax but not the expressivity of GADTs. It's not clearly useful though. *) let is_gadt t = Option.is_some (return_ty_opt t) let pattern_without_binding { name; loc; kind } = match kind with | `Normal ([], _) -> ppat_construct ~loc (Located.lident ~loc name) None | `Normal (_ :: _, _) | `Normal_inline_record _ -> ppat_construct ~loc (Located.lident ~loc name) (Some (ppat_any ~loc)) | `Polymorphic None -> ppat_variant ~loc name None | `Polymorphic (Some _) -> ppat_variant ~loc name (Some (ppat_any ~loc)) ;; let to_fun_type t ~rhs:body_ty = let arg_types = match t.kind with | `Polymorphic None -> [] | `Polymorphic (Some v) -> [ Nolabel, v ] | `Normal (args, _) -> List.map args ~f:(fun typ -> Nolabel, typ) | `Normal_inline_record (fields, _) -> List.map fields ~f:(fun cd -> Labelled cd.pld_name.txt, cd.pld_type) in Create.lambda_sig t.loc arg_types body_ty ;; let to_getter_type t ~lhs:input_type = if is_gadt t (* see getter_opt below for why *) then None else ( let variant_for_label (ld : label_declaration) = ptyp_variant ~loc:ld.pld_loc [ rtag ~loc:ld.pld_loc ld.pld_name false [ ld.pld_type ] ] Closed None in let loc = t.loc in let result_type = match t.kind with | `Polymorphic None | `Normal ([], _) | `Normal_inline_record ([], _) -> [%type: unit] | `Polymorphic (Some v) -> v | `Normal (tup, _) -> ptyp_tuple ~loc tup | `Normal_inline_record (fields, _) -> ptyp_tuple ~loc (List.map fields ~f:variant_for_label) in Some (ptyp_arrow ~loc Nolabel input_type [%type: [%t result_type] option])) ;; let to_getter_case { loc; name; kind } = let pat, idents = match kind with | `Polymorphic None -> ppat_variant ~loc name None, [] | `Polymorphic (Some _) -> let ident = "v" in ppat_variant ~loc name (Some (pvar ident ~loc)), [ `Unlabelled ident ] | `Normal ([], _) -> ppat_construct ~loc (Located.lident ~loc name) None, [] | `Normal (args, _) -> let idents = List.mapi args ~f:(fun i _ -> "v" ^ Int.to_string i) in let patterns = List.map idents ~f:(pvar ~loc) in ( ppat_construct ~loc (Located.lident ~loc name) (Some (ppat_tuple ~loc patterns)) , List.map idents ~f:(fun i -> `Unlabelled i) ) | `Normal_inline_record (lds, _) -> let patterns, idents = List.mapi lds ~f:(fun i ld -> let ident = "v" ^ Int.to_string i in let field_pat = Located.map_lident ld.pld_name, pvar ident ~loc in field_pat, `Labelled (ld.pld_name.txt, ident)) |> List.unzip in ( ppat_construct ~loc (Located.lident ~loc name) (Some (ppat_record ~loc patterns Closed)) , idents ) in let ident_expr = function | `Unlabelled ident -> evar ~loc ident | `Labelled (label, ident) -> pexp_variant ~loc label (Some (evar ~loc ident)) in let expr = match idents with | [] -> [%expr ()] | idents -> pexp_tuple ~loc (List.map idents ~f:ident_expr) in pat, expr ;; end let variant_name_to_string v = let s = String.lowercase v in if Keyword.is_keyword s then s ^ "_" else s ;; module Inspect = struct let row_field loc rf : Variant_constructor.t = match rf.prf_desc with | Rtag ({ txt = name; _ }, true, _) | Rtag ({ txt = name; _ }, _, []) -> { name; loc; kind = `Polymorphic None } | Rtag ({ txt = name; _ }, false, tp :: _) -> { name; loc; kind = `Polymorphic (Some tp) } | Rinherit _ -> Location.raise_errorf ~loc "ppx_variants_conv: polymorphic variant inclusion is not supported" ;; let constructor cd : Variant_constructor.t = let kind = match cd.pcd_args with | Pcstr_tuple pcd_args -> `Normal (pcd_args, cd.pcd_res) | Pcstr_record fields -> `Normal_inline_record (fields, cd.pcd_res) in { name = cd.pcd_name.txt; loc = cd.pcd_name.loc; kind } ;; let type_decl td = let loc = td.ptype_loc in match td.ptype_kind with | Ptype_variant cds -> let cds = List.map cds ~f:constructor in let names_as_string = Hashtbl.create (module String) in List.iter cds ~f:(fun { name; loc; _ } -> let s = variant_name_to_string name in match Hashtbl.find names_as_string s with | None -> Hashtbl.add_exn names_as_string ~key:s ~data:name | Some name' -> Location.raise_errorf ~loc "ppx_variants_conv: constructors %S and %S both get mapped to value %S" name name' s); cds | Ptype_record _ | Ptype_open -> raise_unsupported loc | Ptype_abstract -> (match td.ptype_manifest with | Some { ptyp_desc = Ptyp_variant (row_fields, Closed, None); _ } -> List.map row_fields ~f:(row_field loc) | Some { ptyp_desc = Ptyp_variant _; ptyp_loc = loc; _ } -> Location.raise_errorf ~loc "ppx_variants_conv: polymorphic variants with a row variable are not supported" | _ -> raise_unsupported loc) ;; end let variants_module = function | "t" -> "Variants" | type_name -> "Variants_of_" ^ type_name ;; module Gen_sig = struct let label_arg _loc name ty = Asttypes.Labelled (variant_name_to_string name), ty let val_ ~loc name type_ = psig_value ~loc (value_description ~loc ~name:(Located.mk ~loc name) ~type_ ~prim:[]) ;; let variant_arg f ~variant_type (v : Variant_constructor.t) = let loc = v.loc in let return_ty = Variant_constructor.return_ty v ~variant_type in let variant = [%type: [%t Variant_constructor.to_fun_type v ~rhs:return_ty] Variantslib.Variant.t] in label_arg loc v.Variant_constructor.name (f ~variant) ;; let v_fold_fun ~variant_type loc variants = let acc i = ptyp_var ~loc ("acc__" ^ Int.to_string i) in let f i v = variant_arg ~variant_type (fun ~variant -> [%type: [%t acc i] -> [%t variant] -> [%t acc (i + 1)]]) v in let types = List.mapi variants ~f in let init_ty = label_arg loc "init" (acc 0) in let t = Create.lambda_sig loc (init_ty :: types) (acc (List.length variants)) in val_ ~loc "fold" t ;; let v_iter_fun ~variant_type loc variants = let f = variant_arg ~variant_type (fun ~variant -> [%type: [%t variant] -> unit]) in let types = List.map variants ~f in let t = Create.lambda_sig loc types [%type: unit] in val_ ~loc "iter" t ;; let v_map_fun_opt ~variant_type loc variants = let module V = Variant_constructor in if List.exists variants ~f:V.is_gadt then None else ( let result_type = [%type: 'result__] in let f v = let variant = let constructor_type = V.to_fun_type v ~rhs:variant_type in Create.lambda_sig loc [ Nolabel, [%type: [%t constructor_type] Variantslib.Variant.t] ] (V.to_fun_type v ~rhs:result_type) in label_arg loc v.V.name variant in let types = List.map variants ~f in let t = Create.lambda_sig loc ((Nolabel, variant_type) :: types) result_type in Some (val_ ~loc "map" t)) ;; let v_make_matcher_fun_opt ~variant_type loc variants = let module V = Variant_constructor in if List.exists variants ~f:V.is_gadt then None else ( let result_type = [%type: 'result__] in let acc i = ptyp_var ~loc ("acc__" ^ Int.to_string i) in let f i v = let variant = [%type: [%t Variant_constructor.to_fun_type v ~rhs:variant_type] Variantslib.Variant.t] in let fun_type = match Variant_constructor.args v with | [] -> [%type: unit -> [%t result_type]] | _ :: _ -> Variant_constructor.to_fun_type v ~rhs:result_type in label_arg loc v.name [%type: [%t variant] -> [%t acc i] -> [%t fun_type] * [%t acc (i + 1)]] in let types = List.mapi variants ~f in let t = Create.lambda_sig loc (types @ [ Nolabel, acc 0 ]) [%type: ([%t variant_type] -> [%t result_type]) * [%t acc (List.length variants)]] in Some (val_ ~loc "make_matcher" t)) ;; let v_descriptions ~variant_type:_ loc _ = val_ ~loc "descriptions" [%type: (string * int) list] ;; let v_to_rank_fun ~variant_type loc _ = val_ ~loc "to_rank" [%type: [%t variant_type] -> int] ;; let v_to_name_fun ~variant_type loc _ = val_ ~loc "to_name" [%type: [%t variant_type] -> string] ;; let variant ~variant_type ~ty_name loc variants = let tester_type = [%type: [%t variant_type] -> bool] in let helpers, variant_defs = List.unzip (List.map variants ~f:(fun v -> let module V = Variant_constructor in let return_ty = V.return_ty v ~variant_type in let constructor_type = V.to_fun_type v ~rhs:return_ty in let getter_type_opt = V.to_getter_type v ~lhs:return_ty in let name = variant_name_to_string v.V.name in ( ( val_ ~loc name constructor_type , val_ ~loc ("is_" ^ name) tester_type , Option.map getter_type_opt ~f:(val_ ~loc (name ^ "_val")) ) , val_ ~loc name [%type: [%t constructor_type] Variantslib.Variant.t] ))) in let constructors, testers, getters = List.unzip3 helpers in constructors @ testers @ List.filter_opt getters @ [ psig_module ~loc (module_declaration ~loc ~name:(Located.mk ~loc (Some (variants_module ty_name))) ~type_: (pmty_signature ~loc (variant_defs @ List.filter_opt [ Some (v_fold_fun ~variant_type loc variants) ; Some (v_iter_fun ~variant_type loc variants) ; v_map_fun_opt ~variant_type loc variants ; v_make_matcher_fun_opt ~variant_type loc variants ; Some (v_to_rank_fun ~variant_type loc variants) ; Some (v_to_name_fun ~variant_type loc variants) ; Some (v_descriptions ~variant_type loc variants) ]))) ] ;; let variants_of_td td = let ty_name = td.ptype_name.txt in let loc = td.ptype_loc in let variant_type = core_type_of_type_declaration td in variant ~variant_type ~ty_name loc (Inspect.type_decl td) ;; let generate ~loc ~path:_ (rec_flag, tds) = (match rec_flag with | Nonrecursive -> Location.raise_errorf ~loc "nonrec is not compatible with the `ppx_variants_conv' preprocessor" | _ -> ()); match tds with | [ td ] -> variants_of_td td | _ -> Location.raise_errorf ~loc "ppx_variants_conv: not supported" ;; end module Gen_str = struct (** Replace type variables with locally abstract type, say ['a] with [a], and return the set of locally abstract types created this way. *) let newtypes = let newtype_visitor = object inherit [label list] Ast_traverse.fold_map as super method! core_type core_type acc = match core_type.ptyp_desc with | Ptyp_var label -> let loc = core_type.ptyp_loc in let ty = ptyp_constr ~loc { loc; txt = Longident.Lident label } [] in ty, label :: acc | Ptyp_any -> let label = gen_symbol () in let loc = core_type.ptyp_loc in let ty = ptyp_constr ~loc { loc; txt = Longident.Lident label } [] in ty, label :: acc | _ -> super#core_type core_type acc end in fun ty -> let ty, labels = newtype_visitor#core_type ty [] in ty, List.dedup_and_sort ~compare:String.compare labels ;; let locally_abstract_match loc cases ~variant_ty = let variant_ty, lbls = newtypes variant_ty in let match_expr = pexp_match ~loc [%expr t] cases in let fun_expr = [%expr fun (t : [%t variant_ty]) -> [%e match_expr]] in List.fold_right lbls ~init:fun_expr ~f:(fun txt acc -> pexp_newtype ~loc { txt; loc } acc) ;; let helpers_and_variants loc ~variant_ty variants = let multiple_cases = List.length variants > 1 in let module V = Variant_constructor in let helpers, variants = List.mapi variants ~f:(fun rank v -> let uncapitalized = variant_name_to_string v.V.name in let constructor = let constructed_value = match v.V.kind with | `Normal _ -> let arg = pexp_tuple_opt ~loc (List.map (V.args v) ~f:(fun (_, v) -> evar ~loc v)) in pexp_construct ~loc (Located.lident ~loc v.V.name) arg | `Polymorphic _ -> let arg = pexp_tuple_opt ~loc (List.map (V.args v) ~f:(fun (_, v) -> evar ~loc v)) in pexp_variant ~loc v.V.name arg | `Normal_inline_record (fields, _) -> let arg = pexp_record ~loc (List.map2_exn fields (V.args v) ~f:(fun f (_, name) -> Located.lident ~loc f.pld_name.txt, evar ~loc name)) None in pexp_construct ~loc (Located.lident ~loc v.V.name) (Some arg) in pstr_value ~loc Nonrecursive [ value_binding ~loc ~pat:(pvar ~loc uncapitalized) ~expr: (List.fold_right (V.args v) ~init:constructed_value ~f:(fun (label, v) e -> pexp_fun ~loc label None (pvar ~loc v) e)) ] in let variant = [%stri let [%p pvar ~loc uncapitalized] = { Variantslib.Variant.name = [%e estring ~loc v.V.name] ; rank = [%e eint ~loc rank] ; constructor = [%e evar ~loc uncapitalized] } ;;] in let match_fun ~name ~true_case ~false_expr = let cases = if multiple_cases then [ true_case; case ~guard:None ~lhs:[%pat? _] ~rhs:false_expr ] else [ true_case ] in let body = if Variant_constructor.is_gadt v then locally_abstract_match loc cases ~variant_ty else pexp_function ~loc cases in [%stri let [%p pvar ~loc name] = [%e body] [@@warning "-4"]] in let tester = let name = "is_" ^ uncapitalized in let true_case = case ~guard:None ~lhs:(Variant_constructor.pattern_without_binding v) ~rhs:[%expr true] in match_fun ~name ~true_case ~false_expr:[%expr false] in let getter_opt = (* We cannot generate a getter for GADTs in the case that we have existentially quantified type vars. Further we can't generate _regular_ getter functions when the GADT is non-regular. For the time being we skip generating getters for GADTs altogether *) if Variant_constructor.is_gadt v then None else ( let name = uncapitalized ^ "_val" in let pat, expr = Variant_constructor.to_getter_case v in let true_case = case ~guard:None ~lhs:pat ~rhs:[%expr Stdlib.Option.Some [%e expr]] in Some (match_fun ~name ~true_case ~false_expr:[%expr Stdlib.Option.None])) in (constructor, tester, getter_opt), variant) |> List.unzip in let constructors, testers, getters = List.unzip3 helpers in constructors, testers, List.filter_opt getters, variants ;; let label_arg ?label loc name = let l = match label with | None -> name | Some n -> n in Asttypes.Labelled l, pvar ~loc name ;; let label_arg_fun loc name = label_arg ~label:name loc (name ^ "_fun__") let v_fold_fun loc variants = let module V = Variant_constructor in let variant_fold acc_expr variant = let variant_name = variant_name_to_string variant.V.name in [%expr [%e evar ~loc (variant_name ^ "_fun__")] [%e acc_expr] [%e evar ~loc variant_name]] in let body = List.fold_left variants ~init:[%expr init__] ~f:variant_fold in let patterns = List.map variants ~f:(fun variant -> label_arg_fun loc (variant_name_to_string variant.V.name)) in let init = label_arg ~label:"init" loc "init__" in let lambda = Create.lambda loc (init :: patterns) body in [%stri let fold = [%e lambda]] ;; let v_descriptions loc variants = let module V = Variant_constructor in let f v = [%expr [%e estring ~loc v.V.name], [%e eint ~loc (List.length (V.args v))]] in let variant_names = List.map ~f variants in [%stri let descriptions = [%e elist ~loc variant_names]] ;; let v_map_fun_opt loc variants = let module V = Variant_constructor in (* We are currently not generating getter for GADTs which mean we can't generate [map] *) if List.exists variants ~f:V.is_gadt then None else ( let variant_match_case variant = let pattern = match variant.V.kind with | `Polymorphic _ -> let arg = ppat_tuple_opt ~loc (List.map (V.args variant) ~f:(fun (_, v) -> pvar ~loc v)) in ppat_variant ~loc variant.V.name arg | `Normal _ -> let arg = ppat_tuple_opt ~loc (List.map (V.args variant) ~f:(fun (_, v) -> pvar ~loc v)) in ppat_construct ~loc (Located.lident ~loc variant.V.name) arg | `Normal_inline_record (fields, _) -> let arg = ppat_record ~loc (List.map2_exn fields (V.args variant) ~f:(fun f (_, v) -> Located.lident ~loc f.pld_name.txt, pvar ~loc v)) Closed in ppat_construct ~loc (Located.lident ~loc variant.V.name) (Some arg) in let uncapitalized = variant_name_to_string variant.V.name in let value = List.fold_left (V.args variant) ~init: (eapply ~loc (evar ~loc (uncapitalized ^ "_fun__")) [ evar ~loc uncapitalized ]) ~f:(fun acc_expr (label, var) -> pexp_apply ~loc acc_expr [ label, evar ~loc var ]) in case ~guard:None ~lhs:pattern ~rhs:value in let body = pexp_match ~loc [%expr t__] (List.map variants ~f:variant_match_case) in let patterns = List.map variants ~f:(fun variant -> label_arg_fun loc (variant_name_to_string variant.V.name)) in let lambda = Create.lambda loc ((Nolabel, [%pat? t__]) :: patterns) body in Some [%stri let map = [%e lambda]]) ;; let v_iter_fun loc variants = let module V = Variant_constructor in let names = List.map variants ~f:(fun v -> variant_name_to_string v.V.name) in let variant_iter variant = let variant_name = variant_name_to_string variant.V.name in [%expr ([%e evar ~loc (variant_name ^ "_fun__")] [%e evar ~loc variant_name] : unit)] in let body = esequence ~loc (List.map variants ~f:variant_iter) in let patterns = List.map names ~f:(label_arg_fun loc) in let lambda = Create.lambda loc patterns body in [%stri let iter = [%e lambda]] ;; let v_make_matcher_fun_opt loc variants = let module V = Variant_constructor in (* We are currently not generating getter for GADTs which mean we can't generate [map] and consequently can't generate a matcher either *) if List.exists variants ~f:V.is_gadt then None else ( let result = let map = List.fold_left variants ~init:[%expr map] ~f:(fun acc variant -> let variant_name = variant_name_to_string variant.V.name in pexp_apply ~loc acc [ ( Labelled variant_name , match V.args variant with | [] -> [%expr fun _ -> [%e evar ~loc (variant_name ^ "_gen__")] ()] | _ :: _ -> [%expr fun _ -> [%e evar ~loc (variant_name ^ "_gen__")]] ) ]) in [%expr [%e map], compile_acc__] in let body = List.fold_right variants ~init:result ~f:(fun variant acc -> let variant_name = variant_name_to_string variant.V.name in pexp_let ~loc Nonrecursive [ value_binding ~loc ~pat: (ppat_tuple ~loc [ [%pat? [%p pvar ~loc (variant_name ^ "_gen__")]] ; [%pat? compile_acc__] ]) ~expr: [%expr [%e evar ~loc (variant_name ^ "_fun__")] [%e evar ~loc variant_name] compile_acc__] ] acc) in let patterns = List.map variants ~f:(fun v -> label_arg_fun loc (variant_name_to_string v.V.name)) in let lambda = Create.lambda loc (patterns @ [ Nolabel, [%pat? compile_acc__] ]) body in Some [%stri let make_matcher = [%e lambda]]) ;; let case_analysis_ignoring_values variants ~f = let pattern_and_rhs = List.mapi variants ~f:(fun rank v -> Variant_constructor.pattern_without_binding v, f ~rank ~name:v.name) in List.map pattern_and_rhs ~f:(fun (pattern, rhs) -> case ~guard:None ~lhs:pattern ~rhs) ;; let v_to_rank loc variants ~variant_ty = let cases = case_analysis_ignoring_values variants ~f:(fun ~rank ~name:_ -> eint ~loc rank) in let body = if List.exists variants ~f:Variant_constructor.is_gadt then locally_abstract_match loc cases ~variant_ty else pexp_function ~loc cases in [%stri let to_rank = [%e body]] ;; let v_to_name loc variants ~variant_ty = let cases = case_analysis_ignoring_values variants ~f:(fun ~rank:_ ~name -> estring ~loc name) in let body = if List.exists variants ~f:Variant_constructor.is_gadt then locally_abstract_match loc cases ~variant_ty else pexp_function ~loc cases in [%stri let to_name = [%e body]] ;; let variant ~variant_name ~variant_ty loc ty = let constructors, testers, getters, variants = helpers_and_variants loc ~variant_ty ty in constructors @ testers @ getters @ [ pstr_module ~loc (module_binding ~loc ~name:(Located.mk ~loc (Some (variants_module variant_name))) ~expr: (pmod_structure ~loc (variants @ List.filter_opt [ Some (v_fold_fun loc ty) ; Some (v_iter_fun loc ty) ; v_map_fun_opt loc ty ; v_make_matcher_fun_opt loc ty ; Some (v_to_rank loc ty ~variant_ty) ; Some (v_to_name loc ty ~variant_ty) ; Some (v_descriptions loc ty) ]))) ] ;; let variants_of_td td = let variant_name = td.ptype_name.txt in let loc = td.ptype_loc in let variant_ty = core_type_of_type_declaration td in variant ~variant_name ~variant_ty loc (Inspect.type_decl td) ;; let generate ~loc ~path:_ (rec_flag, tds) = (match rec_flag with | Nonrecursive -> Location.raise_errorf ~loc "nonrec is not compatible with the `ppx_variants_conv' preprocessor" | _ -> ()); match tds with | [ td ] -> variants_of_td td | _ -> Location.raise_errorf ~loc "ppx_variants_conv: not supported" ;; end let variants = Deriving.add "variants" ~str_type_decl:(Deriving.Generator.make_noarg Gen_str.generate) ~sig_type_decl:(Deriving.Generator.make_noarg Gen_sig.generate) ;; ppx_variants_conv-0.16.0/src/ppx_variants_conv.mli000066400000000000000000000000471442175067100224060ustar00rootroot00000000000000open Ppxlib val variants : Deriving.t ppx_variants_conv-0.16.0/test/000077500000000000000000000000001442175067100163275ustar00rootroot00000000000000ppx_variants_conv-0.16.0/test/dune000066400000000000000000000000001442175067100171730ustar00rootroot00000000000000ppx_variants_conv-0.16.0/test/test.mlt000066400000000000000000000263351442175067100200350ustar00rootroot00000000000000open Variantslib;; #verbose true (* to ensure we do not generate such warning *) [@@@ocaml.warning "+4"] module Normal = struct type t = | Foo of int | Bar | Exception [@@deriving variants] end [%%expect {| module Normal : sig type t = Foo of int | Bar | Exception val foo : int -> t val bar : t val exception_ : t val is_foo : t -> bool val is_bar : t -> bool val is_exception_ : t -> bool val foo_val : t -> int option val bar_val : t -> unit option val exception__val : t -> unit option module Variants : sig val foo : (int -> t) Variant.t val bar : t Variant.t val exception_ : t Variant.t val fold : init:'a -> foo:('a -> (int -> t) Variant.t -> 'b) -> bar:('b -> t Variant.t -> 'c) -> exception_:('c -> t Variant.t -> 'd) -> 'd val iter : foo:((int -> t) Variant.t -> unit) -> bar:(t Variant.t -> unit) -> exception_:(t Variant.t -> unit) -> unit val map : t -> foo:((int -> t) Variant.t -> int -> 'a) -> bar:(t Variant.t -> 'a) -> exception_:(t Variant.t -> 'a) -> 'a val make_matcher : foo:((int -> t) Variant.t -> 'a -> (int -> 'b) * 'c) -> bar:(t Variant.t -> 'c -> (unit -> 'b) * 'd) -> exception_:(t Variant.t -> 'd -> (unit -> 'b) * 'e) -> 'a -> (t -> 'b) * 'e val to_rank : t -> int val to_name : t -> string val descriptions : (string * int) list end end |}] module Normal2 : sig type t = | Foo of int | Bar | Exception [@@deriving variants] end = Normal [%%expect {| module Normal2 : sig type t = Foo of int | Bar | Exception val foo : int -> t val bar : t val exception_ : t val is_foo : t -> bool val is_bar : t -> bool val is_exception_ : t -> bool val foo_val : t -> int option val bar_val : t -> unit option val exception__val : t -> unit option module Variants : sig val foo : (int -> t) Variant.t val bar : t Variant.t val exception_ : t Variant.t val fold : init:'acc__0 -> foo:('acc__0 -> (int -> t) Variant.t -> 'acc__1) -> bar:('acc__1 -> t Variant.t -> 'acc__2) -> exception_:('acc__2 -> t Variant.t -> 'acc__3) -> 'acc__3 val iter : foo:((int -> t) Variant.t -> unit) -> bar:(t Variant.t -> unit) -> exception_:(t Variant.t -> unit) -> unit val map : t -> foo:((int -> t) Variant.t -> int -> 'result__) -> bar:(t Variant.t -> 'result__) -> exception_:(t Variant.t -> 'result__) -> 'result__ val make_matcher : foo:((int -> t) Variant.t -> 'acc__0 -> (int -> 'result__) * 'acc__1) -> bar:(t Variant.t -> 'acc__1 -> (unit -> 'result__) * 'acc__2) -> exception_:(t Variant.t -> 'acc__2 -> (unit -> 'result__) * 'acc__3) -> 'acc__0 -> (t -> 'result__) * 'acc__3 val to_rank : t -> int val to_name : t -> string val descriptions : (string * int) list end end |}] module Normal_inline_record = struct type t = | Foo of { a : int ; b : string } | Bar [@@deriving variants] end [%%expect {| module Normal_inline_record : sig type t = Foo of { a : int; b : string; } | Bar val foo : a:int -> b:string -> t val bar : t val is_foo : t -> bool val is_bar : t -> bool val foo_val : t -> ([> `a of int ] * [> `b of string ]) option val bar_val : t -> unit option module Variants : sig val foo : (a:int -> b:string -> t) Variant.t val bar : t Variant.t val fold : init:'a -> foo:('a -> (a:int -> b:string -> t) Variant.t -> 'b) -> bar:('b -> t Variant.t -> 'c) -> 'c val iter : foo:((a:int -> b:string -> t) Variant.t -> unit) -> bar:(t Variant.t -> unit) -> unit val map : t -> foo:((a:int -> b:string -> t) Variant.t -> a:int -> b:string -> 'a) -> bar:(t Variant.t -> 'a) -> 'a val make_matcher : foo:((a:int -> b:string -> t) Variant.t -> 'a -> (a:int -> b:string -> 'b) * 'c) -> bar:(t Variant.t -> 'c -> (unit -> 'b) * 'd) -> 'a -> (t -> 'b) * 'd val to_rank : t -> int val to_name : t -> string val descriptions : (string * int) list end end |}] module Poly = struct type t = [ `Foo of int | `Bar | `Exception ] [@@deriving variants] end [%%expect {| module Poly : sig type t = [ `Bar | `Exception | `Foo of int ] val foo : 'a -> [> `Foo of 'a ] val bar : [> `Bar ] val exception_ : [> `Exception ] val is_foo : [> `Foo of 'a ] -> bool val is_bar : [> `Bar ] -> bool val is_exception_ : [> `Exception ] -> bool val foo_val : [> `Foo of 'a ] -> 'a option val bar_val : [> `Bar ] -> unit option val exception__val : [> `Exception ] -> unit option module Variants : sig val foo : ('a -> [> `Foo of 'a ]) Variant.t val bar : [> `Bar ] Variant.t val exception_ : [> `Exception ] Variant.t val fold : init:'a -> foo:('a -> ('b -> [> `Foo of 'b ]) Variant.t -> 'c) -> bar:('c -> [> `Bar ] Variant.t -> 'd) -> exception_:('d -> [> `Exception ] Variant.t -> 'e) -> 'e val iter : foo:(('a -> [> `Foo of 'a ]) Variant.t -> unit) -> bar:([> `Bar ] Variant.t -> unit) -> exception_:([> `Exception ] Variant.t -> unit) -> unit val map : [< `Bar | `Exception | `Foo of 'a ] -> foo:(('b -> [> `Foo of 'b ]) Variant.t -> 'a -> 'c) -> bar:([> `Bar ] Variant.t -> 'c) -> exception_:([> `Exception ] Variant.t -> 'c) -> 'c val make_matcher : foo:(('a -> [> `Foo of 'a ]) Variant.t -> 'b -> ('c -> 'd) * 'e) -> bar:([> `Bar ] Variant.t -> 'e -> (unit -> 'd) * 'f) -> exception_:([> `Exception ] Variant.t -> 'f -> (unit -> 'd) * 'g) -> 'b -> ([< `Bar | `Exception | `Foo of 'c ] -> 'd) * 'g val to_rank : [< `Bar | `Exception | `Foo of 'a ] -> int val to_name : [< `Bar | `Exception | `Foo of 'a ] -> string val descriptions : (string * int) list end end |}] module Wildcard : sig type _ t = | A | B [@@deriving variants] end = struct type _ t = | A | B [@@deriving variants] end [%%expect {| module Wildcard : sig type _ t = A | B val a : 'a t val b : 'a t val is_a : 'a t -> bool val is_b : 'a t -> bool val a_val : 'a t -> unit option val b_val : 'a t -> unit option module Variants : sig val a : 'a t Variant.t val b : 'a t Variant.t val fold : init:'acc__0 -> a:('acc__0 -> 'a t Variant.t -> 'acc__1) -> b:('acc__1 -> 'b t Variant.t -> 'acc__2) -> 'acc__2 val iter : a:('a t Variant.t -> unit) -> b:('b t Variant.t -> unit) -> unit val map : 'a t -> a:('b t Variant.t -> 'result__) -> b:('c t Variant.t -> 'result__) -> 'result__ val make_matcher : a:('a t Variant.t -> 'acc__0 -> (unit -> 'result__) * 'acc__1) -> b:('b t Variant.t -> 'acc__1 -> (unit -> 'result__) * 'acc__2) -> 'acc__0 -> ('c t -> 'result__) * 'acc__2 val to_rank : 'a t -> int val to_name : 'a t -> string val descriptions : (string * int) list end end |}] module Gadt_no_existentials : sig (* We test: - mix of non GADT and GADT - GADT where the result type is constrained - GADT where using inline records - GADT with polymorphic type vars *) type _ t = | C0 of int | C1 : bool -> unit t | C2 : { a : bool } -> float t | C3 : 'a -> 'a t [@@deriving variants] end = struct type _ t = | C0 of int | C1 : bool -> unit t | C2 : { a : bool } -> float t | C3 : 'a -> 'a t [@@deriving variants] end [%%expect {| module Gadt_no_existentials : sig type _ t = C0 of int | C1 : bool -> unit t | C2 : { a : bool; } -> float t | C3 : 'a -> 'a t val c0 : int -> 'a t val c1 : bool -> unit t val c2 : a:bool -> float t val c3 : 'a -> 'a t val is_c0 : 'a t -> bool val is_c1 : 'a t -> bool val is_c2 : 'a t -> bool val is_c3 : 'a t -> bool val c0_val : 'a t -> int option module Variants : sig val c0 : (int -> 'a t) Variant.t val c1 : (bool -> unit t) Variant.t val c2 : (a:bool -> float t) Variant.t val c3 : ('a -> 'a t) Variant.t val fold : init:'acc__0 -> c0:('acc__0 -> (int -> 'b t) Variant.t -> 'acc__1) -> c1:('acc__1 -> (bool -> unit t) Variant.t -> 'acc__2) -> c2:('acc__2 -> (a:bool -> float t) Variant.t -> 'acc__3) -> c3:('acc__3 -> ('a -> 'a t) Variant.t -> 'acc__4) -> 'acc__4 val iter : c0:((int -> 'b t) Variant.t -> unit) -> c1:((bool -> unit t) Variant.t -> unit) -> c2:((a:bool -> float t) Variant.t -> unit) -> c3:(('a -> 'a t) Variant.t -> unit) -> unit val to_rank : 'a t -> int val to_name : 'a t -> string val descriptions : (string * int) list end end |}] module Gadt_existentials : sig (* We test: - GADT with no payload (mostly there to avoid the type being too simple) - GADT with existential type vars - GADT where vars in the type declaration and the return type of a constructor clash *) type 'a t = | C1 : bool t | C2 : 'b * 'a -> 'b t [@@deriving variants] end = struct type 'a t = | C1 : bool t | C2 : 'b * 'a -> 'b t [@@deriving variants] end [%%expect {| module Gadt_existentials : sig type 'a t = C1 : bool t | C2 : 'b * 'a -> 'b t val c1 : bool t val c2 : 'b -> 'a -> 'b t val is_c1 : 'a t -> bool val is_c2 : 'a t -> bool module Variants : sig val c1 : bool t Variant.t val c2 : ('b -> 'a -> 'b t) Variant.t val fold : init:'acc__0 -> c1:('acc__0 -> bool t Variant.t -> 'acc__1) -> c2:('acc__1 -> ('b -> 'a -> 'b t) Variant.t -> 'acc__2) -> 'acc__2 val iter : c1:(bool t Variant.t -> unit) -> c2:(('b -> 'a -> 'b t) Variant.t -> unit) -> unit val to_rank : 'a t -> int val to_name : 'a t -> string val descriptions : (string * int) list end end |}] type fail1 = [ Poly.t | `Blah ] [@@deriving variants] [%%expect {| Line _, characters _-_: Error: ppx_variants_conv: polymorphic variant inclusion is not supported |}] type fail2 = [> `Foo | `Bar ] [@@deriving variants] [%%expect {| Line _, characters _-_: Error: ppx_variants_conv: polymorphic variants with a row variable are not supported |}] type fail3 = [< `Foo | `Bar ] [@@deriving variants] [%%expect {| Line _, characters _-_: Error: ppx_variants_conv: polymorphic variants with a row variable are not supported |}] type fail4 = [< `Foo | `Bar > `Foo ] [@@deriving variants] [%%expect {| Line _, characters _-_: Error: ppx_variants_conv: polymorphic variants with a row variable are not supported |}]