├── .gitignore ├── .travis.yml ├── CHANGES.md ├── LICENSE.txt ├── Makefile ├── README.md ├── dune-project ├── ppx_deriving_crowbar.opam ├── src ├── dune ├── ppx_deriving_crowbar.ml ├── ppx_deriving_crowbar_runtime.ml └── ppx_deriving_crowbar_runtime.mli └── test ├── dune ├── test.expected └── test.ml /.gitignore: -------------------------------------------------------------------------------- 1 | *.install 2 | _build 3 | .merlin 4 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | install: wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-docker.sh 3 | script: bash -ex .travis-docker.sh 4 | services: 5 | - docker 6 | env: 7 | global: 8 | - PINS="ppx_deriving_crowbar:. xmldiff:https://github.com/yomimono/xmldiff.git#4.06-compat" 9 | - DISTRO="debian-stable" 10 | matrix: 11 | - PACKAGE="ppx_deriving_crowbar" OCAML_VERSION="4.06.0" 12 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | v0.1.1 2018-04-27 2 | ----------------- 3 | 4 | * now not broken with jbuilder! (always set "linkall" so ppx_deriving_crowbar can be driverized) 5 | 6 | v0.1.0 2018-03-29 7 | ----------------- 8 | 9 | Initial release. 10 | -------------------------------------------------------------------------------- /LICENSE.txt: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017 Mindy Preston 2 | 3 | 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: 4 | 5 | The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 6 | 7 | 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. 8 | 9 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | build: 2 | dune build 3 | 4 | test: 5 | dune runtest 6 | 7 | clean: 8 | dune clean 9 | 10 | .PHONY: build test doc clean 11 | 12 | VERSION := $$(opam query --version) 13 | NAME_VERSION := $$(opam query --name-version) 14 | ARCHIVE := $$(opam query --archive) 15 | 16 | release: 17 | git tag -a v$(VERSION) -m "Version $(VERSION)." 18 | git push origin v$(VERSION) 19 | opam publish prepare $(NAME_VERSION) $(ARCHIVE) 20 | opam publish submit $(NAME_VERSION) 21 | rm -rf $(NAME_VERSION) 22 | 23 | .PHONY: release tests 24 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # ppx_deriving_crowbar 2 | 3 | ## What is this? 4 | 5 | `ppx_deriving_crowbar` is a [ppx_deriving](https://github.com/ocaml-ppx/ppx_deriving) plugin for generating [crowbar](https://github.com/stedolan/crowbar) generators. 6 | 7 | ## Examples: 8 | 9 | ``` 10 | type number = int [@@deriving crowbar] 11 | ``` 12 | 13 | will result in a function which maps Crowbar's `int` generator primitive to a `t`: 14 | 15 | ``` 16 | let number_to_crowbar : t Crowbar.gen = Crowbar.(map [int] (fun a -> a)) 17 | ``` 18 | 19 | You can specify a custom generator to replace the automatically derived one with `[@generator f]`. (This is useful in large mutually-recursive type definitions, where you want *most* of the automatically derived functions.) For example: 20 | 21 | ``` 22 | type p = int 23 | and q = p list 24 | and r = q list [@generator Crowbar.const []] 25 | [@@deriving crowbar] 26 | ``` 27 | 28 | to create the following functions: 29 | 30 | ``` 31 | let p_to_crowbar : p Crowbar.gen = Crowbar.(map [int] fun a -> a) 32 | and q_to_crowbar : q Crowbar.gen = Crowbar.list p_to_crowbar 33 | and r_to_crowbar : r Crowbar.gen = Crowbar.const [] 34 | ``` 35 | 36 | Note that types named `t` get functions named `to_crowbar`, rather than `t_to_crowbar`, as is the convention for `ppx_deriving` plugins. 37 | 38 | ## Examples 39 | 40 | `ppx_deriving_crowbar` is used in tandem with [`ppx_import`](https://github.com/ocaml-ppx/ppx_import) to automatically generate OCaml ASTs to test `ocaml-migrate-parsetree` in [ocaml-test-omp](https://github.com/yomimono/ocaml-test-omp), and to generate certificates to test `ocaml-x509` in [ocaml-test-x509](https://github.com/yomimono/ocaml-test-x509). 41 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 1.3) 2 | (name ppx_deriving_crowbar) 3 | -------------------------------------------------------------------------------- /ppx_deriving_crowbar.opam: -------------------------------------------------------------------------------- 1 | opam-version: "1.2" 2 | maintainer: "maintenance@identity-function.com" 3 | authors: ["Mindy Preston"] 4 | homepage: "https://github.com/yomimono/ppx_deriving_crowbar" 5 | bug-reports: "https://github.com/yomimono/ppx_deriving_crowbar/issues" 6 | dev-repo: "https://github.com/yomimono/ppx_deriving_crowbar.git" 7 | license: "MIT" 8 | build: [ 9 | ["dune" "subst"] {pinned} 10 | ["dune" "build" "-p" name "-j" jobs] 11 | ] 12 | build-test: [ 13 | ["dune" "runtest" "-p" name "-j" jobs] 14 | ] 15 | available: [ ocaml-version >= "4.06.0" ] 16 | depends: [ 17 | "dune" {build & >= "1.3.0"} 18 | "ppxfind" {build} 19 | "ppx_deriving" {>= "4.1.5" } 20 | "ppx_tools" 21 | "crowbar" 22 | ] 23 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (public_name ppx_deriving_crowbar) 3 | (modules ppx_deriving_crowbar) 4 | (synopsis "[@@deriving crowbar]") 5 | (kind ppx_deriver) 6 | (libraries ppx_deriving.api) 7 | (preprocess (action (run ppxfind -legacy ppx_tools.metaquot --as-pp %{input-file}))) 8 | (ppx_runtime_libraries ppx_deriving_crowbar.runtime) 9 | (flags :standard -w a@5@8@10@11@12@14@23@24@26@29@40) 10 | ) 11 | 12 | (library 13 | (name ppx_deriving_crowbar_runtime) 14 | (public_name ppx_deriving_crowbar.runtime) 15 | (synopsis "Runtime components of [@@deriving crowbar]") 16 | (modules ppx_deriving_crowbar_runtime) 17 | (libraries ppx_deriving.runtime) 18 | ) 19 | -------------------------------------------------------------------------------- /src/ppx_deriving_crowbar.ml: -------------------------------------------------------------------------------- 1 | open Location 2 | open Parsetree 3 | open Asttypes 4 | open Ast_helper 5 | open Ast_convenience 6 | 7 | let deriver = "crowbar" 8 | let raise_errorf = Ppx_deriving.raise_errorf 9 | 10 | (* currently we only know how to deal with one option, so just return its value *) 11 | let parse_options options = 12 | let always_nonempty = ref false in 13 | options |> List.iter (fun (name, expr) -> 14 | match name with 15 | | "nonempty" -> always_nonempty := true 16 | | _ -> raise_errorf ~loc:expr.pexp_loc "%s does not support option %s" 17 | deriver name); 18 | !always_nonempty 19 | 20 | 21 | let mangler = Ppx_deriving.(`Suffix "to_crowbar") 22 | let unlazify_attribute_name = "crowbar_recursive_typedef_please_unlazy" 23 | (* TODO: actually make sure this is unique *) 24 | 25 | let attr_generator attrs = 26 | Ppx_deriving.(attrs |> attr ~deriver "generator" |> Arg.(get_attr ~deriver expr)) 27 | 28 | let make_crowbar_list l = 29 | let consify add_me extant = 30 | Ast_helper.Exp.(construct (Ast_convenience.lid "Crowbar.::") 31 | (Some (tuple [add_me; extant]))) 32 | in 33 | List.fold_right consify l (Ast_helper.Exp.construct (Ast_convenience.lid 34 | "Crowbar.[]") None) 35 | 36 | let rec n_vars n (l : string list) = 37 | if n > 0 then n_vars (n-1) ((Ppx_deriving.fresh_var l)::l) 38 | else List.rev l 39 | 40 | let last_fun arg function_body = Ast_helper.Exp.fun_ Nolabel None 41 | (Ast_helper.Pat.var (Location.mknoloc arg)) 42 | function_body 43 | 44 | let lazify e = [%expr lazy [%e e]] 45 | 46 | let rec expr_of_typ always_nonempty quoter typ = 47 | let expr_of_typ = expr_of_typ always_nonempty quoter in 48 | match attr_generator typ.ptyp_attributes with 49 | | Some generator -> Ppx_deriving.quote quoter generator 50 | | None -> 51 | let typ = Ppx_deriving.remove_pervasives ~deriver typ in 52 | match typ with 53 | | { ptyp_desc = Ptyp_constr ({ txt = lid }, args) } -> 54 | begin 55 | match typ with 56 | | [%type: unit] -> [%expr Crowbar.const ()] 57 | | [%type: int] -> [%expr Crowbar.int] 58 | | [%type: int32] 59 | | [%type: Int32.t] -> [%expr Crowbar.int32] 60 | | [%type: int64] 61 | | [%type: Int64.t] -> [%expr Crowbar.int64] 62 | | [%type: float] -> [%expr Crowbar.float] 63 | | [%type: bool] -> [%expr Crowbar.bool] 64 | | [%type: char] -> [%expr Crowbar.(map [uint8] Char.chr)] 65 | | [%type: string] 66 | | [%type: String.t] -> [%expr Crowbar.bytes] 67 | | [%type: bytes] 68 | | [%type: Bytes.t] -> [%expr Crowbar.(map [bytes] Bytes.of_string)] 69 | | [%type: nativeint] 70 | | [%type: Nativeint.t] -> [%expr Crowbar.(map [int] Nativeint.of_int)] 71 | (* also TODO: do we DTRT for [@nobuiltin]? nope. *) 72 | | [%type: [%t? typ] option] -> 73 | [%expr Crowbar.(option [%e expr_of_typ typ])] 74 | | [%type: [%t? typ] ref] -> 75 | [%expr Crowbar.(map [[%e expr_of_typ typ]] (fun a -> ref a))] 76 | | [%type: [%t? typ] list] -> 77 | if always_nonempty then [%expr Crowbar.(list1 [%e expr_of_typ typ])] 78 | else [%expr Crowbar.(list [%e expr_of_typ typ])] 79 | | [%type: [%t? typ] array] -> 80 | if always_nonempty then [%expr Crowbar.(map [list1 [%e expr_of_typ typ]] Array.of_list)] 81 | else [%expr Crowbar.(map [list [%e expr_of_typ typ]] Array.of_list)] 82 | | [%type: [%t? typ] lazy_t] 83 | | [%type: [%t? typ] Lazy.t] -> 84 | [%expr Crowbar.(map [[%e expr_of_typ typ]] (fun a -> lazy a))] 85 | | [%type: ([%t? ok_t], [%t? err_t]) result] 86 | | [%type: ([%t? ok_t], [%t? err_t]) Result.result] -> 87 | [%expr Crowbar.(map [bool; [%e expr_of_typ ok_t]; [%e expr_of_typ err_t]] 88 | (fun b x y -> 89 | if b then (Result.Ok x) 90 | else (Result.Error y) 91 | )) 92 | ] 93 | 94 | | _ -> 95 | let fwd = app (Exp.ident (mknoloc (Ppx_deriving.mangle_lid mangler lid))) 96 | (List.map expr_of_typ args) 97 | in 98 | let matches (loc, _) = (0 = String.compare loc.txt unlazify_attribute_name) in 99 | match List.exists matches typ.ptyp_attributes with 100 | | true -> [%expr Crowbar.unlazy [%e fwd]] 101 | | false -> [%expr [%e fwd]] 102 | end 103 | | { ptyp_desc = Ptyp_tuple tuple } -> 104 | let gens, vars_to_tuple = generate_tuple always_nonempty quoter tuple in 105 | [%expr Crowbar.(map [%e (make_crowbar_list gens)] [%e vars_to_tuple])] 106 | | { ptyp_desc = Ptyp_var name } -> Ast_convenience.evar ("poly_"^name) 107 | | { ptyp_desc = Ptyp_alias (typ, _) } -> expr_of_typ typ 108 | | { ptyp_desc = Ptyp_variant (fields, openness, labels);ptyp_loc} -> 109 | (* I think we don't care about open vs closed, we just want to wrap thee 110 | things in the right rows; similarly we don't care about labels *) 111 | (* just like for non-poly variants, we need to choose from the set of 112 | available things (which we can't get more clues about than this here 113 | typedef... hm, unless the labels are clues, actually; TODO think 114 | about that a bit more, I think they're not but make sure). *) 115 | let translate = function 116 | | Rinherit typ -> expr_of_typ typ 117 | | Rtag (label, attrs, _, []) -> 118 | (* nullary, just use the label name *) 119 | [%expr Crowbar.const [%e Ast_helper.Exp.variant label.txt None]] 120 | | Rtag (label, attrs, _, [{ptyp_desc = Ptyp_tuple tuple}]) -> 121 | (* good ol' tuples *) 122 | let (gens, last_fun) = 123 | generate_tuple always_nonempty quoter 124 | ~constructor:(Ast_helper.Exp.variant label.txt) tuple in 125 | [%expr Crowbar.(map [%e (make_crowbar_list gens)] [%e last_fun])] 126 | | Rtag (label, attrs, _, [typ] (* one non-tuple thing *)) -> 127 | let var = "a" in 128 | let body = Ast_helper.Exp.(variant label.txt 129 | (Some (ident @@ Ast_convenience.lid var))) in 130 | let fn = last_fun var body in 131 | [%expr Crowbar.(map [[%e expr_of_typ typ]] [%e fn])] 132 | 133 | | Rtag (_,_,_,_) -> raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s" 134 | deriver (Ppx_deriving.string_of_core_type typ) 135 | in 136 | let cases = List.map translate fields in 137 | [%expr Crowbar.choose [%e (make_crowbar_list cases)]] 138 | | { ptyp_loc } -> raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s" 139 | deriver (Ppx_deriving.string_of_core_type typ) 140 | and generate_tuple always_nonempty quoter ?constructor tuple = 141 | let vars = n_vars (List.length tuple) [] in 142 | let vars_tuple = List.map Ast_convenience.evar vars |> Ast_convenience.tuple in 143 | let vars_tuple = match constructor with 144 | | Some constructor -> constructor (Some vars_tuple) 145 | | None -> vars_tuple 146 | in 147 | let fn_vars_to_tuple = List.fold_right last_fun vars vars_tuple in 148 | let gens = List.map (expr_of_typ always_nonempty quoter) tuple in 149 | gens, fn_vars_to_tuple 150 | 151 | let core_type_of_decl ~options ~path type_decl = 152 | let typ = Ppx_deriving.core_type_of_type_decl type_decl in 153 | Ppx_deriving.poly_arrow_of_type_decl 154 | (fun var -> [%type: [%t var] Crowbar.gen]) 155 | type_decl 156 | [%type: [%t typ] Crowbar.gen Lazy.t] 157 | 158 | let str_of_type ~options ~path ({ptype_loc = loc } as type_decl) = 159 | let always_nonempty = parse_options options in 160 | let quoter = Ppx_deriving.create_quoter () in 161 | let path = Ppx_deriving.path_of_type_decl ~path type_decl in 162 | (* TODO: generalize this to "a list of things that have a type and attributes" 163 | rather than labels; we could use it more generally *) 164 | let gens_and_fn_of_labels ?name labels = 165 | let gens = labels |> List.map (fun {pld_type; pld_attributes} -> 166 | match attr_generator pld_attributes with 167 | | Some generator -> generator 168 | | None -> expr_of_typ always_nonempty quoter pld_type) in 169 | let vars = n_vars (List.length labels) [] in 170 | let field_assignments = labels |> List.mapi (fun n {pld_name} -> 171 | let lid = Ast_convenience.lid pld_name.txt in 172 | (lid, Ast_helper.Exp.ident @@ Ast_convenience.lid @@ List.nth vars n)) 173 | in 174 | let record = Ast_helper.Exp.record field_assignments None in 175 | let record = match name with 176 | | None -> record 177 | | Some name -> Ast_helper.Exp.construct name (Some record) 178 | in 179 | let fn_vars_to_record = List.fold_right last_fun vars record in 180 | (gens, fn_vars_to_record) 181 | in 182 | let generator = 183 | match attr_generator type_decl.ptype_attributes with 184 | | Some generator -> generator 185 | | None -> 186 | match type_decl.ptype_kind, type_decl.ptype_manifest with 187 | | Ptype_open, _ -> raise_errorf "%s cannot be derived for open type" deriver (* TODO: can we do better? *) 188 | | Ptype_abstract, Some manifest -> 189 | expr_of_typ always_nonempty quoter manifest 190 | | Ptype_abstract, None -> 191 | (* we have a ptype_name foo, so try foo_to_crowbar in the namespace *) 192 | app (Exp.ident (Ast_convenience.lid 193 | (Ppx_deriving.mangle_type_decl mangler type_decl))) 194 | [] 195 | | Ptype_record labels, _ -> (* parsetree.mli promises that this will be a 196 | non-empty list *) 197 | let (gens, fn_vars_to_record) = gens_and_fn_of_labels labels in 198 | [%expr Crowbar.(map [%e (make_crowbar_list gens)] [%e fn_vars_to_record])] 199 | | Ptype_variant constrs, _ -> 200 | let cases = constrs |> 201 | List.map (fun {pcd_attributes; pcd_name; pcd_res; pcd_args} -> 202 | match attr_generator pcd_attributes with 203 | | Some generator -> Ppx_deriving.quote quoter generator 204 | | None -> 205 | (* under what circumstances can pcd_res be non-None and pcd_args be 206 | populated? *) 207 | match pcd_res, pcd_args with 208 | | None, Pcstr_tuple [] -> 209 | 210 | let name = Ast_convenience.constr pcd_name.txt [] in 211 | [%expr Crowbar.(const [%e name])] 212 | | None, Pcstr_tuple tuple -> 213 | let (gens, last_fun) = generate_tuple always_nonempty quoter 214 | ~constructor:( 215 | Ast_helper.Exp.construct @@ Ast_convenience.lid pcd_name.txt) 216 | tuple in 217 | [%expr Crowbar.(map [%e (make_crowbar_list gens)] [%e last_fun])] 218 | | Some core_type, Pcstr_tuple _ | Some core_type, Pcstr_record _ -> 219 | (* C: T0 or C: T1 * ... * Tn -> T0 or C: {...} -> T0 *) 220 | expr_of_typ always_nonempty quoter core_type 221 | | None, Pcstr_record labels -> 222 | (* C of {...} or C of {...} as t *) 223 | let gens, fn_vars_to_record = gens_and_fn_of_labels 224 | ~name:(Ast_convenience.lid pcd_name.txt) labels in 225 | [%expr Crowbar.(map [%e (make_crowbar_list gens)] [%e fn_vars_to_record])] 226 | ) in 227 | (* we must be sure that there are generators for all of the possible 228 | variant types, and then invoke Crowbar.choose on the list of them. *) 229 | [%expr Crowbar.choose [%e (make_crowbar_list cases)]] 230 | in 231 | let polymorphize = Ppx_deriving.poly_fun_of_type_decl type_decl in 232 | let out_type = Ppx_deriving.strong_type_of_type @@ core_type_of_decl ~options 233 | ~path type_decl in 234 | let generate_var = pvar (Ppx_deriving.mangle_type_decl mangler type_decl) in 235 | [Vb.mk (Pat.constraint_ generate_var out_type) 236 | (Ppx_deriving.sanitize ~quoter (polymorphize (lazify generator))); 237 | ] 238 | 239 | let tag_recursive_for_unlazifying type_decls = 240 | let add_tag core_type = 241 | let loc = Location.mknoloc unlazify_attribute_name in 242 | let payload : Parsetree.payload = 243 | (PStr [(Ast_helper.Str.mk @@ Pstr_eval ([%expr "Crowbar.unlazy"], []))]) in 244 | let new_tag : Parsetree.attribute = loc, payload in 245 | Ast_helper.Typ.attr core_type new_tag 246 | in 247 | let rec tag_on_match (needle : type_declaration) core_type = 248 | let core_type = match core_type.ptyp_desc with 249 | | Ptyp_constr (name, args) -> 250 | (* need to tag the top-level thing too, if it matches *) 251 | let core_type = 252 | let full_name l = Longident.flatten l |> String.concat "." in 253 | if (0 = String.compare (full_name name.txt) needle.ptype_name.txt) 254 | then add_tag core_type 255 | else core_type 256 | in 257 | {core_type with ptyp_desc = 258 | Ptyp_constr (name, List.map (tag_on_match needle) args)} 259 | | Ptyp_tuple l -> {core_type with ptyp_desc = 260 | Ptyp_tuple (List.map (tag_on_match needle) l)} 261 | | Ptyp_variant (fields, openness, labels) -> 262 | let dig = function 263 | | Rinherit _ as a -> a 264 | | Rtag (a, b, c, d) -> Rtag (a, b, c, List.map (tag_on_match needle) d) 265 | in 266 | {core_type with ptyp_desc = 267 | Ptyp_variant ((List.map dig fields), openness, labels)} 268 | 269 | | _ -> core_type 270 | in 271 | if (0 = String.compare (Ppx_deriving.string_of_core_type core_type) needle.ptype_name.txt) 272 | then add_tag core_type 273 | else core_type 274 | in 275 | let rec descender needle type_decl = 276 | match type_decl.ptype_kind, type_decl.ptype_manifest with 277 | | Ptype_abstract, Some manifest -> 278 | {type_decl with ptype_manifest = Some (tag_on_match needle manifest) } 279 | | Ptype_abstract, None -> type_decl 280 | | Ptype_record labels, _ -> 281 | let check label = { label with pld_type = (tag_on_match needle label.pld_type)} in 282 | let labels = List.map check labels in 283 | {type_decl with ptype_kind = (Ptype_record labels)} 284 | | Ptype_variant constrs, _ -> 285 | let constrs = constrs |> List.map @@ fun constr -> 286 | match constr.pcd_res with 287 | | Some core_type -> {constr with pcd_res = Some (tag_on_match needle core_type)} 288 | | None -> match constr.pcd_args with 289 | | Pcstr_tuple tuple -> 290 | { constr with pcd_args = Pcstr_tuple (List.map (tag_on_match needle) tuple) } 291 | | Pcstr_record labels -> 292 | let check label = { label with 293 | pld_type = (tag_on_match needle label.pld_type)} 294 | in 295 | { constr with pcd_args = Pcstr_record (List.map check labels)} 296 | in 297 | {type_decl with ptype_kind = (Ptype_variant constrs)} 298 | | Ptype_open, _ -> type_decl (* TODO: I don't know what else we could do here *) 299 | in 300 | (* each top-level element in the list has to be fully considered with respect 301 | to both itself and other items *) 302 | List.fold_left (fun l needle -> List.map (descender needle) l) type_decls type_decls 303 | 304 | let unlazify type_decl = 305 | let name = Ppx_deriving.mangle_type_decl mangler type_decl in 306 | let fn_name_ident = Exp.ident (Ast_convenience.lid name) in 307 | let args = Ppx_deriving.fold_right_type_decl 308 | (fun str args -> (Asttypes.Nolabel, Exp.ident (Ast_convenience.lid 309 | ("poly_"^(str.txt))))::args) 310 | type_decl [] 311 | in 312 | match args with 313 | | [] -> 314 | let lazy_name = Ast_helper.Pat.lazy_ (Ast_helper.Pat.var (mknoloc name)) in 315 | Str.value Nonrecursive [Vb.mk lazy_name (Ast_convenience.evar name)] 316 | | args -> 317 | let apply_fn = Exp.apply fn_name_ident args in 318 | (* TODO: we assume Lazy has not been shadowed :/ *) 319 | let lazy_fn = Exp.apply (Exp.ident (Ast_convenience.lid "Lazy.force")) 320 | [Asttypes.Nolabel, apply_fn] in 321 | let polymorphize = Ppx_deriving.poly_fun_of_type_decl type_decl in 322 | Str.value Nonrecursive [Vb.mk (pvar name) (polymorphize lazy_fn)] 323 | 324 | let deriver = Ppx_deriving.create deriver 325 | ~core_type:(Ppx_deriving.with_quoter 326 | (fun quoter typ -> expr_of_typ false quoter typ)) 327 | ~type_decl_str:(fun ~options ~path type_decls -> 328 | let type_decls = tag_recursive_for_unlazifying type_decls in 329 | let bodies = List.concat (List.map (str_of_type ~options ~path) type_decls) in 330 | (Str.value Recursive bodies) :: 331 | (List.map unlazify type_decls)) 332 | () 333 | 334 | let () = Ppx_deriving.register deriver 335 | -------------------------------------------------------------------------------- /src/ppx_deriving_crowbar_runtime.ml: -------------------------------------------------------------------------------- 1 | include Ppx_deriving_runtime 2 | -------------------------------------------------------------------------------- /src/ppx_deriving_crowbar_runtime.mli: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/yomimono/ppx_deriving_crowbar/6cadd0eba685ff0283374d49d3d819c6a806370c/src/ppx_deriving_crowbar_runtime.mli -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test) 3 | (libraries crowbar) 4 | (preprocess (pps ppx_deriving_crowbar)) 5 | (flags :standard -w a@5@8@10@11@12@14@23@24@26@29@40) 6 | ) 7 | -------------------------------------------------------------------------------- /test/test.expected: -------------------------------------------------------------------------------- 1 | everything is awesome: PASS 2 | 3 | nothing is bad: PASS 4 | 5 | -------------------------------------------------------------------------------- /test/test.ml: -------------------------------------------------------------------------------- 1 | module Glorn : sig 2 | type snorp 3 | end = struct 4 | type snorp = int 5 | end 6 | 7 | type plot = int [@generator Crowbar.const 1] 8 | [@@deriving crowbar] 9 | 10 | type foo = A of int [@generator (Crowbar.const (A 2))] 11 | | B of int [@generator Crowbar.(map [Crowbar.float] (fun f -> B (int_of_float f)))] 12 | and quux = Q of int | R of foo | D of foo list 13 | [@@deriving crowbar] 14 | 15 | type ploomple = int option * float * bool ref 16 | [@generator Crowbar.const (None, 4., ref false)] 17 | [@@deriving crowbar] 18 | 19 | type strorple = [ 20 | `Thorcla of string 21 | | `Mlorstri of int 22 | ] and clist = [ 23 | `Omon 24 | | `Kilder of bool * strorple list 25 | ] [@@deriving crowbar] 26 | 27 | let q = `Thorcla "spiders" 28 | 29 | type knorp = { 30 | a : float [@generator Crowbar.const 4.] 31 | } 32 | [@@deriving crowbar] 33 | 34 | type fkeen = | A of int 35 | and meep = | B of fkeen 36 | [@@deriving crowbar] 37 | 38 | module Rdjeimbo = struct 39 | type homp = (int * float) 40 | and pnorst = (homp * int) 41 | and knipp = (string * pnorst) 42 | and florn = | Fjnie of knipp 43 | [@@deriving crowbar] 44 | 45 | type t = pnorst * homp [@@deriving crowbar] 46 | end 47 | 48 | module Clorstro = struct 49 | type t = [ `Morgthorp of Rdjeimbo.t ] [@@deriving crowbar] 50 | end 51 | 52 | type bar = { 53 | justice: bool; 54 | purrs: int array; 55 | fangs: ploomple; 56 | clorntro: string Lazy.t; 57 | rejweo: quux; 58 | } 59 | [@@deriving crowbar] 60 | 61 | type clippy = | A of int | B of {a: int; b: float} 62 | [@@deriving crowbar] 63 | 64 | type oops = (int, string) result 65 | [@@deriving crowbar] 66 | 67 | type disaster = | A of (int, string) result 68 | [@@deriving crowbar] 69 | 70 | type oh_no = ((int * float), string) result 71 | [@@deriving crowbar] 72 | 73 | type hlifd = {b: (int, string) result;} 74 | [@@deriving crowbar] 75 | 76 | type 'a norple = { 77 | kwijwor : int; 78 | nipstel : 'a; 79 | } 80 | and pune = | A 81 | and plongle = pune norple 82 | [@@deriving crowbar] 83 | 84 | type krord = 85 | | Empty 86 | | Nonempty of hlifd list [@generator Crowbar.(map [list1 hlifd_to_crowbar] (fun l -> Nonempty l))] 87 | [@@deriving crowbar] 88 | 89 | type stdord = 90 | | Empty 91 | | Nonempty of hlifd list 92 | [@@deriving crowbar { nonempty = true }] 93 | 94 | let () = 95 | Crowbar.(add_test ~name:"everything is awesome" 96 | [foo_to_crowbar; bar_to_crowbar; quux_to_crowbar] 97 | (fun foo _bar _quux -> check @@ match foo with 98 | | A 2 -> true 99 | | A i -> false 100 | | _ -> true 101 | )); 102 | Crowbar.(add_test ~name:"nothing is bad" 103 | [stdord_to_crowbar] (function 104 | | Nonempty [] -> Crowbar.fail "ugh" 105 | | _ -> ())); 106 | --------------------------------------------------------------------------------