pax_global_header00006660000000000000000000000064135645304060014520gustar00rootroot0000000000000052 comment=4e9b782f199618ea47c27562fb7f639f0fe43b03 ppx_variants_conv-0.13.0/000077500000000000000000000000001356453040600153445ustar00rootroot00000000000000ppx_variants_conv-0.13.0/.gitignore000066400000000000000000000000411356453040600173270ustar00rootroot00000000000000_build *.install *.merlin _opam ppx_variants_conv-0.13.0/CHANGES.md000066400000000000000000000021061356453040600167350ustar00rootroot00000000000000## 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.13.0/CONTRIBUTING.md000066400000000000000000000044101356453040600175740ustar00rootroot00000000000000This 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.13.0/LICENSE.md000066400000000000000000000021351356453040600167510ustar00rootroot00000000000000The MIT License 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 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.13.0/Makefile000066400000000000000000000004031356453040600170010ustar00rootroot00000000000000INSTALL_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.13.0/README.md000066400000000000000000000063751356453040600166360ustar00rootroot00000000000000ppx_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, 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 (** 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: 'b -> a:('b -> ('a -> 'a t) Variant.t -> 'c) -> b:('c -> (char -> 'a t) Variant.t -> 'd) -> c:('d -> ('a t) Variant.t -> 'e) -> d:('e -> (int -> int -> 'a t) Variant.t -> 'f) -> 'f 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:(('a -> 'a t) Variant.t -> 'b -> ('c -> 'd) * 'e) -> b:((char -> 'f t) Variant.t -> 'e -> (char -> 'd) * 'g) -> c:('h t Variant.t -> 'g -> (unit -> 'd) * 'i) -> d:((int -> int -> 'j t) Variant.t -> 'i -> (int -> int -> 'd) * 'k) -> 'b -> ('c t -> 'd) * 'k 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. `ppx_variant_libs` works similarly on simple polymorphic variants (without row variables and without inclusion). ppx_variants_conv-0.13.0/dune000066400000000000000000000000001356453040600162100ustar00rootroot00000000000000ppx_variants_conv-0.13.0/dune-project000066400000000000000000000000171356453040600176640ustar00rootroot00000000000000(lang dune 1.5)ppx_variants_conv-0.13.0/example/000077500000000000000000000000001356453040600167775ustar00rootroot00000000000000ppx_variants_conv-0.13.0/example/dune000066400000000000000000000002011356453040600176460ustar00rootroot00000000000000(executables (names test) (libraries) (preprocess (pps ppx_variants_conv))) (alias (name DEFAULT) (deps test.ml.pp test.mli.pp))ppx_variants_conv-0.13.0/example/test.ml000066400000000000000000000004211356453040600203050ustar00rootroot00000000000000module 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.13.0/example/test.mli000066400000000000000000000002331356453040600204570ustar00rootroot00000000000000module Normal : sig type t = Foo of int | Bar [@@deriving variants] end module Poly : sig type t = [ `Foo of int | `Bar ] [@@deriving variants] end ppx_variants_conv-0.13.0/ppx_variants_conv.opam000066400000000000000000000014741356453040600217730ustar00rootroot00000000000000opam-version: "2.0" version: "v0.13.0" maintainer: "opensource@janestreet.com" 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.04.2"} "base" {>= "v0.13" & < "v0.14"} "variantslib" {>= "v0.13" & < "v0.14"} "dune" {>= "1.5.1"} "ppxlib" {>= "0.9.0"} ] 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.13.0/src/000077500000000000000000000000001356453040600161335ustar00rootroot00000000000000ppx_variants_conv-0.13.0/src/dune000066400000000000000000000002661356453040600170150ustar00rootroot00000000000000(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.13.0/src/ppx_variants_conv.ml000066400000000000000000000434671356453040600222460ustar00rootroot00000000000000(* 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 | `Normal_inline_record of label_declaration list | `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 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 end let variant_name_to_string v = let s = String.lowercase v in if Caml.Hashtbl.mem Lexer.keyword_table 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 = if Option.is_some cd.pcd_res then Location.raise_errorf ~loc:cd.pcd_loc "GADTs are not supported by variantslib"; let kind = match cd.pcd_args with | Pcstr_tuple pcd_args -> `Normal pcd_args | Pcstr_record fields -> `Normal_inline_record fields 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 apply_type loc ~ty_name ~tps = ptyp_constr ~loc (Located.lident ~loc ty_name) tps 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 variant = [%type: [%t Variant_constructor.to_fun_type v ~rhs:variant_type] Variantslib.Variant.t] in label_arg loc v.Variant_constructor.name (f ~variant) ;; let v_fold_fun ~variant_type loc variants = let f = variant_arg ~variant_type (fun ~variant -> [%type: 'acc__ -> [%t variant] -> 'acc__ ]) in let types = List.map variants ~f in let init_ty = label_arg loc "init" [%type: 'acc__ ] in let t = Create.lambda_sig loc (init_ty :: types) [%type: 'acc__ ] 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 ~variant_type loc variants = let module V = Variant_constructor in 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 val_ ~loc "map" t ;; let v_make_matcher_fun ~variant_type loc variants = 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 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 constructors, variant_defs = List.unzip (List.map variants ~f:(fun v -> let module V = Variant_constructor in let constructor_type = V.to_fun_type v ~rhs:variant_type in let name = variant_name_to_string v.V.name in ( val_ ~loc name constructor_type , val_ ~loc name [%type: [%t constructor_type] Variantslib.Variant.t] ))) in constructors @ [ psig_module ~loc (module_declaration ~loc ~name:(Located.mk ~loc (variants_module ty_name)) ~type_:(pmty_signature ~loc (variant_defs @ [ v_fold_fun ~variant_type loc variants ; v_iter_fun ~variant_type loc variants ; v_map_fun ~variant_type loc variants ; v_make_matcher_fun ~variant_type loc variants ; v_to_rank_fun ~variant_type loc variants ; v_to_name_fun ~variant_type loc variants ; 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 = apply_type loc ~ty_name ~tps:(List.map td.ptype_params ~f:fst) 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 let constructors_and_variants loc variants = let module V = Variant_constructor in List.unzip (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 constructor, variant )) ;; 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 loc variants = let module V = Variant_constructor in 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 [%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 loc variants = let module V = Variant_constructor in 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 [%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 ty = let cases = case_analysis_ignoring_values ty ~f:(fun ~rank ~name:_ -> eint ~loc rank) in [%stri let to_rank = [%e pexp_function ~loc cases]] ;; let v_to_name loc ty = let cases = case_analysis_ignoring_values ty ~f:(fun ~rank:_ ~name -> estring ~loc name) in [%stri let to_name = [%e pexp_function ~loc cases]] ;; let variant ~variant_name loc ty = let constructors, variants = constructors_and_variants loc ty in constructors @ [ pstr_module ~loc (module_binding ~loc ~name:(Located.mk ~loc (variants_module variant_name)) ~expr:(pmod_structure ~loc (variants @ [ v_fold_fun loc ty ; v_iter_fun loc ty ; v_map_fun loc ty ; v_make_matcher_fun loc ty ; v_to_rank loc ty ; v_to_name loc ty ; v_descriptions loc ty ]))) ] ;; let variants_of_td td = let variant_name = td.ptype_name.txt in let loc = td.ptype_loc in variant ~variant_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 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.13.0/src/ppx_variants_conv.mli000066400000000000000000000000471356453040600224020ustar00rootroot00000000000000open Ppxlib val variants : Deriving.t ppx_variants_conv-0.13.0/test/000077500000000000000000000000001356453040600163235ustar00rootroot00000000000000ppx_variants_conv-0.13.0/test/dune000066400000000000000000000000001356453040600171670ustar00rootroot00000000000000ppx_variants_conv-0.13.0/test/test.mlt000066400000000000000000000161441356453040600200260ustar00rootroot00000000000000open Variantslib #verbose true;; 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 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 module Variants : sig val foo : (int -> t) Variant.t val bar : t Variant.t val exception_ : t Variant.t val fold : init:'acc__ -> foo:('acc__ -> (int -> t) Variant.t -> 'acc__) -> bar:('acc__ -> t Variant.t -> 'acc__) -> exception_:('acc__ -> t Variant.t -> 'acc__) -> 'acc__ 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 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 ] 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 module Variants : sig val a : 'a t Variant.t val b : 'a t Variant.t val fold : init:'acc__ -> a:('acc__ -> 'a t Variant.t -> 'acc__) -> b:('acc__ -> 'b t Variant.t -> 'acc__) -> 'acc__ 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 |}];; 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 |}];;