├── .gitignore ├── .ocamlformat ├── CHANGES.md ├── CONTRIBUTING.md ├── LICENSE.md ├── README.md ├── dune ├── dune-project ├── ppx_deriving_ezjsonm.opam ├── ppx_deriving_yaml.opam ├── src ├── common │ ├── dune │ ├── ppx_deriving_yaml_common.ml │ └── ppx_deriving_yaml_common.mli ├── ezjsonm │ ├── dune │ ├── index.mld │ └── ppx_deriving_ezjsonm.ml └── yaml │ ├── dune │ ├── index.mld │ └── ppx_deriving_yaml.ml └── test ├── dune ├── expect_ezjsonm ├── LICENSE.md ├── dune ├── errors │ ├── dune │ ├── dune.inc │ ├── err.expected │ ├── err.ml │ └── pp.ml ├── gen_rules.ml └── passing │ ├── dune │ ├── dune.inc │ ├── pp.ml │ ├── recursive.expected │ ├── recursive.ml │ ├── simple.expected │ ├── simple.ml │ ├── skip_unknown.expected │ └── skip_unknown.ml ├── expect_yaml ├── LICENSE.md ├── dune ├── errors │ ├── dune │ ├── dune.inc │ ├── err.expected │ ├── err.ml │ └── pp.ml ├── gen_rules.ml └── passing │ ├── dune │ ├── dune.inc │ ├── pp.ml │ ├── recursive.expected │ ├── recursive.ml │ ├── simple.expected │ ├── simple.ml │ ├── skip_unknown.expected │ └── skip_unknown.ml └── test.ml /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | /_opam 3 | .vscode 4 | .merlin 5 | example -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | version=0.26.2 2 | break-infix=fit-or-vertical 3 | parse-docstrings=true 4 | indicate-multiline-delimiters=no -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | ## v0.4.0 (17/11/2024) Cambridge 2 | 3 | - Refactor library to support ppx_deriving_ezjsonm (a JSON backend) (#59, @patricoferris) 4 | 5 | ## v0.3.0 (06/05/2024) Cambridge 6 | 7 | - Fix bug with unused infix operators (#56, @patricoferris) 8 | - Stdlib.( = ) is also used now so other stdlibs work (#55, @andreypopp) 9 | 10 | ## v0.2.3 (27/04/2024) Marrakesh 11 | 12 | - Prefix `Stdlib.` to standard library modules so other stdlibs work (#53, @andreypopp) 13 | 14 | ## v0.2.2 (05/01/2024) Cambridge 15 | 16 | - Embed errors in the AST (#51, @patricoferris and special thanks to @panglesd 17 | for the detailed issue in #48) 18 | 19 | ## v0.2.1 (04/12/2022) Cambridge 20 | 21 | - Support types with recursive definitions (#46, @patricoferris) 22 | - Fix `skip_unknown` flag when unknown fields are not last in the record (#43, @code-ghalib) 23 | 24 | ## v0.2.0 (14/10/2022) 25 | 26 | - Add custom `to_yaml` and `of_yaml` attributes (#38, @patricoferris) 27 | - Add `skip_unknown` flag to allow partially decoding yaml (#40, @code-ghalib) 28 | - Hide record fields with default values in to_yaml output (#37, @maurobringolf, reviewed by @sim642 and @patricoferris) 29 | - Expose `to_yaml` and `of_yaml` derivers with `yaml` being an alias (#36, @patricoferris) 30 | - Improved error messages (#32, @prosper74, reviewed by @patricoferris) 31 | - Add a default attribute for providing placeholder values (#31, @prosper74, reviewed by @ayc9, @pitag-ha and @patricoferris) 32 | 33 | ## v0.1.1 (28/02/2022) 34 | 35 | - Remove rresult dependency (#27, @patricoferris) 36 | 37 | ## v0.1.0 38 | 39 | - Initial public release 40 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # Contributing 2 | 3 | ## OCaml and opam 4 | 5 | After following [these instructions for setting up OCaml with opam](https://v3.ocaml.org/docs/up-and-running) you should be in a position to start building this 6 | repository. Refer to the following section for cloning the repository using git. 7 | 8 | Once you have that set up to install the dependencies you can run 9 | 10 | ``` 11 | opam install . --deps-only --with-test 12 | ``` 13 | 14 | This will install the main dependencies along with any we will need for running the tests. The build the project after opam has finished installing everything run: 15 | 16 | ``` 17 | dune build 18 | ``` 19 | 20 | And to run the tests (which are in the `test` directory) run: 21 | 22 | ``` 23 | dune runtest 24 | ``` 25 | 26 | There is a directory called `test/expect`. This is borrowed from the [repr](https://github.com/mirage/repr) ppx and allows you to write tests that generate the actual post-processed OCaml code and saves them to files. All you need to do is add a test with some `` as `name.ml` in the directory and an empty file called `.expected`. Then run `dune runtest` which should show you code that dune wants to promote to the file, if it looks good you can run `dune promote` and commit the results. 27 | 28 | After making changes to the code please also run the formatter to maintain a common style across the codebase. You can achieve this by running the following command: 29 | 30 | ``` 31 | dune build @fmt --auto 32 | ``` 33 | 34 | To run this command without any error, you might need to install the correct version of `ocamlformat`. The `.ocamlformat` file records the current version the repository uses. Install this version by running: 35 | 36 | ``` 37 | opam install ocamlformat=X.XX.X 38 | ``` 39 | 40 | where, `X.XX.X` denotes the version in the `.ocamlformat` file. *For example*, if the `0.20.1` version of `ocamlformat` has to be installed, then you must run `opam install ocamlformat=0.20.1`. To know more, kindly visit [OCamlFormat](https://github.com/ocaml-ppx/ocamlformat). 41 | 42 | If you hit any problems please feel free to open an issue. 43 | 44 | ## Git and GitHub workflow 45 | 46 | The preferred workflow for contributing to a repository is to fork the main repository on GitHub, clone, and develop on a new branch. 47 | 48 | If you aren't familiar with how to work with Github or would like to learn it, here is [a great tutorial](https://app.egghead.io/playlists/how-to-contribute-to-an-open-source-project-on-github). 49 | 50 | Feel free to use any approach while creating a pull request. Here are a few suggestions from the dev team: 51 | 52 | - If you are not sure whether your changes will be accepted or want to discuss the method before delving into it, please create an issue and ask it. 53 | - Clone the repo locally (or continue editing directly in github if the change is small). Checkout 54 | out the branch that you created. 55 | - Create a draft pull request with a small initial commit. Here's how you can [create a draft pull request.](https://github.blog/2019-02-14-introducing-draft-pull-requests/) 56 | - Continue developing, feel free to ask questions in the PR, if you run into obstacles or uncertainty as you make changes 57 | - Review your implementation according to the checks noted in the PR template 58 | - Once you feel your branch is ready, change the PR status to "ready to review" 59 | - Consult the tasks noted in the PR template 60 | - When merging, consider cleaning up the commit body 61 | - Close any issues that were addressed by this PR. -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | Copyright (c) 2020 Patrick Ferris 2 | 3 | Permission to use, copy, modify, and distribute this software for any 4 | purpose with or without fee is hereby granted, provided that the above 5 | copyright notice and this permission notice appear in all copies. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 8 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 9 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 10 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 11 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 12 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 13 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Derivers for Yaml and JSON 2 | 3 | This repository contains the source code for: 4 | 5 | - `ppx_deriving_yaml` a ppx deriver for generating conversion functions for Yaml. 6 | - `ppx_deriving_ezjsonm` a ppx deriver for generating conversation functions for JSON (using the [Ezjsonm][] library). 7 | 8 | ## Installation 9 | 10 | You may need to update your opam-repository. 11 | 12 | ```sh 13 | opam update 14 | opam install ppx_deriving_yaml # For the Yaml deriver 15 | opam install ppx_deriving_ezjsonm # For the Ezjsonm deriver 16 | ``` 17 | 18 | ## Documentation 19 | 20 | The release documentation should be available on the OCaml.org website at https://ocaml.org/p/ppx_deriving_yaml 21 | and https://ocaml.org/p/ppx_deriving_ezjsonm. 22 | 23 | [The latest documentation is available here](https://patricoferris.github.io/ppx_deriving_yaml). 24 | 25 | The documentation contains sample programs. 26 | 27 | 28 | [Ezjsonm]: https://ocaml.org/p/ezjsonm 29 | -------------------------------------------------------------------------------- /dune: -------------------------------------------------------------------------------- 1 | (env 2 | (dev 3 | (flags 4 | (:standard -w -69)))) 5 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.14) 2 | 3 | (name ppx_deriving_yaml) 4 | 5 | (generate_opam_files true) 6 | 7 | (source 8 | (github patricoferris/ppx_deriving_yaml)) 9 | 10 | (license ISC) 11 | 12 | (authors "Patrick Ferris") 13 | 14 | (maintainers "patrick@sirref.org") 15 | 16 | (package 17 | (name ppx_deriving_yaml) 18 | (synopsis "Yaml PPX") 19 | (description "Deriving conversion functions to and from yaml for your OCaml types.") 20 | (tags ("ppx" "deriver" "yaml")) 21 | (depends 22 | yaml 23 | (alcotest :with-test) 24 | (mdx (and :with-test (>= 2.4.1))) 25 | (ppx_deriving :with-test) ; dune still puts this in META file ... 26 | (ocaml 27 | (>= 4.08.1)) 28 | (ppxlib 29 | (>= 0.25.0)) 30 | )) 31 | 32 | (package 33 | (name ppx_deriving_ezjsonm) 34 | (synopsis "Ezjsonm PPX") 35 | (description "Deriving conversion functions to and from JSON for your OCaml types.") 36 | (tags ("ppx" "deriver" "json")) 37 | (depends 38 | ezjsonm 39 | (alcotest :with-test) 40 | (mdx (and :with-test (>= 2.4.1))) 41 | (ppx_deriving :with-test) ; dune still puts this in META file ... 42 | (ocaml 43 | (>= 4.08.1)) 44 | (ppxlib 45 | (>= 0.25.0)) 46 | )) 47 | 48 | (using mdx 0.3) 49 | -------------------------------------------------------------------------------- /ppx_deriving_ezjsonm.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Ezjsonm PPX" 4 | description: 5 | "Deriving conversion functions to and from JSON for your OCaml types." 6 | maintainer: ["patrick@sirref.org"] 7 | authors: ["Patrick Ferris"] 8 | license: "ISC" 9 | tags: ["ppx" "deriver" "json"] 10 | homepage: "https://github.com/patricoferris/ppx_deriving_yaml" 11 | bug-reports: "https://github.com/patricoferris/ppx_deriving_yaml/issues" 12 | depends: [ 13 | "dune" {>= "3.14"} 14 | "ezjsonm" 15 | "alcotest" {with-test} 16 | "mdx" {with-test & >= "2.4.1"} 17 | "ppx_deriving" {with-test} 18 | "ocaml" {>= "4.08.1"} 19 | "ppxlib" {>= "0.25.0"} 20 | "odoc" {with-doc} 21 | ] 22 | build: [ 23 | ["dune" "subst"] {dev} 24 | [ 25 | "dune" 26 | "build" 27 | "-p" 28 | name 29 | "-j" 30 | jobs 31 | "@install" 32 | "@runtest" {with-test} 33 | "@doc" {with-doc} 34 | ] 35 | ] 36 | dev-repo: "git+https://github.com/patricoferris/ppx_deriving_yaml.git" 37 | -------------------------------------------------------------------------------- /ppx_deriving_yaml.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Yaml PPX" 4 | description: 5 | "Deriving conversion functions to and from yaml for your OCaml types." 6 | maintainer: ["patrick@sirref.org"] 7 | authors: ["Patrick Ferris"] 8 | license: "ISC" 9 | tags: ["ppx" "deriver" "yaml"] 10 | homepage: "https://github.com/patricoferris/ppx_deriving_yaml" 11 | bug-reports: "https://github.com/patricoferris/ppx_deriving_yaml/issues" 12 | depends: [ 13 | "dune" {>= "3.14"} 14 | "yaml" 15 | "alcotest" {with-test} 16 | "mdx" {with-test & >= "2.4.1"} 17 | "ppx_deriving" {with-test} 18 | "ocaml" {>= "4.08.1"} 19 | "ppxlib" {>= "0.25.0"} 20 | "odoc" {with-doc} 21 | ] 22 | build: [ 23 | ["dune" "subst"] {dev} 24 | [ 25 | "dune" 26 | "build" 27 | "-p" 28 | name 29 | "-j" 30 | jobs 31 | "@install" 32 | "@runtest" {with-test} 33 | "@doc" {with-doc} 34 | ] 35 | ] 36 | dev-repo: "git+https://github.com/patricoferris/ppx_deriving_yaml.git" 37 | -------------------------------------------------------------------------------- /src/common/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ppx_deriving_yaml_common) 3 | (modules ppx_deriving_yaml_common) 4 | (public_name ppx_deriving_yaml.common) 5 | (libraries ppxlib) 6 | (preprocess 7 | (pps ppxlib.metaquot))) 8 | 9 | (rule 10 | (alias default) 11 | (targets ppx_deriving_ezjsonm_common.ml ppx_deriving_ezjsonm_common.mli) 12 | (deps ppx_deriving_yaml_common.ml ppx_deriving_yaml_common.mli) 13 | (action 14 | (progn 15 | (copy ppx_deriving_yaml_common.ml ppx_deriving_ezjsonm_common.ml) 16 | (copy ppx_deriving_yaml_common.mli ppx_deriving_ezjsonm_common.mli)))) 17 | 18 | (library 19 | (name ppx_deriving_ezjsonm_common) 20 | (modules ppx_deriving_ezjsonm_common) 21 | (public_name ppx_deriving_ezjsonm.common) 22 | (libraries ppxlib) 23 | (preprocess 24 | (pps ppxlib.metaquot))) 25 | -------------------------------------------------------------------------------- /src/common/ppx_deriving_yaml_common.ml: -------------------------------------------------------------------------------- 1 | open Ppxlib 2 | open Ast_helper 3 | open Ast_builder.Default 4 | 5 | module Helpers = struct 6 | let arg n = "arg" ^ string_of_int n 7 | let mkloc txt = { txt; loc = !Ast_helper.default_loc } 8 | 9 | let fold_right f type_decl acc = 10 | let fold f params acc = 11 | List.fold_right 12 | (fun (p, _) acc -> 13 | match p with 14 | | { ptyp_desc = Ptyp_any; _ } -> acc 15 | | { ptyp_desc = Ptyp_var name; _ } -> 16 | let name = { txt = name; loc = p.ptyp_loc } in 17 | f name acc 18 | | _ -> assert false) 19 | params acc 20 | in 21 | fold f type_decl.ptype_params acc 22 | 23 | let poly_fun ~loc typ_decl expr = 24 | fold_right 25 | (fun name expr -> 26 | let name = name.txt in 27 | Exp.fun_ Nolabel None 28 | (Ast_helper.Pat.var { loc; txt = "poly_" ^ name }) 29 | expr) 30 | typ_decl expr 31 | 32 | let ptuple ~loc = function 33 | | [] -> [%pat? ()] 34 | | [ x ] -> x 35 | | xs -> Pat.tuple ~loc xs 36 | 37 | let etuple ~loc = function 38 | | [] -> [%expr ()] 39 | | [ x ] -> x 40 | | xs -> Exp.tuple ~loc xs 41 | 42 | let add_suffix ?(fixpoint = "t") suf lid = 43 | match lid with 44 | | (Lident t | Ldot (_, t)) when t = fixpoint -> suf 45 | | Lident t | Ldot (_, t) -> t ^ "_" ^ suf 46 | | Lapply _ -> assert false 47 | 48 | let mangle_suf ?fixpoint suf lid = 49 | match lid with 50 | | Lident _t -> Lident (add_suffix ?fixpoint suf lid) 51 | | Ldot (p, _t) -> Ldot (p, add_suffix ?fixpoint suf lid) 52 | | Lapply _ -> assert false 53 | 54 | let map_bind ~loc = 55 | [%expr 56 | fun f lst -> 57 | Stdlib.List.fold_left 58 | (fun acc x -> 59 | match acc with 60 | | Stdlib.Ok acc -> f x >>= fun x -> Stdlib.Ok (x :: acc) 61 | | Stdlib.Error e -> Stdlib.Error e) 62 | (Stdlib.Ok []) lst 63 | >>= fun lst -> Stdlib.Ok (Stdlib.List.rev lst)] 64 | end 65 | 66 | let arg = Helpers.arg 67 | 68 | exception Failed_to_derive of location * string 69 | 70 | module type Backend = sig 71 | val backend : string 72 | val typename : string 73 | val suf_to : string 74 | val suf_of : string 75 | 76 | module Attrs : sig 77 | val key : (label_declaration, label) Attribute.t 78 | val name : (constructor_declaration, string) Attribute.t 79 | val default : (label_declaration, expression) Attribute.t 80 | val to_ : (label_declaration, expression) Attribute.t 81 | val of_ : (label_declaration, expression) Attribute.t 82 | end 83 | end 84 | 85 | module Make (B : Backend) = struct 86 | let backend_constructor = 87 | Typ.constr (Located.lident ~loc:Location.none B.typename) [] 88 | 89 | let polymorphic_msg = 90 | let msg = 91 | Rtag 92 | ( { txt = "Msg"; loc = Location.none }, 93 | false, 94 | [ Typ.constr (Located.lident ~loc:Location.none "string") [] ] ) 95 | in 96 | let msg_row = 97 | { prf_desc = msg; prf_attributes = []; prf_loc = Location.none } 98 | in 99 | Typ.variant [ msg_row ] Open None 100 | 101 | let arrow_backend ?result ~loc arg = 102 | let return = 103 | match result with 104 | | Some r -> 105 | Typ.constr (Located.lident ~loc "result") [ r; polymorphic_msg ] 106 | | None -> backend_constructor 107 | in 108 | Typ.arrow Nolabel arg return 109 | 110 | let function_returning_backend ?result ~loc expr arg = 111 | Exp.constraint_ expr (arrow_backend ?result ~loc arg) 112 | 113 | let rec type_to_expr typ = 114 | let loc = typ.ptyp_loc in 115 | match typ with 116 | | [%type: int] -> [%expr fun (x : int) -> `Float (float_of_int x)] 117 | | [%type: float] -> [%expr fun (x : float) -> `Float x] 118 | | [%type: string] -> [%expr fun (x : string) -> `String x] 119 | | [%type: bool] -> [%expr fun (x : bool) -> `Bool x] 120 | | [%type: char] -> [%expr fun (x : char) -> `String (String.make 1 x)] 121 | | [%type: [%t? typ] list] -> 122 | [%expr fun x -> `A (List.map [%e type_to_expr typ] x)] 123 | | [%type: [%t? typ] array] -> 124 | [%expr fun x -> `A Array.(to_list (map [%e type_to_expr typ]) x)] 125 | | [%type: [%t? typ] option] -> 126 | [%expr function None -> `Null | Some t -> [%e type_to_expr typ] t] 127 | (* When Yaml.value or Ezjsonm.value is found in the type declaration *) 128 | | { ptyp_desc = Ptyp_constr ({ txt = lid; _ }, []); _ } 129 | when Longident.name lid = B.typename -> 130 | [%expr fun x -> x] 131 | | { ptyp_desc = Ptyp_constr ({ txt = lid; _ }, args); _ } -> 132 | let fwd = 133 | function_app 134 | (Exp.ident (Helpers.mkloc (Helpers.mangle_suf B.suf_to lid))) 135 | args 136 | in 137 | [%expr fun x -> [%e fwd] x] 138 | | { ptyp_desc = Ptyp_var name; _ } -> 139 | let ident = Exp.ident (Located.lident ~loc ("poly_" ^ name)) in 140 | function_returning_backend ~loc ident (Typ.any ()) 141 | | { ptyp_desc = Ptyp_poly (names, typ); _ } -> 142 | polymorphic_function names (type_to_expr typ) 143 | | { ptyp_desc = Ptyp_tuple typs; _ } -> 144 | let tuple_pattern = 145 | Pat.tuple 146 | (List.mapi 147 | (fun i t -> Pat.var { loc = t.ptyp_loc; txt = arg i }) 148 | typs) 149 | in 150 | let list_apps = 151 | [%expr 152 | `A 153 | [%e 154 | Ast_builder.Default.elist ~loc 155 | (List.mapi 156 | (fun i t -> 157 | Ast_builder.Default.eapply ~loc (type_to_expr t) 158 | [ Exp.ident (Located.lident ~loc (arg i)) ]) 159 | typs)]] 160 | in 161 | [%expr fun [%p tuple_pattern] -> [%e list_apps]] 162 | | { ptyp_desc = Ptyp_variant (row_fields, _, _); _ } -> ( 163 | let cases = 164 | let exception Failed_to_derive of location * string in 165 | try 166 | let l = 167 | List.map 168 | (fun (field : row_field) -> 169 | match field.prf_desc with 170 | | Rtag (label, true, []) -> 171 | Exp.case 172 | (Pat.variant label.txt None) 173 | [%expr `O [ ([%e estring ~loc label.txt], `A []) ]] 174 | | Rtag (label, false, [ { ptyp_desc = Ptyp_tuple typs; _ } ]) 175 | -> 176 | Exp.case 177 | (Pat.variant label.txt 178 | (Some 179 | (Helpers.ptuple ~loc 180 | (List.mapi (fun i _ -> pvar ~loc (arg i)) typs)))) 181 | [%expr 182 | `O 183 | [ 184 | ( [%e estring ~loc label.txt], 185 | `A 186 | [%e 187 | elist ~loc 188 | (List.mapi 189 | (fun i t -> 190 | [%expr 191 | [%e type_to_expr t] 192 | [%e evar ~loc (arg i)]]) 193 | typs)] ); 194 | ]] 195 | | Rtag (label, false, [ t ]) -> 196 | Exp.case 197 | (Pat.variant ~loc label.txt (Some (pvar ~loc "x"))) 198 | [%expr 199 | [%e type_to_expr t] [%e evar ~loc "x"] |> fun x -> 200 | `O [ ([%e estring ~loc label.txt], `A [ x ]) ]] 201 | | Rtag (label, _, _) -> 202 | raise (Failed_to_derive (label.loc, "Rtag")) 203 | | Rinherit ctype -> 204 | Exp.case 205 | (Pat.variant ~loc "e" (Some (pvar ~loc "x"))) 206 | (type_to_expr ctype)) 207 | row_fields 208 | in 209 | Ok l 210 | with Failed_to_derive (l, s) -> Error (`Msg (l, s)) 211 | in 212 | match cases with 213 | | Error (`Msg (loc, m)) -> 214 | pexp_extension ~loc @@ Location.error_extensionf ~loc "%s" m 215 | | Ok cases -> Exp.function_ ~loc cases) 216 | | { ptyp_desc = Ptyp_arrow _; _ } -> 217 | pexp_extension ~loc 218 | @@ Location.error_extensionf ~loc "Functions cannot be converted %s" 219 | B.backend 220 | | { ptyp_desc = Ptyp_object _; _ } -> 221 | pexp_extension ~loc 222 | @@ Location.error_extensionf ~loc "Objects cannot be converted %s" 223 | B.backend 224 | | { ptyp_desc = Ptyp_class _; _ } -> 225 | pexp_extension ~loc 226 | @@ Location.error_extensionf ~loc "Classes cannot be converted %s" 227 | B.backend 228 | | { ptyp_desc = Ptyp_any; _ } -> 229 | pexp_extension ~loc 230 | @@ Location.error_extensionf ~loc "Any cannot be converted %s" B.backend 231 | | { ptyp_desc = Ptyp_package _; _ } -> 232 | pexp_extension ~loc 233 | @@ Location.error_extensionf ~loc "Packages cannot be converted %s" 234 | B.backend 235 | | { ptyp_desc = Ptyp_alias _; _ } -> 236 | pexp_extension ~loc 237 | @@ Location.error_extensionf ~loc "Aliases cannot be converted %s" 238 | B.backend 239 | | { ptyp_desc = Ptyp_extension _; _ } -> 240 | pexp_extension ~loc 241 | @@ Location.error_extensionf ~loc "Extensions cannot be converted %s" 242 | B.backend 243 | 244 | and function_app f l = 245 | if l = [] then f 246 | else 247 | Exp.apply f (List.map (fun e -> (Nolabel, e)) (List.map type_to_expr l)) 248 | 249 | and polymorphic_function names expr = 250 | List.fold_right 251 | (fun name expr -> 252 | let loc = name.Location.loc in 253 | let name = name.Location.txt in 254 | let arg = Pat.var { loc; txt = "poly_" ^ name } in 255 | [%expr fun [%p arg] -> [%e expr]]) 256 | names expr 257 | 258 | let record_to_expr ~typ ~loc fields = 259 | let fields_to_expr fs = 260 | List.map 261 | (fun ({ pld_name; pld_type; pld_loc; _ } as pld) -> 262 | let name = 263 | Option.value ~default:pld_name.txt (Attribute.get B.Attrs.key pld) 264 | in 265 | let func = 266 | match Attribute.get B.Attrs.to_ pld with 267 | | None -> type_to_expr pld_type 268 | | Some fn -> fn 269 | in 270 | let field = 271 | Exp.field 272 | (Ast_builder.Default.evar ~loc "x") 273 | (Located.lident ~loc pld_name.txt) 274 | in 275 | [%expr 276 | [%e 277 | match Attribute.get B.Attrs.default pld with 278 | | None -> 279 | [%expr 280 | Some 281 | ( [%e Ast_builder.Default.estring ~loc:pld_loc name], 282 | [%e func] [%e field] )] 283 | | Some d -> 284 | [%expr 285 | (fun x -> 286 | if Stdlib.( = ) x [%e d] then None 287 | else 288 | Some 289 | ( [%e Ast_builder.Default.estring ~loc:pld_loc name], 290 | [%e func] x )) 291 | [%e field]]]]) 292 | fs 293 | in 294 | let fs = fields_to_expr fields in 295 | [%expr 296 | fun (x : [%t typ]) -> 297 | `O 298 | (Stdlib.List.filter_map 299 | (fun x -> x) 300 | [%e Ast_builder.Default.elist ~loc fs])] 301 | 302 | let type_decl_to_type type_decl = 303 | let loc = type_decl.ptype_loc in 304 | let t = core_type_of_type_declaration type_decl in 305 | List.fold_right 306 | (fun (param, _) typ -> 307 | match param.ptyp_desc with 308 | | Ptyp_any -> typ 309 | | Ptyp_var name -> 310 | let loc = param.ptyp_loc in 311 | let arg = Typ.var ~loc name in 312 | let func_t = arrow_backend ~loc arg in 313 | [%type: [%t func_t] -> [%t typ]] 314 | | _ -> assert false) 315 | type_decl.ptype_params (arrow_backend ~loc t) 316 | 317 | let type_decl_of_type type_decl = 318 | let loc = type_decl.ptype_loc in 319 | let t = core_type_of_type_declaration type_decl in 320 | List.fold_right 321 | (fun (param, _) typ -> 322 | match param.ptyp_desc with 323 | | Ptyp_any -> typ 324 | | Ptyp_var name -> 325 | let loc = param.ptyp_loc in 326 | let arg = Typ.var ~loc name in 327 | let func_t = arrow_backend ~result:arg ~loc backend_constructor in 328 | [%type: [%t func_t] -> [%t typ]] 329 | | _ -> assert false) 330 | type_decl.ptype_params 331 | (arrow_backend ~result:t ~loc backend_constructor) 332 | 333 | let wrap_open_rresult ~loc expr = 334 | [%expr 335 | let[@warning "-26"] ( >>= ) v f = 336 | match v with Ok v -> f v | Error _ as e -> e 337 | in 338 | [%e expr]] 339 | 340 | let mk_pat_match ~loc cases typ = 341 | let cases = 342 | cases 343 | @ [ 344 | ( [%pat? _], 345 | [%expr 346 | Error 347 | (`Msg 348 | [%e 349 | estring ~loc 350 | ("Was expecting '" ^ typ ^ "' but got a different type")])] 351 | ); 352 | ] 353 | in 354 | Exp.function_ (List.map (fun (pat, exp) -> Exp.case pat exp) cases) 355 | 356 | let monad_fold f = 357 | List.fold_left (fun expr (t, i) -> 358 | let loc = expr.pexp_loc in 359 | [%expr 360 | [%e f t] [%e evar ~loc (arg i)] >>= fun [%p pvar ~loc (arg i)] -> 361 | [%e expr]]) 362 | 363 | let rec of_backend_type_to_expr name typ = 364 | let loc = typ.ptyp_loc in 365 | let argument, expr_arg = 366 | match name with 367 | | None -> (Pat.var { loc; txt = "x" }, Exp.ident (Located.lident ~loc "x")) 368 | | Some t -> (Pat.var { loc; txt = t }, Exp.ident (Located.lident ~loc t)) 369 | in 370 | match typ with 371 | | [%type: int] -> 372 | mk_pat_match ~loc 373 | [ 374 | ( [%pat? `Float [%p argument]], 375 | [%expr Ok (int_of_float [%e expr_arg])] ); 376 | ] 377 | "int" 378 | | [%type: float] -> 379 | mk_pat_match ~loc 380 | [ ([%pat? `Float [%p argument]], [%expr Ok [%e expr_arg]]) ] 381 | "float" 382 | | [%type: string] -> 383 | mk_pat_match ~loc 384 | [ ([%pat? `String [%p argument]], [%expr Ok [%e expr_arg]]) ] 385 | "string" 386 | | [%type: bool] -> 387 | mk_pat_match ~loc 388 | [ ([%pat? `Bool [%p argument]], [%expr Ok [%e expr_arg]]) ] 389 | "bool" 390 | | [%type: char] -> 391 | mk_pat_match ~loc 392 | [ ([%pat? `String [%p argument]], [%expr Ok [%e expr_arg].[0]]) ] 393 | "char" 394 | | [%type: [%t? typ] list] -> 395 | mk_pat_match ~loc 396 | [ 397 | ( [%pat? `A lst], 398 | [%expr 399 | let ( >>= ) v f = 400 | match v with Ok v -> f v | Error _ as e -> e 401 | in 402 | [%e Helpers.map_bind ~loc] 403 | [%e of_backend_type_to_expr None typ] 404 | lst] ); 405 | ] 406 | "list" 407 | | [%type: [%t? typ] array] -> 408 | mk_pat_match ~loc 409 | [ 410 | ( [%pat? `A lst], 411 | [%expr 412 | let ( >>= ) v f = 413 | match v with Ok v -> f v | Error _ as e -> e 414 | in 415 | `A 416 | Array.( 417 | to_list ([%e Helpers.map_bind ~loc] [%e type_to_expr typ]))] 418 | ); 419 | ] 420 | "array" 421 | | [%type: [%t? typ] option] -> 422 | [%expr 423 | function 424 | | `Null -> Ok None 425 | | x -> 426 | [%e of_backend_type_to_expr None typ] x >>= fun x -> Ok (Some x)] 427 | | { ptyp_desc = Ptyp_constr ({ txt = lid; _ }, []); _ } 428 | when Longident.name lid = B.typename -> 429 | [%expr fun x -> Ok x] 430 | | { ptyp_desc = Ptyp_constr ({ txt = lid; _ }, args); _ } -> 431 | let fwd = 432 | function_appl 433 | (Exp.ident (Helpers.mkloc (Helpers.mangle_suf B.suf_of lid))) 434 | args 435 | in 436 | [%expr fun x -> [%e fwd] x] 437 | | { ptyp_desc = Ptyp_var name; _ } -> 438 | let ident = Exp.ident (Located.lident ~loc ("poly_" ^ name)) in 439 | [%expr 440 | ([%e ident] 441 | : [%t backend_constructor] -> (_, [> `Msg of string ]) result)] 442 | | { ptyp_desc = Ptyp_poly (names, typ); _ } -> 443 | polymorphic_function names (of_backend_type_to_expr None typ) 444 | | { ptyp_desc = Ptyp_tuple typs; _ } -> 445 | let list_pat = 446 | [%pat? 447 | `A 448 | [%p 449 | plist ~loc 450 | (List.mapi 451 | (fun i t -> Pat.var { loc = t.ptyp_loc; txt = arg i }) 452 | typs)]] 453 | in 454 | let funcs = 455 | List.mapi 456 | (fun i t -> 457 | (i, [%expr [%e of_backend_type_to_expr (Some (arg i)) t]])) 458 | typs 459 | in 460 | let expr = 461 | List.fold_left 462 | (fun acc (i, t) -> 463 | [%expr 464 | [%e t] [%e evar ~loc (arg i)] >>= fun [%p pvar ~loc (arg i)] -> 465 | [%e acc]]) 466 | [%expr 467 | Stdlib.Result.Ok 468 | [%e 469 | Helpers.etuple ~loc 470 | (List.mapi (fun i _ -> evar ~loc (arg i)) typs)]] 471 | funcs 472 | in 473 | wrap_open_rresult ~loc (mk_pat_match ~loc [ (list_pat, expr) ] "null") 474 | | { ptyp_desc = Ptyp_variant (row_fields, _, _); _ } -> 475 | let cases = 476 | List.map 477 | (fun field -> 478 | match field.prf_desc with 479 | | Rtag (name, true, []) -> 480 | Exp.case 481 | [%pat? `O [ ([%p pstring ~loc name.txt], `A []) ]] 482 | [%expr Stdlib.Result.Ok [%e Exp.variant name.txt None]] 483 | | Rtag (name, false, [ { ptyp_desc = Ptyp_tuple typs; _ } ]) -> 484 | let e = 485 | monad_fold 486 | (of_backend_type_to_expr None) 487 | [%expr 488 | Stdlib.Result.Ok 489 | [%e 490 | Exp.variant name.txt 491 | (Some 492 | (Helpers.etuple ~loc 493 | (List.mapi 494 | (fun i _ -> evar ~loc (arg i)) 495 | typs)))]] 496 | (List.mapi (fun i t -> (t, i)) typs) 497 | in 498 | Exp.case 499 | [%pat? 500 | `O 501 | [ 502 | ( [%p pstring ~loc name.txt], 503 | `A 504 | [%p 505 | plist ~loc 506 | (List.mapi 507 | (fun i _ -> pvar ~loc (arg i)) 508 | typs)] ); 509 | ]] 510 | e 511 | | Rtag (name, false, [ t ]) -> 512 | Exp.case 513 | [%pat? `O [ ([%p pstring ~loc name.txt], `A [ x ]) ]] 514 | [%expr 515 | [%e of_backend_type_to_expr None t] x >>= fun x -> 516 | Stdlib.Result.Ok 517 | [%e Exp.variant name.txt (Some (evar ~loc "x"))]] 518 | | _ -> Exp.case [%pat? _] [%expr Error (`Msg "Not implemented")]) 519 | row_fields 520 | in 521 | wrap_open_rresult ~loc 522 | (Exp.function_ ~loc 523 | (cases 524 | @ [ 525 | Exp.case 526 | [%pat? _] 527 | [%expr Error (`Msg "failed converting variant")]; 528 | ])) 529 | | { ptyp_desc = Ptyp_arrow _; _ } -> 530 | pexp_extension ~loc 531 | @@ Location.error_extensionf ~loc "Functions cannot be converted %s" 532 | B.backend 533 | | { ptyp_desc = Ptyp_object _; _ } -> 534 | pexp_extension ~loc 535 | @@ Location.error_extensionf ~loc "Objects cannot be converted %s" 536 | B.backend 537 | | { ptyp_desc = Ptyp_class _; _ } -> 538 | pexp_extension ~loc 539 | @@ Location.error_extensionf ~loc "Classes cannot be converted %s" 540 | B.backend 541 | | { ptyp_desc = Ptyp_any; _ } -> 542 | pexp_extension ~loc 543 | @@ Location.error_extensionf ~loc "Any cannot be converted %s" B.backend 544 | | { ptyp_desc = Ptyp_package _; _ } -> 545 | pexp_extension ~loc 546 | @@ Location.error_extensionf ~loc "Packages cannot be converted %s" 547 | B.backend 548 | | { ptyp_desc = Ptyp_alias _; _ } -> 549 | pexp_extension ~loc 550 | @@ Location.error_extensionf ~loc "Aliases cannot be converted %s" 551 | B.backend 552 | | { ptyp_desc = Ptyp_extension _; _ } -> 553 | pexp_extension ~loc 554 | @@ Location.error_extensionf ~loc "Extensions cannot be converted %s" 555 | B.backend 556 | 557 | and function_appl f l = 558 | if l = [] then f 559 | else 560 | Exp.apply f 561 | (List.map 562 | (fun e -> (Nolabel, e)) 563 | (List.map (of_backend_type_to_expr None) l)) 564 | 565 | and polymorphic_function names expr = 566 | List.fold_right 567 | (fun name expr -> 568 | let loc = name.Location.loc in 569 | let name = name.Location.txt in 570 | let arg = Pat.var { loc; txt = "poly_" ^ name } in 571 | [%expr fun [%p arg] -> [%e expr]]) 572 | names expr 573 | 574 | (** Method used by PPX Deriving Yojson 575 | https://github.com/ocaml-ppx/ppx_deriving_yojson/blob/master/src/ppx_deriving_yojson.ml#L508 576 | The loop goes over the possible key-value pairs in the list and 577 | accumulates the possible values in a list. Once complete whatever the last 578 | value was is used in the construction of the record. *) 579 | 580 | let of_backend_record_to_expr ~loc ~skip_unknown fields = 581 | let monad_binding = 582 | List.fold_left (fun expr i -> 583 | let loc = expr.pexp_loc in 584 | [%expr 585 | [%e evar ~loc (arg i)] >>= fun [%p pvar ~loc (arg i)] -> [%e expr]]) 586 | in 587 | let record = 588 | [%expr 589 | Ok 590 | [%e 591 | Exp.record 592 | (List.mapi 593 | (fun i f -> 594 | (Located.lident ~loc f.pld_name.txt, evar ~loc (arg i))) 595 | fields) 596 | None]] 597 | in 598 | let base_case = monad_binding record (List.mapi (fun i _ -> i) fields) in 599 | let kv_cases = 600 | List.mapi 601 | (fun i f -> 602 | let name = 603 | Option.value ~default:f.pld_name.txt (Attribute.get B.Attrs.key f) 604 | in 605 | let funcs = 606 | List.mapi 607 | (fun j _ -> 608 | if i = j then 609 | match Attribute.get B.Attrs.of_ f with 610 | | Some fn -> eapply ~loc fn [ evar ~loc "x" ] 611 | | None -> 612 | eapply ~loc 613 | (of_backend_type_to_expr None f.pld_type) 614 | [ evar ~loc "x" ] 615 | else evar ~loc (arg j)) 616 | fields 617 | in 618 | Exp.case 619 | [%pat? ([%p pstring ~loc name], x) :: xs] 620 | [%expr loop xs [%e Helpers.etuple ~loc funcs]]) 621 | fields 622 | in 623 | let kv_cases = 624 | kv_cases 625 | @ [ 626 | Exp.case [%pat? []] base_case; 627 | (if skip_unknown then Exp.case [%pat? _ :: xs] [%expr loop xs _state] 628 | else 629 | Exp.case 630 | [%pat? (x, _y) :: _] 631 | [%expr Error (`Msg ("Failed to find the case for: " ^ x))]); 632 | ] 633 | in 634 | let option_to_none t = 635 | match Attribute.get B.Attrs.default t with 636 | | None -> ( 637 | match t.pld_type with 638 | | [%type: [%t? _] option] -> [%expr Ok None] 639 | | _ -> 640 | [%expr 641 | Error 642 | (`Msg 643 | [%e 644 | estring ~loc 645 | ("Didn't find the function for key: " ^ t.pld_name.txt)])] 646 | ) 647 | | Some default -> [%expr Ok [%e default]] 648 | in 649 | let e = 650 | [%expr 651 | function 652 | | `O xs -> 653 | let rec loop xs 654 | ([%p 655 | Helpers.ptuple ~loc 656 | (List.mapi (fun i _ -> pvar ~loc (arg i)) fields)] as 657 | _state) = 658 | [%e Exp.match_ [%expr xs] kv_cases] 659 | in 660 | loop xs 661 | [%e 662 | Helpers.etuple ~loc 663 | (List.map (fun f -> option_to_none f) fields)] 664 | | _ -> 665 | Error (`Msg "Failed building a key-value object expecting a list")] 666 | in 667 | wrap_open_rresult ~loc e 668 | 669 | (* Higher level constructions *) 670 | 671 | let failed_to_derive loc msg = raise (Failed_to_derive (loc, msg)) 672 | 673 | let mangle_name_label suff label = 674 | if label = "t" then suff else label ^ "_" ^ suff 675 | 676 | (* We need to check if a type is recursive or not in it's definition *) 677 | let check_rec_type rec_flag typ = 678 | let check = 679 | object 680 | inherit type_is_recursive rec_flag typ 681 | end 682 | in 683 | check#go 684 | 685 | let generate_impl_of ~ctxt (rec_flag, type_decls) skip_unknown = 686 | let rec_flag = check_rec_type rec_flag type_decls () in 687 | let loc = Expansion_context.Deriver.derived_item_loc ctxt in 688 | List.concat 689 | (List.map 690 | (fun typ_decl -> 691 | match typ_decl with 692 | | { ptype_kind = Ptype_abstract; ptype_manifest; ptype_name; _ } -> ( 693 | match ptype_manifest with 694 | | Some t -> 695 | let ocamliser = 696 | Helpers.poly_fun ~loc:typ_decl.ptype_loc typ_decl 697 | (of_backend_type_to_expr None t) 698 | in 699 | let of_yaml = mangle_name_label B.suf_of ptype_name.txt in 700 | [ 701 | pstr_value ~loc rec_flag 702 | [ 703 | Vb.mk (ppat_var ~loc { loc; txt = of_yaml }) ocamliser; 704 | ]; 705 | ] 706 | | None -> 707 | [ 708 | pstr_value ~loc rec_flag 709 | [ 710 | Vb.mk 711 | (ppat_var ~loc { loc; txt = "error_encountered" }) 712 | (pexp_extension ~loc 713 | @@ Location.error_extensionf ~loc 714 | "Failed to derive something for an abstract \ 715 | type with no manifest!"); 716 | ]; 717 | ]) 718 | | { ptype_kind = Ptype_variant constructors; ptype_name; _ } -> 719 | let of_yaml = mangle_name_label B.suf_of ptype_name.txt in 720 | let of_yaml_cases = 721 | let l = 722 | List.map 723 | (fun ({ pcd_name; pcd_args; _ } as p) -> 724 | let name = 725 | Option.value ~default:pcd_name.txt 726 | (Attribute.get B.Attrs.name p) 727 | in 728 | match pcd_args with 729 | | Pcstr_tuple args -> 730 | let tuple = 731 | if List.length args = 0 then None 732 | else 733 | Some 734 | (Helpers.etuple ~loc 735 | (List.mapi 736 | (fun i _ -> evar ~loc (Helpers.arg i)) 737 | args)) 738 | in 739 | Exp.case 740 | [%pat? 741 | `O 742 | [ 743 | ( [%p pstring ~loc name], 744 | `A 745 | [%p 746 | plist ~loc 747 | (List.mapi 748 | (fun i _ -> 749 | pvar ~loc (Helpers.arg i)) 750 | args)] ); 751 | ]] 752 | (monad_fold 753 | (of_backend_type_to_expr None) 754 | [%expr 755 | Stdlib.Result.Ok 756 | [%e 757 | Exp.construct 758 | { 759 | txt = Lident pcd_name.txt; 760 | loc = pcd_name.loc; 761 | } 762 | tuple]] 763 | (List.mapi (fun i t -> (t, i)) args)) 764 | | _ -> failed_to_derive loc "Failed to derive variant") 765 | constructors 766 | in 767 | Ok l 768 | in 769 | let of_yaml_cases = 770 | match of_yaml_cases with 771 | | Error _ as e -> e 772 | | Ok cases -> 773 | Ok 774 | (cases 775 | @ [ 776 | Exp.case 777 | [%pat? _] 778 | [%expr 779 | Stdlib.Error 780 | (`Msg "no match for this variant expression")]; 781 | ]) 782 | in 783 | let of_yaml_expr = 784 | match of_yaml_cases with 785 | | Error (loc, msg) -> 786 | pexp_extension ~loc 787 | @@ Location.error_extensionf ~loc "%s" msg 788 | | Ok of_yaml_cases -> 789 | wrap_open_rresult ~loc (Exp.function_ ~loc of_yaml_cases) 790 | in 791 | [ 792 | pstr_value ~loc rec_flag 793 | [ Vb.mk (ppat_var ~loc { loc; txt = of_yaml }) of_yaml_expr ]; 794 | ] 795 | | { ptype_kind = Ptype_record fields; ptype_loc; ptype_name; _ } -> 796 | let of_yaml = mangle_name_label B.suf_of ptype_name.txt in 797 | [ 798 | pstr_value ~loc rec_flag 799 | [ 800 | Vb.mk 801 | (ppat_var ~loc { loc; txt = of_yaml }) 802 | (Helpers.poly_fun ~loc:ptype_loc typ_decl 803 | (of_backend_record_to_expr ~skip_unknown 804 | ~loc:ptype_loc fields)); 805 | ]; 806 | ] 807 | | _ -> 808 | [ 809 | pstr_value ~loc rec_flag 810 | [ 811 | Vb.mk (ppat_var ~loc { loc; txt = "error" }) 812 | @@ pexp_extension ~loc 813 | @@ Location.error_extensionf ~loc 814 | "Cannot derive anything for this type"; 815 | ]; 816 | ]) 817 | type_decls) 818 | 819 | let vb_error loc msg = 820 | [ 821 | pstr_value ~loc Nonrecursive 822 | [ 823 | Vb.mk 824 | (ppat_var ~loc { loc; txt = "error_encountered" }) 825 | (pexp_extension ~loc @@ Location.error_extensionf ~loc "%s" msg); 826 | ]; 827 | ] 828 | 829 | let generate_impl_to ~ctxt (rec_flag, type_decls) = 830 | let rec_flag = check_rec_type rec_flag type_decls () in 831 | let loc = Expansion_context.Deriver.derived_item_loc ctxt in 832 | List.concat 833 | (List.map 834 | (fun typ_decl -> 835 | match typ_decl with 836 | | { ptype_kind = Ptype_abstract; ptype_manifest; ptype_name; _ } -> ( 837 | match ptype_manifest with 838 | | Some t -> 839 | let yamliser = 840 | Helpers.poly_fun ~loc:typ_decl.ptype_loc typ_decl 841 | (type_to_expr t) 842 | in 843 | let to_yaml = mangle_name_label B.suf_to ptype_name.txt in 844 | [ 845 | pstr_value ~loc rec_flag 846 | [ Vb.mk (ppat_var ~loc { loc; txt = to_yaml }) yamliser ]; 847 | ] 848 | | None -> vb_error loc "Cannot derive anything for this type") 849 | | { ptype_kind = Ptype_variant constructors; ptype_name; _ } -> 850 | let to_yaml = mangle_name_label B.suf_to ptype_name.txt in 851 | let to_yaml_cases = 852 | try 853 | let l = 854 | List.map 855 | (fun ({ pcd_name; pcd_args; _ } as p) -> 856 | let name = 857 | Option.value ~default:pcd_name.txt 858 | (Attribute.get B.Attrs.name p) 859 | in 860 | match pcd_args with 861 | | Pcstr_tuple args -> 862 | let pat_arg = 863 | if List.length args = 0 then None 864 | else 865 | Some 866 | (Helpers.ptuple ~loc 867 | (List.mapi 868 | (fun i _ -> pvar ~loc (Helpers.arg i)) 869 | args)) 870 | in 871 | Exp.case (pconstruct p pat_arg) 872 | [%expr 873 | `O 874 | [ 875 | ( [%e estring ~loc name], 876 | `A 877 | [%e 878 | elist ~loc 879 | (List.mapi 880 | (fun i t -> 881 | [%expr 882 | [%e type_to_expr t] 883 | [%e 884 | evar ~loc 885 | (Helpers.arg i)]]) 886 | args)] ); 887 | ]] 888 | | _ -> failwith "Not implemented!") 889 | constructors 890 | in 891 | Ok l 892 | with Failed_to_derive (loc, msg) -> Error (`Msg (loc, msg)) 893 | in 894 | let to_yaml_expr = 895 | match to_yaml_cases with 896 | | Error (`Msg (loc, msg)) -> 897 | pexp_extension ~loc 898 | @@ Location.error_extensionf ~loc "%s" msg 899 | | Ok to_yaml_cases -> Exp.function_ ~loc to_yaml_cases 900 | in 901 | [ 902 | pstr_value ~loc rec_flag 903 | [ Vb.mk (ppat_var ~loc { loc; txt = to_yaml }) to_yaml_expr ]; 904 | ] 905 | | { ptype_kind = Ptype_record fields; ptype_loc; ptype_name; _ } -> 906 | let to_yaml = mangle_name_label B.suf_to ptype_name.txt in 907 | [ 908 | pstr_value ~loc rec_flag 909 | [ 910 | Vb.mk 911 | [%pat? [%p ppat_var ~loc { loc; txt = to_yaml }]] 912 | [%expr 913 | [%e 914 | Helpers.poly_fun ~loc:ptype_loc typ_decl 915 | (record_to_expr 916 | ~typ:(core_type_of_type_declaration typ_decl) 917 | ~loc:ptype_loc fields)]]; 918 | ]; 919 | ] 920 | | _ -> vb_error loc "Cannot derive anything for this type") 921 | type_decls) 922 | 923 | let generate_intf_to ~ctxt (_rec_flag, type_decls) : 924 | Ppxlib.Ast.signature_item list = 925 | let loc = Expansion_context.Deriver.derived_item_loc ctxt in 926 | List.map 927 | (fun typ_decl -> 928 | match typ_decl with 929 | | { ptype_kind = Ptype_abstract | Ptype_record _; _ } -> 930 | [ 931 | psig_value ~loc 932 | (Val.mk 933 | { 934 | loc = typ_decl.ptype_name.loc; 935 | txt = mangle_name_label B.suf_to typ_decl.ptype_name.txt; 936 | } 937 | (type_decl_to_type typ_decl)); 938 | ] 939 | | _ -> 940 | [ 941 | psig_value ~loc 942 | (Val.mk 943 | { loc; txt = "error_encountered" } 944 | (ptyp_extension ~loc 945 | @@ Location.error_extensionf ~loc 946 | "Cannot derived\n anything")); 947 | ]) 948 | type_decls 949 | |> List.concat 950 | 951 | let generate_intf_of ~ctxt (_rec_flag, type_decls) : 952 | Ppxlib.Ast.signature_item list = 953 | let loc = Expansion_context.Deriver.derived_item_loc ctxt in 954 | List.map 955 | (fun typ_decl -> 956 | match typ_decl with 957 | | { ptype_kind = Ptype_abstract | Ptype_record _; _ } -> 958 | [ 959 | psig_value ~loc 960 | (Val.mk 961 | { 962 | loc = typ_decl.ptype_name.loc; 963 | txt = mangle_name_label B.suf_of typ_decl.ptype_name.txt; 964 | } 965 | (type_decl_of_type typ_decl)); 966 | ] 967 | | _ -> 968 | [ 969 | psig_value ~loc 970 | (Val.mk 971 | { loc; txt = "error_encountered" } 972 | (ptyp_extension ~loc 973 | @@ Location.error_extensionf ~loc 974 | "Cannot derived\n anything")); 975 | ]) 976 | type_decls 977 | |> List.concat 978 | 979 | let impl_generator_to impl = 980 | let open B in 981 | Deriving.Generator.V2.make_noarg 982 | ~attributes: 983 | [ 984 | Attribute.T Attrs.default; 985 | Attribute.T Attrs.name; 986 | Attribute.T Attrs.key; 987 | ] 988 | impl 989 | 990 | let impl_generator_of impl = 991 | let open B in 992 | Deriving.Generator.V2.make 993 | ~attributes: 994 | [ 995 | Attribute.T Attrs.default; 996 | Attribute.T Attrs.name; 997 | Attribute.T Attrs.key; 998 | ] 999 | Deriving.Args.(empty +> flag "skip_unknown") 1000 | impl 1001 | end 1002 | -------------------------------------------------------------------------------- /src/common/ppx_deriving_yaml_common.mli: -------------------------------------------------------------------------------- 1 | open Ppxlib 2 | (** {1 Functions for converting OCaml types to Yaml.value types} *) 3 | 4 | module type Backend = sig 5 | val backend : string 6 | val typename : string 7 | val suf_to : string 8 | val suf_of : string 9 | 10 | module Attrs : sig 11 | val key : (label_declaration, label) Attribute.t 12 | val name : (constructor_declaration, string) Attribute.t 13 | val default : (label_declaration, expression) Attribute.t 14 | val to_ : (label_declaration, expression) Attribute.t 15 | val of_ : (label_declaration, expression) Attribute.t 16 | end 17 | end 18 | 19 | module Make (_ : Backend) : sig 20 | val type_to_expr : core_type -> expression 21 | 22 | val record_to_expr : 23 | typ:core_type -> loc:Location.t -> label_declaration list -> expression 24 | 25 | val type_decl_to_type : type_declaration -> core_type 26 | val type_decl_of_type : type_declaration -> core_type 27 | val of_backend_type_to_expr : string option -> core_type -> expression 28 | 29 | val of_backend_record_to_expr : 30 | loc:Location.t -> skip_unknown:bool -> label_declaration list -> expression 31 | 32 | val monad_fold : 33 | ('a -> expression) -> expression -> ('a * int) list -> expression 34 | 35 | val wrap_open_rresult : loc:location -> expression -> expression 36 | 37 | val generate_impl_to : 38 | ctxt:Expansion_context.Deriver.t -> 39 | rec_flag * type_declaration list -> 40 | structure_item list 41 | 42 | val generate_impl_of : 43 | ctxt:Expansion_context.Deriver.t -> 44 | rec_flag * type_declaration list -> 45 | bool -> 46 | structure_item list 47 | 48 | val generate_intf_to : 49 | ctxt:Expansion_context.Deriver.t -> 50 | rec_flag * type_declaration list -> 51 | signature_item list 52 | 53 | val generate_intf_of : 54 | ctxt:Expansion_context.Deriver.t -> 55 | rec_flag * type_declaration list -> 56 | signature_item list 57 | 58 | val impl_generator_to : 59 | (ctxt:Expansion_context.Deriver.t -> 'a -> 'b) -> 60 | ('b, 'a) Deriving.Generator.t 61 | 62 | val impl_generator_of : 63 | (ctxt:Expansion_context.Deriver.t -> 'a -> bool -> 'b) -> 64 | ('b, 'a) Deriving.Generator.t 65 | end 66 | -------------------------------------------------------------------------------- /src/ezjsonm/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ppx_deriving_ezjsonm) 3 | (public_name ppx_deriving_ezjsonm) 4 | (modules ppx_deriving_ezjsonm) 5 | (kind ppx_deriver) 6 | (libraries ppxlib ppx_deriving_ezjsonm.common) 7 | (ppx_runtime_libraries ezjsonm) 8 | (preprocess 9 | (pps ppxlib.metaquot))) 10 | 11 | (mdx 12 | (files index.mld) 13 | (package ppx_deriving_ezjsonm) 14 | (libraries ppx_deriving_ezjsonm ezjsonm)) 15 | 16 | (documentation 17 | (package ppx_deriving_ezjsonm)) 18 | -------------------------------------------------------------------------------- /src/ezjsonm/index.mld: -------------------------------------------------------------------------------- 1 | {1 Deriving JSON} 2 | 3 | This deriver generates code targetted at the {! Ezjsonm} library. 4 | This shares a core type with the Yaml library meaning the deriver 5 | works in exactly the same way as [ppx_deriving_yaml]. 6 | 7 | The derivers favour usefulness over efficiency. 8 | 9 | {2 A Simple Example} 10 | 11 | To use the library, add a preprocessing stanza to your dune library. 12 | 13 | {@ocaml skip[ 14 | (preprocess 15 | (pps 16 | ppx_deriving_ezjsonm)) 17 | ]} 18 | 19 | So the documentation can include checked code examples, we first must require the 20 | deriver. 21 | 22 | {@ocaml[ 23 | # #require "ppx_deriving_ezjsonm";; 24 | ]} 25 | 26 | From there, you can annotate your type declarations with [[@@deriving ezjsonm]]. 27 | By default this will generate two functions, [of_yaml] and [to_yaml]. If the type 28 | is not called [t], the type's name will be prepended to these functions separated 29 | by a single hyphen. 30 | 31 | {@ocaml[ 32 | # module Person : sig 33 | type t [@@deriving ezjsonm] 34 | val set_name : t -> string -> t 35 | end = struct 36 | type t = { 37 | name : string; 38 | age : int; 39 | }[@@deriving ezjsonm] 40 | let set_name t name = { t with name } 41 | end;; 42 | module Person : 43 | sig 44 | type t 45 | val to_ezjsonm : t -> Ezjsonm.value 46 | val of_ezjsonm : Ezjsonm.value -> (t, [> `Msg of string ]) result 47 | val set_name : t -> string -> t 48 | end 49 | ]} 50 | 51 | You can then use these functions in conjunction with the {! Ezjsonm} libary to read, manipulate 52 | and write JSON values. For example, this little JSON value: 53 | 54 | {@ocaml[ 55 | # let raw_json = "{\"name\": \"Alice\", \"age\": 42 }" 56 | val raw_json : string = "{\"name\": \"Alice\", \"age\": 42 }" 57 | # let p = Ezjsonm.value_from_string raw_json 58 | |> Person.of_ezjsonm 59 | |> Result.get_ok;; 60 | val p : Person.t = 61 | ]} 62 | 63 | Then we change the name of the person and convert back to JSON. 64 | 65 | {@ocaml[ 66 | # Person.set_name p "Bob" |> Person.to_ezjsonm |> Ezjsonm.value_to_string;; 67 | - : string = "{\"name\":\"Bob\",\"age\":42}" 68 | ]} 69 | 70 | {2 Attributes} 71 | 72 | For more information about the possible attributes, please see the {{: https://ocaml.org/p/ppx_deriving_yaml} documentation 73 | for [ppx_deriving_yaml]}. 74 | -------------------------------------------------------------------------------- /src/ezjsonm/ppx_deriving_ezjsonm.ml: -------------------------------------------------------------------------------- 1 | open Ppxlib 2 | 3 | module Backend = struct 4 | let backend = "ezjsonm" 5 | let typename = "Ezjsonm.value" 6 | let suf_to = "to_ezjsonm" 7 | let suf_of = "of_ezjsonm" 8 | 9 | module Attrs = struct 10 | let key = 11 | Attribute.declare "ezjsonm.key" Attribute.Context.label_declaration 12 | Ast_pattern.(pstr (pstr_eval (estring __) nil ^:: nil)) 13 | (fun x -> x) 14 | 15 | let name = 16 | Attribute.declare "ezjsonm.name" Attribute.Context.constructor_declaration 17 | Ast_pattern.(pstr (pstr_eval (estring __) nil ^:: nil)) 18 | (fun x -> x) 19 | 20 | let default = 21 | Attribute.declare "ezjsonm.default" Attribute.Context.label_declaration 22 | Ast_pattern.(single_expr_payload __) 23 | (fun x -> x) 24 | 25 | let to_ = 26 | Attribute.declare "ezjsonm.to_ezjsonm" Attribute.Context.label_declaration 27 | Ast_pattern.(single_expr_payload __) 28 | (fun x -> x) 29 | 30 | let of_ = 31 | Attribute.declare "ezjsonm.of_ezjsonm" Attribute.Context.label_declaration 32 | Ast_pattern.(single_expr_payload __) 33 | (fun x -> x) 34 | end 35 | end 36 | 37 | module Value = Ppx_deriving_ezjsonm_common.Make (Backend) 38 | 39 | let intf_generator intf = Deriving.Generator.V2.make_noarg intf 40 | 41 | let deriver = 42 | let open Value in 43 | let of_ezjsonm = 44 | Deriving.add "of_ezjsonm" 45 | ~str_type_decl:(impl_generator_of generate_impl_of) 46 | ~sig_type_decl:(intf_generator generate_intf_of) 47 | in 48 | let to_ezjsonm = 49 | Deriving.add "to_ezjsonm" 50 | ~str_type_decl:(impl_generator_to generate_impl_to) 51 | ~sig_type_decl:(intf_generator generate_intf_to) 52 | in 53 | Deriving.add_alias "ezjsonm" [ of_ezjsonm; to_ezjsonm ] 54 | -------------------------------------------------------------------------------- /src/yaml/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ppx_deriving_yaml) 3 | (public_name ppx_deriving_yaml) 4 | (modules ppx_deriving_yaml) 5 | (kind ppx_deriver) 6 | (libraries ppxlib ppx_deriving_yaml.common) 7 | (ppx_runtime_libraries yaml) 8 | (preprocess 9 | (pps ppxlib.metaquot))) 10 | 11 | (mdx 12 | (files index.mld) 13 | (package ppx_deriving_yaml) 14 | (libraries ppxlib ppx_deriving_yaml yaml)) 15 | 16 | (documentation 17 | (package ppx_deriving_yaml)) 18 | -------------------------------------------------------------------------------- /src/yaml/index.mld: -------------------------------------------------------------------------------- 1 | {0 Deriving Yaml} 2 | 3 | This ppx is based on {{: https://github.com/NathanReb/ppx_yojson} ppx_yojson} 4 | and {{: https://github.com/ocaml-ppx/ppx_deriving_yojson} ppx_deriving_yojson} 5 | because of the many similarities between JSON and yaml. 6 | 7 | So similar that OCaml's {! Yaml} library shares a common type with the {{: 8 | https://github.com/p/ezjsonm} Ezjsonm} library. See {{: 9 | https://github.com/p/ppx_deriving_ezjsonm} [ppx_deriving_ezjsonm]} for more 10 | details. 11 | 12 | {1 Basic Usage} 13 | 14 | For converting OCaml values to Yaml values [ppx_deriving_yaml] will do the 15 | conventional dropping of the type name if it is [t]. Otherwise the type name is 16 | the prefix to the [to_yaml] function. 17 | 18 | [to_yaml] produces a {! Yaml.value}. 19 | 20 | [of_yaml] produces OCaml types wrapped in a {! Stdlib.result}. 21 | 22 | {@ocaml[ 23 | # #require "ppx_deriving_yaml";; 24 | ]} 25 | 26 | Here is a small example. 27 | 28 | {@ocaml[ 29 | type person = { name : string; age : int } [@@deriving yaml] 30 | type users = person list [@@deriving yaml] 31 | ]} 32 | 33 | This will produce four functions, a [_to_yaml] and [_of_yaml] for both a person and 34 | the users. For example: 35 | 36 | {@ocaml[ 37 | # person_to_yaml;; 38 | - : person -> 39 | [> `O of (string * [> `Float of float | `String of string ]) list ] 40 | = 41 | # users_of_yaml;; 42 | - : [> `A of 43 | [> `O of (string * [> `Float of float | `String of string ]) list ] 44 | list ] -> 45 | (person list, [> `Msg of string ]) result 46 | = 47 | ]} 48 | 49 | If your type constructors have arguments, then the functions will be 50 | higher-order and you will need to supply a function to convert values for each 51 | constructor argument. For example: 52 | 53 | {@ocaml[ 54 | type 'a note = { txt : 'a } [@@deriving yaml] 55 | ]} 56 | 57 | produces the following function. 58 | 59 | {@ocaml[ 60 | # note_to_yaml;; 61 | - : ('a -> Yaml.value) -> 'a note -> [> `O of (string * Yaml.value) list ] = 62 | 63 | ]} 64 | 65 | Finally, if you only need the encoder ([to_yaml]) or the decoder ([of_yaml]) then there are single versions of the deriver for those. 66 | 67 | {@ocaml[ 68 | # type x = { age : int }[@@deriving to_yaml];; 69 | type x = { age : int; } 70 | val x_to_yaml : x -> [> `O of (string * [> `Float of float ]) list ] = 71 | ]} 72 | 73 | {1 Attributes} 74 | 75 | {2 Key and Name} 76 | 77 | Record field names cannot begin with a capital letter and variant constructors 78 | must start with one. This limits what the generated Yaml can look like. To 79 | override the Yaml names you can use the [[@key ]] and [[@name 80 | ]] attributes for records and variants respectively. 81 | 82 | {@ocaml[ 83 | # type t = { 84 | camel_name : string [@key "camel-name"] 85 | }[@@deriving to_yaml];; 86 | type t = { camel_name : string; } 87 | val to_yaml : t -> [> `O of (string * [> `String of string ]) list ] = 88 | 89 | # Yaml.to_string_exn (to_yaml { camel_name = "Alice" });; 90 | - : string = "camel-name: Alice\n" 91 | ]} 92 | 93 | {2 Default Values} 94 | 95 | You can also specify default values for fields. 96 | 97 | {@ocaml[ 98 | type t = { 99 | name : string; 100 | age : int [@default 42] 101 | }[@@deriving yaml] 102 | ]} 103 | 104 | These will be used in the absence of any fields when decoding Yaml values into OCaml ones. 105 | 106 | {@ocaml[ 107 | # Yaml.of_string_exn "name: Alice" |> of_yaml;; 108 | - : (t, [> `Msg of string ]) result = Ok {name = "Alice"; age = 42} 109 | ]} 110 | 111 | {2 Custom encoding and decoding} 112 | 113 | Sometimes you might want to specify your own encoding and decoding logic on field 114 | by field basis. To do so, you can use the [of_yaml] and [to_yaml] attributes. 115 | 116 | {@ocaml[ 117 | type t = { 118 | name : string [@to_yaml fun i -> `String ("custom-" ^ i)] 119 | }[@@deriving yaml] 120 | ]} 121 | 122 | The [to_yaml] function will use the custom encoder now instead. 123 | 124 | {@ocaml[ 125 | # Yaml.to_string_exn (to_yaml { name = "alice" });; 126 | - : string = "name: custom-alice\n" 127 | ]} 128 | 129 | {1 Partially Decoding} 130 | 131 | There is a [~skip_unknown] flag for telling the deriver to simply ignore any 132 | fields which are missing. This is particularly useful when you only wish to 133 | partially decode a yaml value. 134 | 135 | Consider the following yaml: 136 | 137 | {@ocaml[ 138 | let yaml = "name: Bob\nage: 42\nmisc: We don't need this!" 139 | ]} 140 | 141 | If we try to do the normal decoding of this but only partially extract the fields, it will throw an error. 142 | 143 | {@ocaml[ 144 | # type t = { 145 | name : string; 146 | age : int; 147 | }[@@deriving of_yaml];; 148 | type t = { name : string; age : int; } 149 | val of_yaml : 150 | [> `O of (string * [> `Float of float | `String of string ]) list ] -> 151 | (t, [> `Msg of string ]) result = 152 | 153 | # Yaml.of_string_exn yaml |> of_yaml;; 154 | - : (t, [> `Msg of string ]) result = 155 | Error (`Msg "Failed to find the case for: misc") 156 | ]} 157 | 158 | Instead we tell the deriver to ignore unknown fields. 159 | 160 | {@ocaml[ 161 | type t = { 162 | name : string; 163 | age : int; 164 | }[@@deriving of_yaml ~skip_unknown] 165 | ]} 166 | 167 | {@ocaml[ 168 | # Yaml.of_string_exn yaml |> of_yaml;; 169 | - : (t, [> `Msg of string ]) result = Ok {name = "Bob"; age = 42} 170 | ]} 171 | 172 | {1 Implementation Details} 173 | 174 | One important thing is that ['a option] values within records will return [None] if the Yaml you are trying to convert does not exist. 175 | 176 | {table 177 | {tr {th OCaml Type}{th Yaml Type}} 178 | {tr {td [int]}{td [`Float]}} 179 | {tr {td [float]}{td [`Float]}} 180 | {tr {td [string]}{td [`String]}} 181 | {tr {td [bool]}{td [`Bool]}} 182 | {tr {td [None]}{td [`Null]}} 183 | {tr {td [list]}{td [ `A []]}} 184 | {tr {td [array]}{td [ `A []]}} 185 | {tr {td [record] e.g [{ name : string }]}{td [`O [("name", `String s)]]}} 186 | {tr {td [A of int] or [ [`A of int]]}{td [`O [("A", `A [`Float f])]]}} 187 | } 188 | -------------------------------------------------------------------------------- /src/yaml/ppx_deriving_yaml.ml: -------------------------------------------------------------------------------- 1 | open Ppxlib 2 | 3 | module Backend = struct 4 | let backend = "yaml" 5 | let typename = "Yaml.value" 6 | let suf_to = "to_yaml" 7 | let suf_of = "of_yaml" 8 | 9 | module Attrs = struct 10 | let key = 11 | Attribute.declare "yaml.key" Attribute.Context.label_declaration 12 | Ast_pattern.(pstr (pstr_eval (estring __) nil ^:: nil)) 13 | (fun x -> x) 14 | 15 | let name = 16 | Attribute.declare "yaml.name" Attribute.Context.constructor_declaration 17 | Ast_pattern.(pstr (pstr_eval (estring __) nil ^:: nil)) 18 | (fun x -> x) 19 | 20 | let default = 21 | Attribute.declare "yaml.default" Attribute.Context.label_declaration 22 | Ast_pattern.(single_expr_payload __) 23 | (fun x -> x) 24 | 25 | let to_ = 26 | Attribute.declare "yaml.to_yaml" Attribute.Context.label_declaration 27 | Ast_pattern.(single_expr_payload __) 28 | (fun x -> x) 29 | 30 | let of_ = 31 | Attribute.declare "yaml.of_yaml" Attribute.Context.label_declaration 32 | Ast_pattern.(single_expr_payload __) 33 | (fun x -> x) 34 | end 35 | end 36 | 37 | module Value = Ppx_deriving_yaml_common.Make (Backend) 38 | 39 | let intf_generator intf = Deriving.Generator.V2.make_noarg intf 40 | 41 | let deriver = 42 | let open Value in 43 | let of_yaml = 44 | Deriving.add "of_yaml" 45 | ~str_type_decl:(impl_generator_of generate_impl_of) 46 | ~sig_type_decl:(intf_generator generate_intf_of) 47 | in 48 | let to_yaml = 49 | Deriving.add "to_yaml" 50 | ~str_type_decl:(impl_generator_to generate_impl_to) 51 | ~sig_type_decl:(intf_generator generate_intf_to) 52 | in 53 | Deriving.add_alias "yaml" [ of_yaml; to_yaml ] 54 | -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test) 3 | (package ppx_deriving_yaml) 4 | (libraries alcotest yaml) 5 | (preprocess 6 | (pps ppx_deriving_yaml))) 7 | -------------------------------------------------------------------------------- /test/expect_ezjsonm/LICENSE.md: -------------------------------------------------------------------------------- 1 | ## ISC License 2 | 3 | Copyright (c) 2013-2020 Thomas Gazagnaire 4 | Copyright (c) 2019-2020 Craig Ferguson 5 | 6 | Permission to use, copy, modify, and distribute this software for any 7 | purpose with or without fee is hereby granted, provided that the above 8 | copyright notice and this permission notice appear in all copies. 9 | 10 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -------------------------------------------------------------------------------- /test/expect_ezjsonm/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name gen_rules)) 3 | -------------------------------------------------------------------------------- /test/expect_ezjsonm/errors/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name pp) 3 | (modules pp) 4 | (libraries ppx_deriving_ezjsonm ppxlib)) 5 | 6 | (include dune.inc) 7 | 8 | (rule 9 | (targets dune.inc.gen) 10 | (deps 11 | (source_tree .)) 12 | (action 13 | (with-stdout-to 14 | %{targets} 15 | (run ../gen_rules.exe --expect-failure)))) 16 | 17 | (rule 18 | (alias runtest) 19 | (package ppx_deriving_ezjsonm) 20 | (action 21 | (diff dune.inc dune.inc.gen))) 22 | -------------------------------------------------------------------------------- /test/expect_ezjsonm/errors/dune.inc: -------------------------------------------------------------------------------- 1 | (env 2 | (_ 3 | (env-vars 4 | (OCAML_ERROR_STYLE "short") 5 | (OCAML_COLOR "never")))) 6 | 7 | ; -------- Test: `err.ml` -------- 8 | 9 | 10 | 11 | ; Run the PPX on the `.ml` file 12 | (rule 13 | (targets err.actual) 14 | (deps 15 | (:pp pp.exe) 16 | (:input err.ml)) 17 | (action 18 | (with-stdout-to 19 | %{targets} 20 | (bash "./%{pp} -no-color --impl %{input}")))) 21 | 22 | ; Compare the post-processed output to the .expected file 23 | (rule 24 | (alias runtest) 25 | (package ppx_deriving_ezjsonm) 26 | (action 27 | (diff err.expected err.actual))) 28 | 29 | 30 | -------------------------------------------------------------------------------- /test/expect_ezjsonm/errors/err.expected: -------------------------------------------------------------------------------- 1 | type t = int -> int[@@deriving ezjsonm] 2 | include 3 | struct 4 | let _ = fun (_ : t) -> () 5 | let to_ezjsonm = [%ocaml.error "Functions cannot be converted ezjsonm"] 6 | let _ = to_ezjsonm 7 | let of_ezjsonm = [%ocaml.error "Functions cannot be converted ezjsonm"] 8 | let _ = of_ezjsonm 9 | end[@@ocaml.doc "@inline"][@@merlin.hide ] 10 | type u = int -> int[@@deriving ezjsonm] 11 | include 12 | struct 13 | let _ = fun (_ : u) -> () 14 | let u_to_ezjsonm = [%ocaml.error "Functions cannot be converted ezjsonm"] 15 | let _ = u_to_ezjsonm 16 | let u_of_ezjsonm = [%ocaml.error "Functions cannot be converted ezjsonm"] 17 | let _ = u_of_ezjsonm 18 | end[@@ocaml.doc "@inline"][@@merlin.hide ] 19 | type v = int[@@deriving ezjsonm] 20 | include 21 | struct 22 | let _ = fun (_ : v) -> () 23 | let v_to_ezjsonm (x : int) = `Float (float_of_int x) 24 | let _ = v_to_ezjsonm 25 | let v_of_ezjsonm = 26 | function 27 | | `Float x -> Ok (int_of_float x) 28 | | _ -> Error (`Msg "Was expecting 'int' but got a different type") 29 | let _ = v_of_ezjsonm 30 | end[@@ocaml.doc "@inline"][@@merlin.hide ] 31 | type w = ..[@@deriving ezjsonm] 32 | include 33 | struct 34 | let _ = fun (_ : w) -> () 35 | let error_encountered = 36 | [%ocaml.error "Cannot derive anything for this type"] 37 | let _ = error_encountered 38 | let error = [%ocaml.error "Cannot derive anything for this type"] 39 | let _ = error 40 | end[@@ocaml.doc "@inline"][@@merlin.hide ] 41 | type x[@@deriving ezjsonm] 42 | include 43 | struct 44 | let _ = fun (_ : x) -> () 45 | let error_encountered = 46 | [%ocaml.error "Cannot derive anything for this type"] 47 | let _ = error_encountered 48 | let error_encountered = 49 | [%ocaml.error 50 | "Failed to derive something for an abstract type with no manifest!"] 51 | let _ = error_encountered 52 | end[@@ocaml.doc "@inline"][@@merlin.hide ] 53 | let _ = v_of_ezjsonm 54 | -------------------------------------------------------------------------------- /test/expect_ezjsonm/errors/err.ml: -------------------------------------------------------------------------------- 1 | type t = int -> int [@@deriving ezjsonm] 2 | type u = int -> int [@@deriving ezjsonm] 3 | type v = int [@@deriving ezjsonm] 4 | type w = .. [@@deriving ezjsonm] 5 | type x [@@deriving ezjsonm] 6 | 7 | let _ = v_of_ezjsonm 8 | -------------------------------------------------------------------------------- /test/expect_ezjsonm/errors/pp.ml: -------------------------------------------------------------------------------- 1 | let () = Ppxlib.Driver.standalone () 2 | -------------------------------------------------------------------------------- /test/expect_ezjsonm/gen_rules.ml: -------------------------------------------------------------------------------- 1 | (* Global configuration for tests in which the PPX fails (for consistency with 2 | various compiler versions / platforms). *) 3 | let ppx_fail_global_stanzas () = 4 | Format.printf 5 | {|(env 6 | (_ 7 | (env-vars 8 | (OCAML_ERROR_STYLE "short") 9 | (OCAML_COLOR "never")))) 10 | 11 | |} 12 | 13 | let output_stanzas ~expect_failure filename = 14 | let base = Filename.remove_extension filename in 15 | let pp_library ppf base = 16 | (* If the PPX will fail, we don't need to declare the file as executable *) 17 | if not expect_failure then 18 | Format.fprintf ppf 19 | "; The PPX-dependent executable under test@,\ 20 | @[(executable@ (name %s)@ (modules %s)@ (preprocess (pps \ 21 | ppx_deriving_ezjsonm))@ (libraries ezjsonm))@]" 22 | base base 23 | else () 24 | in 25 | let pp_rule ppf base = 26 | let pp_action ppf expect_failure = 27 | Format.fprintf ppf 28 | (if expect_failure then 29 | "@[(with-stdout-to@,\ 30 | %%{targets}@,\ 31 | (bash \"./%%{pp} -no-color --impl %%{input}\"))@]" 32 | else 33 | "(run ./%%{pp} -deriving-keep-w32 both --impl %%{input} -o \ 34 | %%{targets})") 35 | in 36 | Format.fprintf ppf 37 | "; Run the PPX on the `.ml` file@,\ 38 | @[(rule@,\ 39 | (targets %s.actual)@,\ 40 | @[(deps@,\ 41 | (:pp pp.exe)@,\ 42 | (:input %s.ml))@]@,\ 43 | @[(action@,\ 44 | %a))@]@]" 45 | base base pp_action expect_failure 46 | in 47 | let pp_diff_alias ppf base = 48 | Format.fprintf ppf 49 | "; Compare the post-processed output to the .expected file@,\ 50 | @[(rule@,\ 51 | (alias runtest)@,\ 52 | (package ppx_deriving_ezjsonm)@,\ 53 | @[(action@,\ 54 | @[(diff@ %s.expected@ %s.actual)@])@])@]" base base 55 | in 56 | let pp_run_alias ppf base = 57 | (* If we expect the derivation to succeed, then we should be able to compile 58 | the output. *) 59 | if not expect_failure then 60 | Format.fprintf ppf 61 | "@,\ 62 | @,\ 63 | ; Ensure that the post-processed executable runs correctly@,\ 64 | @[(rule@,\ 65 | (alias runtest)@,\ 66 | (package ppx_deriving_ezjsonm)@,\ 67 | @[(action@,\ 68 | @[(run@ ./%s.exe)@])@])@]" base 69 | else () 70 | in 71 | Format.set_margin 80; 72 | Format.printf 73 | "@[; -------- Test: `%s.ml` --------@,@,%a@,@,%a@,@,%a%a@,@]@." base 74 | pp_library base pp_rule base pp_diff_alias base pp_run_alias base 75 | 76 | let is_error_test = function 77 | | "pp.ml" -> false 78 | | "gen_dune_rules.ml" -> false 79 | | filename -> 80 | Filename.check_suffix filename ".ml" 81 | (* Avoid capturing post-PPX files *) 82 | && not (Filename.check_suffix filename ".pp.ml") 83 | 84 | let () = 85 | let expect_failure = 86 | match Array.to_list Sys.argv with 87 | | [ _; "--expect-failure" ] -> true 88 | | [ _ ] -> false 89 | | _ -> failwith "Unsupported option passed" 90 | in 91 | if expect_failure then ppx_fail_global_stanzas (); 92 | Sys.readdir "." 93 | |> Array.to_list 94 | |> List.sort String.compare 95 | |> List.filter is_error_test 96 | |> List.iter (output_stanzas ~expect_failure); 97 | Format.printf "\n%!" 98 | -------------------------------------------------------------------------------- /test/expect_ezjsonm/passing/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name pp) 3 | (modules pp) 4 | (libraries ppx_deriving_ezjsonm ppxlib)) 5 | 6 | (include dune.inc) 7 | 8 | (rule 9 | (targets dune.inc.gen) 10 | (deps 11 | (source_tree .)) 12 | (action 13 | (with-stdout-to 14 | %{targets} 15 | (run ../gen_rules.exe)))) 16 | 17 | (rule 18 | (alias runtest) 19 | (package ppx_deriving_ezjsonm) 20 | (action 21 | (diff dune.inc dune.inc.gen))) 22 | -------------------------------------------------------------------------------- /test/expect_ezjsonm/passing/dune.inc: -------------------------------------------------------------------------------- 1 | ; -------- Test: `recursive.ml` -------- 2 | 3 | ; The PPX-dependent executable under test 4 | (executable 5 | (name recursive) 6 | (modules recursive) 7 | (preprocess (pps ppx_deriving_ezjsonm)) 8 | (libraries ezjsonm)) 9 | 10 | ; Run the PPX on the `.ml` file 11 | (rule 12 | (targets recursive.actual) 13 | (deps 14 | (:pp pp.exe) 15 | (:input recursive.ml)) 16 | (action 17 | (run ./%{pp} -deriving-keep-w32 both --impl %{input} -o %{targets}))) 18 | 19 | ; Compare the post-processed output to the .expected file 20 | (rule 21 | (alias runtest) 22 | (package ppx_deriving_ezjsonm) 23 | (action 24 | (diff recursive.expected recursive.actual))) 25 | 26 | ; Ensure that the post-processed executable runs correctly 27 | (rule 28 | (alias runtest) 29 | (package ppx_deriving_ezjsonm) 30 | (action 31 | (run ./recursive.exe))) 32 | 33 | ; -------- Test: `simple.ml` -------- 34 | 35 | ; The PPX-dependent executable under test 36 | (executable 37 | (name simple) 38 | (modules simple) 39 | (preprocess (pps ppx_deriving_ezjsonm)) 40 | (libraries ezjsonm)) 41 | 42 | ; Run the PPX on the `.ml` file 43 | (rule 44 | (targets simple.actual) 45 | (deps 46 | (:pp pp.exe) 47 | (:input simple.ml)) 48 | (action 49 | (run ./%{pp} -deriving-keep-w32 both --impl %{input} -o %{targets}))) 50 | 51 | ; Compare the post-processed output to the .expected file 52 | (rule 53 | (alias runtest) 54 | (package ppx_deriving_ezjsonm) 55 | (action 56 | (diff simple.expected simple.actual))) 57 | 58 | ; Ensure that the post-processed executable runs correctly 59 | (rule 60 | (alias runtest) 61 | (package ppx_deriving_ezjsonm) 62 | (action 63 | (run ./simple.exe))) 64 | 65 | ; -------- Test: `skip_unknown.ml` -------- 66 | 67 | ; The PPX-dependent executable under test 68 | (executable 69 | (name skip_unknown) 70 | (modules skip_unknown) 71 | (preprocess (pps ppx_deriving_ezjsonm)) 72 | (libraries ezjsonm)) 73 | 74 | ; Run the PPX on the `.ml` file 75 | (rule 76 | (targets skip_unknown.actual) 77 | (deps 78 | (:pp pp.exe) 79 | (:input skip_unknown.ml)) 80 | (action 81 | (run ./%{pp} -deriving-keep-w32 both --impl %{input} -o %{targets}))) 82 | 83 | ; Compare the post-processed output to the .expected file 84 | (rule 85 | (alias runtest) 86 | (package ppx_deriving_ezjsonm) 87 | (action 88 | (diff skip_unknown.expected skip_unknown.actual))) 89 | 90 | ; Ensure that the post-processed executable runs correctly 91 | (rule 92 | (alias runtest) 93 | (package ppx_deriving_ezjsonm) 94 | (action 95 | (run ./skip_unknown.exe))) 96 | 97 | 98 | -------------------------------------------------------------------------------- /test/expect_ezjsonm/passing/pp.ml: -------------------------------------------------------------------------------- 1 | let () = Ppxlib.Driver.standalone () 2 | -------------------------------------------------------------------------------- /test/expect_ezjsonm/passing/recursive.expected: -------------------------------------------------------------------------------- 1 | type t = { 2 | name: string ; 3 | children: t list }[@@deriving ezjsonm] 4 | include 5 | struct 6 | let rec to_ezjsonm (x : t) = 7 | `O 8 | (Stdlib.List.filter_map (fun x -> x) 9 | [Some ("name", (((fun (x : string) -> `String x)) x.name)); 10 | Some 11 | ("children", 12 | (((fun x -> `A (List.map (fun x -> to_ezjsonm x) x))) 13 | x.children))]) 14 | let rec of_ezjsonm = 15 | let (>>=) v f = match v with | Ok v -> f v | Error _ as e -> e[@@warning 16 | "-26"] in 17 | function 18 | | `O xs -> 19 | let rec loop xs ((arg0, arg1) as _state) = 20 | match xs with 21 | | ("name", x)::xs -> 22 | loop xs 23 | (((function 24 | | `String x -> Ok x 25 | | _ -> 26 | Error 27 | (`Msg 28 | "Was expecting 'string' but got a different type")) 29 | x), arg1) 30 | | ("children", x)::xs -> 31 | loop xs 32 | (arg0, 33 | ((function 34 | | `A lst -> 35 | let (>>=) v f = 36 | match v with | Ok v -> f v | Error _ as e -> e in 37 | ((fun f -> 38 | fun lst -> 39 | (Stdlib.List.fold_left 40 | (fun acc -> 41 | fun x -> 42 | match acc with 43 | | Stdlib.Ok acc -> 44 | (f x) >>= 45 | ((fun x -> Stdlib.Ok (x :: acc))) 46 | | Stdlib.Error e -> Stdlib.Error e) 47 | (Stdlib.Ok []) lst) 48 | >>= 49 | (fun lst -> Stdlib.Ok (Stdlib.List.rev lst)))) 50 | (fun x -> of_ezjsonm x) lst 51 | | _ -> 52 | Error 53 | (`Msg 54 | "Was expecting 'list' but got a different type")) 55 | x)) 56 | | [] -> 57 | arg1 >>= 58 | ((fun arg1 -> 59 | arg0 >>= 60 | (fun arg0 -> Ok { name = arg0; children = arg1 }))) 61 | | (x, _y)::_ -> 62 | Error (`Msg ("Failed to find the case for: " ^ x)) in 63 | loop xs 64 | ((Error (`Msg "Didn't find the function for key: name")), 65 | (Error (`Msg "Didn't find the function for key: children"))) 66 | | _ -> 67 | Error (`Msg "Failed building a key-value object expecting a list") 68 | end[@@ocaml.doc "@inline"][@@merlin.hide ] 69 | -------------------------------------------------------------------------------- /test/expect_ezjsonm/passing/recursive.ml: -------------------------------------------------------------------------------- 1 | type t = { name : string; children : t list } [@@deriving ezjsonm] 2 | -------------------------------------------------------------------------------- /test/expect_ezjsonm/passing/simple.expected: -------------------------------------------------------------------------------- 1 | type var = 2 | | Hello 3 | | World of string [@@deriving ezjsonm] 4 | include 5 | struct 6 | let var_to_ezjsonm = 7 | function 8 | | Hello -> `O [("Hello", (`A []))] 9 | | World arg0 -> 10 | `O [("World", (`A [((fun (x : string) -> `String x)) arg0]))] 11 | let var_of_ezjsonm = 12 | let (>>=) v f = match v with | Ok v -> f v | Error _ as e -> e[@@warning 13 | "-26"] in 14 | function 15 | | `O (("Hello", `A [])::[]) -> Stdlib.Result.Ok Hello 16 | | `O (("World", `A (arg0::[]))::[]) -> 17 | ((function 18 | | `String x -> Ok x 19 | | _ -> 20 | Error 21 | (`Msg "Was expecting 'string' but got a different type")) 22 | arg0) 23 | >>= ((fun arg0 -> Stdlib.Result.Ok (World arg0))) 24 | | _ -> Stdlib.Error (`Msg "no match for this variant expression") 25 | end[@@ocaml.doc "@inline"][@@merlin.hide ] 26 | type poly_var = [ `Hello | `World of string ][@@deriving ezjsonm] 27 | include 28 | struct 29 | let poly_var_to_ezjsonm = 30 | function 31 | | `Hello -> `O [("Hello", (`A []))] 32 | | `World x -> 33 | ((fun (x : string) -> `String x) x) |> 34 | ((fun x -> `O [("World", (`A [x]))])) 35 | let poly_var_of_ezjsonm = 36 | let (>>=) v f = match v with | Ok v -> f v | Error _ as e -> e[@@warning 37 | "-26"] in 38 | function 39 | | `O (("Hello", `A [])::[]) -> Stdlib.Result.Ok `Hello 40 | | `O (("World", `A (x::[]))::[]) -> 41 | ((function 42 | | `String x -> Ok x 43 | | _ -> 44 | Error 45 | (`Msg "Was expecting 'string' but got a different type")) x) 46 | >>= ((fun x -> Stdlib.Result.Ok (`World x))) 47 | | _ -> Error (`Msg "failed converting variant") 48 | end[@@ocaml.doc "@inline"][@@merlin.hide ] 49 | type a = { 50 | x: [ `Simple | `Example ] }[@@deriving ezjsonm] 51 | include 52 | struct 53 | let a_to_ezjsonm (x : a) = 54 | `O 55 | (Stdlib.List.filter_map (fun x -> x) 56 | [Some 57 | ("x", 58 | (((function 59 | | `Simple -> `O [("Simple", (`A []))] 60 | | `Example -> `O [("Example", (`A []))])) x.x))]) 61 | let a_of_ezjsonm = 62 | let (>>=) v f = match v with | Ok v -> f v | Error _ as e -> e[@@warning 63 | "-26"] in 64 | function 65 | | `O xs -> 66 | let rec loop xs (arg0 as _state) = 67 | match xs with 68 | | ("x", x)::xs -> 69 | loop xs 70 | ((let (>>=) v f = 71 | match v with | Ok v -> f v | Error _ as e -> e[@@warning 72 | "-26"] in 73 | function 74 | | `O (("Simple", `A [])::[]) -> Stdlib.Result.Ok `Simple 75 | | `O (("Example", `A [])::[]) -> 76 | Stdlib.Result.Ok `Example 77 | | _ -> Error (`Msg "failed converting variant")) x) 78 | | [] -> arg0 >>= ((fun arg0 -> Ok { x = arg0 })) 79 | | (x, _y)::_ -> 80 | Error (`Msg ("Failed to find the case for: " ^ x)) in 81 | loop xs (Error (`Msg "Didn't find the function for key: x")) 82 | | _ -> 83 | Error (`Msg "Failed building a key-value object expecting a list") 84 | end[@@ocaml.doc "@inline"][@@merlin.hide ] 85 | type t = { 86 | name: string ; 87 | age: int option }[@@deriving ezjsonm] 88 | include 89 | struct 90 | let to_ezjsonm (x : t) = 91 | `O 92 | (Stdlib.List.filter_map (fun x -> x) 93 | [Some ("name", (((fun (x : string) -> `String x)) x.name)); 94 | Some 95 | ("age", 96 | (((function 97 | | None -> `Null 98 | | Some t -> ((fun (x : int) -> `Float (float_of_int x))) t)) 99 | x.age))]) 100 | let of_ezjsonm = 101 | let (>>=) v f = match v with | Ok v -> f v | Error _ as e -> e[@@warning 102 | "-26"] in 103 | function 104 | | `O xs -> 105 | let rec loop xs ((arg0, arg1) as _state) = 106 | match xs with 107 | | ("name", x)::xs -> 108 | loop xs 109 | (((function 110 | | `String x -> Ok x 111 | | _ -> 112 | Error 113 | (`Msg 114 | "Was expecting 'string' but got a different type")) 115 | x), arg1) 116 | | ("age", x)::xs -> 117 | loop xs 118 | (arg0, 119 | ((function 120 | | `Null -> Ok None 121 | | x -> 122 | ((function 123 | | `Float x -> Ok (int_of_float x) 124 | | _ -> 125 | Error 126 | (`Msg 127 | "Was expecting 'int' but got a different type")) 128 | x) 129 | >>= ((fun x -> Ok (Some x)))) x)) 130 | | [] -> 131 | arg1 >>= 132 | ((fun arg1 -> 133 | arg0 >>= (fun arg0 -> Ok { name = arg0; age = arg1 }))) 134 | | (x, _y)::_ -> 135 | Error (`Msg ("Failed to find the case for: " ^ x)) in 136 | loop xs 137 | ((Error (`Msg "Didn't find the function for key: name")), 138 | (Ok None)) 139 | | _ -> 140 | Error (`Msg "Failed building a key-value object expecting a list") 141 | end[@@ocaml.doc "@inline"][@@merlin.hide ] 142 | type u = { 143 | name: string [@default "Una"]}[@@deriving to_ezjsonm] 144 | include 145 | struct 146 | let u_to_ezjsonm (x : u) = 147 | `O 148 | (Stdlib.List.filter_map (fun x -> x) 149 | [((fun x -> 150 | if Stdlib.(=) x "Una" 151 | then None 152 | else Some ("name", (((fun (x : string) -> `String x)) x)))) 153 | x.name]) 154 | end[@@ocaml.doc "@inline"][@@merlin.hide ] 155 | type v = { 156 | age: int [@key "AGE"][@default 10]}[@@deriving of_ezjsonm] 157 | include 158 | struct 159 | let v_of_ezjsonm = 160 | let (>>=) v f = match v with | Ok v -> f v | Error _ as e -> e[@@warning 161 | "-26"] in 162 | function 163 | | `O xs -> 164 | let rec loop xs (arg0 as _state) = 165 | match xs with 166 | | ("AGE", x)::xs -> 167 | loop xs 168 | ((function 169 | | `Float x -> Ok (int_of_float x) 170 | | _ -> 171 | Error 172 | (`Msg 173 | "Was expecting 'int' but got a different type")) 174 | x) 175 | | [] -> arg0 >>= ((fun arg0 -> Ok { age = arg0 })) 176 | | (x, _y)::_ -> 177 | Error (`Msg ("Failed to find the case for: " ^ x)) in 178 | loop xs (Ok 10) 179 | | _ -> 180 | Error (`Msg "Failed building a key-value object expecting a list") 181 | end[@@ocaml.doc "@inline"][@@merlin.hide ] 182 | type w = { 183 | age: int [@to_ezjsonm fun i -> `Float (float_of_int (i - 10))]}[@@deriving 184 | ezjsonm] 185 | include 186 | struct 187 | let w_to_ezjsonm (x : w) = 188 | `O 189 | (Stdlib.List.filter_map (fun x -> x) 190 | [Some ("age", (((fun i -> `Float (float_of_int (i - 10)))) x.age))]) 191 | let w_of_ezjsonm = 192 | let (>>=) v f = match v with | Ok v -> f v | Error _ as e -> e[@@warning 193 | "-26"] in 194 | function 195 | | `O xs -> 196 | let rec loop xs (arg0 as _state) = 197 | match xs with 198 | | ("age", x)::xs -> 199 | loop xs 200 | ((function 201 | | `Float x -> Ok (int_of_float x) 202 | | _ -> 203 | Error 204 | (`Msg 205 | "Was expecting 'int' but got a different type")) 206 | x) 207 | | [] -> arg0 >>= ((fun arg0 -> Ok { age = arg0 })) 208 | | (x, _y)::_ -> 209 | Error (`Msg ("Failed to find the case for: " ^ x)) in 210 | loop xs (Error (`Msg "Didn't find the function for key: age")) 211 | | _ -> 212 | Error (`Msg "Failed building a key-value object expecting a list") 213 | end[@@ocaml.doc "@inline"][@@merlin.hide ] 214 | type x = 215 | { 216 | age: int 217 | [@of_ezjsonm 218 | function 219 | | `Float f -> Ok (int_of_float (f +. 10.)) 220 | | _ -> Error (`Msg "Expected a Yaml `Float")]}[@@deriving ezjsonm] 221 | include 222 | struct 223 | let x_to_ezjsonm (x : x) = 224 | `O 225 | (Stdlib.List.filter_map (fun x -> x) 226 | [Some 227 | ("age", (((fun (x : int) -> `Float (float_of_int x))) x.age))]) 228 | let x_of_ezjsonm = 229 | let (>>=) v f = match v with | Ok v -> f v | Error _ as e -> e[@@warning 230 | "-26"] in 231 | function 232 | | `O xs -> 233 | let rec loop xs (arg0 as _state) = 234 | match xs with 235 | | ("age", x)::xs -> 236 | loop xs 237 | ((function 238 | | `Float f -> Ok (int_of_float (f +. 10.)) 239 | | _ -> Error (`Msg "Expected a Yaml `Float")) x) 240 | | [] -> arg0 >>= ((fun arg0 -> Ok { age = arg0 })) 241 | | (x, _y)::_ -> 242 | Error (`Msg ("Failed to find the case for: " ^ x)) in 243 | loop xs (Error (`Msg "Didn't find the function for key: age")) 244 | | _ -> 245 | Error (`Msg "Failed building a key-value object expecting a list") 246 | end[@@ocaml.doc "@inline"][@@merlin.hide ] 247 | -------------------------------------------------------------------------------- /test/expect_ezjsonm/passing/simple.ml: -------------------------------------------------------------------------------- 1 | type var = Hello | World of string [@@deriving ezjsonm] 2 | type poly_var = [ `Hello | `World of string ] [@@deriving ezjsonm] 3 | type a = { x : [ `Simple | `Example ] } [@@deriving ezjsonm] 4 | type t = { name : string; age : int option } [@@deriving ezjsonm] 5 | type u = { name : string [@default "Una"] } [@@deriving to_ezjsonm] 6 | type v = { age : int [@key "AGE"] [@default 10] } [@@deriving of_ezjsonm] 7 | 8 | type w = { age : int [@to_ezjsonm fun i -> `Float (float_of_int (i - 10))] } 9 | [@@deriving ezjsonm] 10 | 11 | type x = { 12 | age : int; 13 | [@of_ezjsonm 14 | function 15 | | `Float f -> Ok (int_of_float (f +. 10.)) 16 | | _ -> Error (`Msg "Expected a Yaml `Float")] 17 | } 18 | [@@deriving ezjsonm] 19 | -------------------------------------------------------------------------------- /test/expect_ezjsonm/passing/skip_unknown.expected: -------------------------------------------------------------------------------- 1 | type t = { 2 | name: string ; 3 | age: int }[@@deriving of_ezjsonm ~skip_unknown] 4 | include 5 | struct 6 | let of_ezjsonm = 7 | let (>>=) v f = match v with | Ok v -> f v | Error _ as e -> e[@@warning 8 | "-26"] in 9 | function 10 | | `O xs -> 11 | let rec loop xs ((arg0, arg1) as _state) = 12 | match xs with 13 | | ("name", x)::xs -> 14 | loop xs 15 | (((function 16 | | `String x -> Ok x 17 | | _ -> 18 | Error 19 | (`Msg 20 | "Was expecting 'string' but got a different type")) 21 | x), arg1) 22 | | ("age", x)::xs -> 23 | loop xs 24 | (arg0, 25 | ((function 26 | | `Float x -> Ok (int_of_float x) 27 | | _ -> 28 | Error 29 | (`Msg 30 | "Was expecting 'int' but got a different type")) 31 | x)) 32 | | [] -> 33 | arg1 >>= 34 | ((fun arg1 -> 35 | arg0 >>= (fun arg0 -> Ok { name = arg0; age = arg1 }))) 36 | | _::xs -> loop xs _state in 37 | loop xs 38 | ((Error (`Msg "Didn't find the function for key: name")), 39 | (Error (`Msg "Didn't find the function for key: age"))) 40 | | _ -> 41 | Error (`Msg "Failed building a key-value object expecting a list") 42 | end[@@ocaml.doc "@inline"][@@merlin.hide ] 43 | -------------------------------------------------------------------------------- /test/expect_ezjsonm/passing/skip_unknown.ml: -------------------------------------------------------------------------------- 1 | type t = { name : string; age : int } [@@deriving of_ezjsonm ~skip_unknown] 2 | -------------------------------------------------------------------------------- /test/expect_yaml/LICENSE.md: -------------------------------------------------------------------------------- 1 | ## ISC License 2 | 3 | Copyright (c) 2013-2020 Thomas Gazagnaire 4 | Copyright (c) 2019-2020 Craig Ferguson 5 | 6 | Permission to use, copy, modify, and distribute this software for any 7 | purpose with or without fee is hereby granted, provided that the above 8 | copyright notice and this permission notice appear in all copies. 9 | 10 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -------------------------------------------------------------------------------- /test/expect_yaml/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name gen_rules)) 3 | -------------------------------------------------------------------------------- /test/expect_yaml/errors/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name pp) 3 | (modules pp) 4 | (libraries ppx_deriving_yaml ppxlib)) 5 | 6 | (include dune.inc) 7 | 8 | (rule 9 | (targets dune.inc.gen) 10 | (deps 11 | (source_tree .)) 12 | (action 13 | (with-stdout-to 14 | %{targets} 15 | (run ../gen_rules.exe --expect-failure)))) 16 | 17 | (rule 18 | (alias runtest) 19 | (package ppx_deriving_yaml) 20 | (action 21 | (diff dune.inc dune.inc.gen))) 22 | -------------------------------------------------------------------------------- /test/expect_yaml/errors/dune.inc: -------------------------------------------------------------------------------- 1 | (env 2 | (_ 3 | (env-vars 4 | (OCAML_ERROR_STYLE "short") 5 | (OCAML_COLOR "never")))) 6 | 7 | ; -------- Test: `err.ml` -------- 8 | 9 | 10 | 11 | ; Run the PPX on the `.ml` file 12 | (rule 13 | (targets err.actual) 14 | (deps 15 | (:pp pp.exe) 16 | (:input err.ml)) 17 | (action 18 | (with-stdout-to 19 | %{targets} 20 | (bash "./%{pp} -no-color --impl %{input}")))) 21 | 22 | ; Compare the post-processed output to the .expected file 23 | (rule 24 | (alias runtest) 25 | (package ppx_deriving_yaml) 26 | (action 27 | (diff err.expected err.actual))) 28 | 29 | 30 | -------------------------------------------------------------------------------- /test/expect_yaml/errors/err.expected: -------------------------------------------------------------------------------- 1 | type t = int -> int[@@deriving yaml] 2 | include 3 | struct 4 | let _ = fun (_ : t) -> () 5 | let to_yaml = [%ocaml.error "Functions cannot be converted yaml"] 6 | let _ = to_yaml 7 | let of_yaml = [%ocaml.error "Functions cannot be converted yaml"] 8 | let _ = of_yaml 9 | end[@@ocaml.doc "@inline"][@@merlin.hide ] 10 | type u = int -> int[@@deriving yaml] 11 | include 12 | struct 13 | let _ = fun (_ : u) -> () 14 | let u_to_yaml = [%ocaml.error "Functions cannot be converted yaml"] 15 | let _ = u_to_yaml 16 | let u_of_yaml = [%ocaml.error "Functions cannot be converted yaml"] 17 | let _ = u_of_yaml 18 | end[@@ocaml.doc "@inline"][@@merlin.hide ] 19 | type v = int[@@deriving yaml] 20 | include 21 | struct 22 | let _ = fun (_ : v) -> () 23 | let v_to_yaml (x : int) = `Float (float_of_int x) 24 | let _ = v_to_yaml 25 | let v_of_yaml = 26 | function 27 | | `Float x -> Ok (int_of_float x) 28 | | _ -> Error (`Msg "Was expecting 'int' but got a different type") 29 | let _ = v_of_yaml 30 | end[@@ocaml.doc "@inline"][@@merlin.hide ] 31 | type w = ..[@@deriving yaml] 32 | include 33 | struct 34 | let _ = fun (_ : w) -> () 35 | let error_encountered = 36 | [%ocaml.error "Cannot derive anything for this type"] 37 | let _ = error_encountered 38 | let error = [%ocaml.error "Cannot derive anything for this type"] 39 | let _ = error 40 | end[@@ocaml.doc "@inline"][@@merlin.hide ] 41 | type x[@@deriving yaml] 42 | include 43 | struct 44 | let _ = fun (_ : x) -> () 45 | let error_encountered = 46 | [%ocaml.error "Cannot derive anything for this type"] 47 | let _ = error_encountered 48 | let error_encountered = 49 | [%ocaml.error 50 | "Failed to derive something for an abstract type with no manifest!"] 51 | let _ = error_encountered 52 | end[@@ocaml.doc "@inline"][@@merlin.hide ] 53 | let _ = v_of_yaml 54 | -------------------------------------------------------------------------------- /test/expect_yaml/errors/err.ml: -------------------------------------------------------------------------------- 1 | type t = int -> int [@@deriving yaml] 2 | type u = int -> int [@@deriving yaml] 3 | type v = int [@@deriving yaml] 4 | type w = .. [@@deriving yaml] 5 | type x [@@deriving yaml] 6 | 7 | let _ = v_of_yaml 8 | -------------------------------------------------------------------------------- /test/expect_yaml/errors/pp.ml: -------------------------------------------------------------------------------- 1 | let () = Ppxlib.Driver.standalone () 2 | -------------------------------------------------------------------------------- /test/expect_yaml/gen_rules.ml: -------------------------------------------------------------------------------- 1 | (* Global configuration for tests in which the PPX fails (for consistency with 2 | various compiler versions / platforms). *) 3 | let ppx_fail_global_stanzas () = 4 | Format.printf 5 | {|(env 6 | (_ 7 | (env-vars 8 | (OCAML_ERROR_STYLE "short") 9 | (OCAML_COLOR "never")))) 10 | 11 | |} 12 | 13 | let output_stanzas ~expect_failure filename = 14 | let base = Filename.remove_extension filename in 15 | let pp_library ppf base = 16 | (* If the PPX will fail, we don't need to declare the file as executable *) 17 | if not expect_failure then 18 | Format.fprintf ppf 19 | "; The PPX-dependent executable under test@,\ 20 | @[(executable@ (name %s)@ (modules %s)@ (preprocess (pps \ 21 | ppx_deriving_yaml))@ (libraries yaml))@]" 22 | base base 23 | else () 24 | in 25 | let pp_rule ppf base = 26 | let pp_action ppf expect_failure = 27 | Format.fprintf ppf 28 | (if expect_failure then 29 | "@[(with-stdout-to@,\ 30 | %%{targets}@,\ 31 | (bash \"./%%{pp} -no-color --impl %%{input}\"))@]" 32 | else 33 | "(run ./%%{pp} -deriving-keep-w32 both --impl %%{input} -o \ 34 | %%{targets})") 35 | in 36 | Format.fprintf ppf 37 | "; Run the PPX on the `.ml` file@,\ 38 | @[(rule@,\ 39 | (targets %s.actual)@,\ 40 | @[(deps@,\ 41 | (:pp pp.exe)@,\ 42 | (:input %s.ml))@]@,\ 43 | @[(action@,\ 44 | %a))@]@]" 45 | base base pp_action expect_failure 46 | in 47 | let pp_diff_alias ppf base = 48 | Format.fprintf ppf 49 | "; Compare the post-processed output to the .expected file@,\ 50 | @[(rule@,\ 51 | (alias runtest)@,\ 52 | (package ppx_deriving_yaml)@,\ 53 | @[(action@,\ 54 | @[(diff@ %s.expected@ %s.actual)@])@])@]" base base 55 | in 56 | let pp_run_alias ppf base = 57 | (* If we expect the derivation to succeed, then we should be able to compile 58 | the output. *) 59 | if not expect_failure then 60 | Format.fprintf ppf 61 | "@,\ 62 | @,\ 63 | ; Ensure that the post-processed executable runs correctly@,\ 64 | @[(rule@,\ 65 | (alias runtest)@,\ 66 | (package ppx_deriving_yaml)@,\ 67 | @[(action@,\ 68 | @[(run@ ./%s.exe)@])@])@]" base 69 | else () 70 | in 71 | Format.set_margin 80; 72 | Format.printf 73 | "@[; -------- Test: `%s.ml` --------@,@,%a@,@,%a@,@,%a%a@,@]@." base 74 | pp_library base pp_rule base pp_diff_alias base pp_run_alias base 75 | 76 | let is_error_test = function 77 | | "pp.ml" -> false 78 | | "gen_dune_rules.ml" -> false 79 | | filename -> 80 | Filename.check_suffix filename ".ml" 81 | (* Avoid capturing post-PPX files *) 82 | && not (Filename.check_suffix filename ".pp.ml") 83 | 84 | let () = 85 | let expect_failure = 86 | match Array.to_list Sys.argv with 87 | | [ _; "--expect-failure" ] -> true 88 | | [ _ ] -> false 89 | | _ -> failwith "Unsupported option passed" 90 | in 91 | if expect_failure then ppx_fail_global_stanzas (); 92 | Sys.readdir "." 93 | |> Array.to_list 94 | |> List.sort String.compare 95 | |> List.filter is_error_test 96 | |> List.iter (output_stanzas ~expect_failure); 97 | Format.printf "\n%!" 98 | -------------------------------------------------------------------------------- /test/expect_yaml/passing/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name pp) 3 | (modules pp) 4 | (libraries ppx_deriving_yaml ppxlib)) 5 | 6 | (include dune.inc) 7 | 8 | (rule 9 | (targets dune.inc.gen) 10 | (deps 11 | (source_tree .)) 12 | (action 13 | (with-stdout-to 14 | %{targets} 15 | (run ../gen_rules.exe)))) 16 | 17 | (rule 18 | (alias runtest) 19 | (package ppx_deriving_yaml) 20 | (action 21 | (diff dune.inc dune.inc.gen))) 22 | -------------------------------------------------------------------------------- /test/expect_yaml/passing/dune.inc: -------------------------------------------------------------------------------- 1 | ; -------- Test: `recursive.ml` -------- 2 | 3 | ; The PPX-dependent executable under test 4 | (executable 5 | (name recursive) 6 | (modules recursive) 7 | (preprocess (pps ppx_deriving_yaml)) 8 | (libraries yaml)) 9 | 10 | ; Run the PPX on the `.ml` file 11 | (rule 12 | (targets recursive.actual) 13 | (deps 14 | (:pp pp.exe) 15 | (:input recursive.ml)) 16 | (action 17 | (run ./%{pp} -deriving-keep-w32 both --impl %{input} -o %{targets}))) 18 | 19 | ; Compare the post-processed output to the .expected file 20 | (rule 21 | (alias runtest) 22 | (package ppx_deriving_yaml) 23 | (action 24 | (diff recursive.expected recursive.actual))) 25 | 26 | ; Ensure that the post-processed executable runs correctly 27 | (rule 28 | (alias runtest) 29 | (package ppx_deriving_yaml) 30 | (action 31 | (run ./recursive.exe))) 32 | 33 | ; -------- Test: `simple.ml` -------- 34 | 35 | ; The PPX-dependent executable under test 36 | (executable 37 | (name simple) 38 | (modules simple) 39 | (preprocess (pps ppx_deriving_yaml)) 40 | (libraries yaml)) 41 | 42 | ; Run the PPX on the `.ml` file 43 | (rule 44 | (targets simple.actual) 45 | (deps 46 | (:pp pp.exe) 47 | (:input simple.ml)) 48 | (action 49 | (run ./%{pp} -deriving-keep-w32 both --impl %{input} -o %{targets}))) 50 | 51 | ; Compare the post-processed output to the .expected file 52 | (rule 53 | (alias runtest) 54 | (package ppx_deriving_yaml) 55 | (action 56 | (diff simple.expected simple.actual))) 57 | 58 | ; Ensure that the post-processed executable runs correctly 59 | (rule 60 | (alias runtest) 61 | (package ppx_deriving_yaml) 62 | (action 63 | (run ./simple.exe))) 64 | 65 | ; -------- Test: `skip_unknown.ml` -------- 66 | 67 | ; The PPX-dependent executable under test 68 | (executable 69 | (name skip_unknown) 70 | (modules skip_unknown) 71 | (preprocess (pps ppx_deriving_yaml)) 72 | (libraries yaml)) 73 | 74 | ; Run the PPX on the `.ml` file 75 | (rule 76 | (targets skip_unknown.actual) 77 | (deps 78 | (:pp pp.exe) 79 | (:input skip_unknown.ml)) 80 | (action 81 | (run ./%{pp} -deriving-keep-w32 both --impl %{input} -o %{targets}))) 82 | 83 | ; Compare the post-processed output to the .expected file 84 | (rule 85 | (alias runtest) 86 | (package ppx_deriving_yaml) 87 | (action 88 | (diff skip_unknown.expected skip_unknown.actual))) 89 | 90 | ; Ensure that the post-processed executable runs correctly 91 | (rule 92 | (alias runtest) 93 | (package ppx_deriving_yaml) 94 | (action 95 | (run ./skip_unknown.exe))) 96 | 97 | 98 | -------------------------------------------------------------------------------- /test/expect_yaml/passing/pp.ml: -------------------------------------------------------------------------------- 1 | let () = Ppxlib.Driver.standalone () 2 | -------------------------------------------------------------------------------- /test/expect_yaml/passing/recursive.expected: -------------------------------------------------------------------------------- 1 | type t = { 2 | name: string ; 3 | children: t list }[@@deriving yaml] 4 | include 5 | struct 6 | let rec to_yaml (x : t) = 7 | `O 8 | (Stdlib.List.filter_map (fun x -> x) 9 | [Some ("name", (((fun (x : string) -> `String x)) x.name)); 10 | Some 11 | ("children", 12 | (((fun x -> `A (List.map (fun x -> to_yaml x) x))) x.children))]) 13 | let rec of_yaml = 14 | let (>>=) v f = match v with | Ok v -> f v | Error _ as e -> e[@@warning 15 | "-26"] in 16 | function 17 | | `O xs -> 18 | let rec loop xs ((arg0, arg1) as _state) = 19 | match xs with 20 | | ("name", x)::xs -> 21 | loop xs 22 | (((function 23 | | `String x -> Ok x 24 | | _ -> 25 | Error 26 | (`Msg 27 | "Was expecting 'string' but got a different type")) 28 | x), arg1) 29 | | ("children", x)::xs -> 30 | loop xs 31 | (arg0, 32 | ((function 33 | | `A lst -> 34 | let (>>=) v f = 35 | match v with | Ok v -> f v | Error _ as e -> e in 36 | ((fun f -> 37 | fun lst -> 38 | (Stdlib.List.fold_left 39 | (fun acc -> 40 | fun x -> 41 | match acc with 42 | | Stdlib.Ok acc -> 43 | (f x) >>= 44 | ((fun x -> Stdlib.Ok (x :: acc))) 45 | | Stdlib.Error e -> Stdlib.Error e) 46 | (Stdlib.Ok []) lst) 47 | >>= 48 | (fun lst -> Stdlib.Ok (Stdlib.List.rev lst)))) 49 | (fun x -> of_yaml x) lst 50 | | _ -> 51 | Error 52 | (`Msg 53 | "Was expecting 'list' but got a different type")) 54 | x)) 55 | | [] -> 56 | arg1 >>= 57 | ((fun arg1 -> 58 | arg0 >>= 59 | (fun arg0 -> Ok { name = arg0; children = arg1 }))) 60 | | (x, _y)::_ -> 61 | Error (`Msg ("Failed to find the case for: " ^ x)) in 62 | loop xs 63 | ((Error (`Msg "Didn't find the function for key: name")), 64 | (Error (`Msg "Didn't find the function for key: children"))) 65 | | _ -> 66 | Error (`Msg "Failed building a key-value object expecting a list") 67 | end[@@ocaml.doc "@inline"][@@merlin.hide ] 68 | -------------------------------------------------------------------------------- /test/expect_yaml/passing/recursive.ml: -------------------------------------------------------------------------------- 1 | type t = { name : string; children : t list } [@@deriving yaml] 2 | -------------------------------------------------------------------------------- /test/expect_yaml/passing/simple.expected: -------------------------------------------------------------------------------- 1 | type var = 2 | | Hello 3 | | World of string [@@deriving yaml] 4 | include 5 | struct 6 | let var_to_yaml = 7 | function 8 | | Hello -> `O [("Hello", (`A []))] 9 | | World arg0 -> 10 | `O [("World", (`A [((fun (x : string) -> `String x)) arg0]))] 11 | let var_of_yaml = 12 | let (>>=) v f = match v with | Ok v -> f v | Error _ as e -> e[@@warning 13 | "-26"] in 14 | function 15 | | `O (("Hello", `A [])::[]) -> Stdlib.Result.Ok Hello 16 | | `O (("World", `A (arg0::[]))::[]) -> 17 | ((function 18 | | `String x -> Ok x 19 | | _ -> 20 | Error 21 | (`Msg "Was expecting 'string' but got a different type")) 22 | arg0) 23 | >>= ((fun arg0 -> Stdlib.Result.Ok (World arg0))) 24 | | _ -> Stdlib.Error (`Msg "no match for this variant expression") 25 | end[@@ocaml.doc "@inline"][@@merlin.hide ] 26 | type poly_var = [ `Hello | `World of string ][@@deriving yaml] 27 | include 28 | struct 29 | let poly_var_to_yaml = 30 | function 31 | | `Hello -> `O [("Hello", (`A []))] 32 | | `World x -> 33 | ((fun (x : string) -> `String x) x) |> 34 | ((fun x -> `O [("World", (`A [x]))])) 35 | let poly_var_of_yaml = 36 | let (>>=) v f = match v with | Ok v -> f v | Error _ as e -> e[@@warning 37 | "-26"] in 38 | function 39 | | `O (("Hello", `A [])::[]) -> Stdlib.Result.Ok `Hello 40 | | `O (("World", `A (x::[]))::[]) -> 41 | ((function 42 | | `String x -> Ok x 43 | | _ -> 44 | Error 45 | (`Msg "Was expecting 'string' but got a different type")) x) 46 | >>= ((fun x -> Stdlib.Result.Ok (`World x))) 47 | | _ -> Error (`Msg "failed converting variant") 48 | end[@@ocaml.doc "@inline"][@@merlin.hide ] 49 | type a = { 50 | x: [ `Simple | `Example ] }[@@deriving yaml] 51 | include 52 | struct 53 | let a_to_yaml (x : a) = 54 | `O 55 | (Stdlib.List.filter_map (fun x -> x) 56 | [Some 57 | ("x", 58 | (((function 59 | | `Simple -> `O [("Simple", (`A []))] 60 | | `Example -> `O [("Example", (`A []))])) x.x))]) 61 | let a_of_yaml = 62 | let (>>=) v f = match v with | Ok v -> f v | Error _ as e -> e[@@warning 63 | "-26"] in 64 | function 65 | | `O xs -> 66 | let rec loop xs (arg0 as _state) = 67 | match xs with 68 | | ("x", x)::xs -> 69 | loop xs 70 | ((let (>>=) v f = 71 | match v with | Ok v -> f v | Error _ as e -> e[@@warning 72 | "-26"] in 73 | function 74 | | `O (("Simple", `A [])::[]) -> Stdlib.Result.Ok `Simple 75 | | `O (("Example", `A [])::[]) -> 76 | Stdlib.Result.Ok `Example 77 | | _ -> Error (`Msg "failed converting variant")) x) 78 | | [] -> arg0 >>= ((fun arg0 -> Ok { x = arg0 })) 79 | | (x, _y)::_ -> 80 | Error (`Msg ("Failed to find the case for: " ^ x)) in 81 | loop xs (Error (`Msg "Didn't find the function for key: x")) 82 | | _ -> 83 | Error (`Msg "Failed building a key-value object expecting a list") 84 | end[@@ocaml.doc "@inline"][@@merlin.hide ] 85 | type t = { 86 | name: string ; 87 | age: int option }[@@deriving yaml] 88 | include 89 | struct 90 | let to_yaml (x : t) = 91 | `O 92 | (Stdlib.List.filter_map (fun x -> x) 93 | [Some ("name", (((fun (x : string) -> `String x)) x.name)); 94 | Some 95 | ("age", 96 | (((function 97 | | None -> `Null 98 | | Some t -> ((fun (x : int) -> `Float (float_of_int x))) t)) 99 | x.age))]) 100 | let of_yaml = 101 | let (>>=) v f = match v with | Ok v -> f v | Error _ as e -> e[@@warning 102 | "-26"] in 103 | function 104 | | `O xs -> 105 | let rec loop xs ((arg0, arg1) as _state) = 106 | match xs with 107 | | ("name", x)::xs -> 108 | loop xs 109 | (((function 110 | | `String x -> Ok x 111 | | _ -> 112 | Error 113 | (`Msg 114 | "Was expecting 'string' but got a different type")) 115 | x), arg1) 116 | | ("age", x)::xs -> 117 | loop xs 118 | (arg0, 119 | ((function 120 | | `Null -> Ok None 121 | | x -> 122 | ((function 123 | | `Float x -> Ok (int_of_float x) 124 | | _ -> 125 | Error 126 | (`Msg 127 | "Was expecting 'int' but got a different type")) 128 | x) 129 | >>= ((fun x -> Ok (Some x)))) x)) 130 | | [] -> 131 | arg1 >>= 132 | ((fun arg1 -> 133 | arg0 >>= (fun arg0 -> Ok { name = arg0; age = arg1 }))) 134 | | (x, _y)::_ -> 135 | Error (`Msg ("Failed to find the case for: " ^ x)) in 136 | loop xs 137 | ((Error (`Msg "Didn't find the function for key: name")), 138 | (Ok None)) 139 | | _ -> 140 | Error (`Msg "Failed building a key-value object expecting a list") 141 | end[@@ocaml.doc "@inline"][@@merlin.hide ] 142 | type u = { 143 | name: string [@default "Una"]}[@@deriving to_yaml] 144 | include 145 | struct 146 | let u_to_yaml (x : u) = 147 | `O 148 | (Stdlib.List.filter_map (fun x -> x) 149 | [((fun x -> 150 | if Stdlib.(=) x "Una" 151 | then None 152 | else Some ("name", (((fun (x : string) -> `String x)) x)))) 153 | x.name]) 154 | end[@@ocaml.doc "@inline"][@@merlin.hide ] 155 | type v = { 156 | age: int [@key "AGE"][@default 10]}[@@deriving of_yaml] 157 | include 158 | struct 159 | let v_of_yaml = 160 | let (>>=) v f = match v with | Ok v -> f v | Error _ as e -> e[@@warning 161 | "-26"] in 162 | function 163 | | `O xs -> 164 | let rec loop xs (arg0 as _state) = 165 | match xs with 166 | | ("AGE", x)::xs -> 167 | loop xs 168 | ((function 169 | | `Float x -> Ok (int_of_float x) 170 | | _ -> 171 | Error 172 | (`Msg 173 | "Was expecting 'int' but got a different type")) 174 | x) 175 | | [] -> arg0 >>= ((fun arg0 -> Ok { age = arg0 })) 176 | | (x, _y)::_ -> 177 | Error (`Msg ("Failed to find the case for: " ^ x)) in 178 | loop xs (Ok 10) 179 | | _ -> 180 | Error (`Msg "Failed building a key-value object expecting a list") 181 | end[@@ocaml.doc "@inline"][@@merlin.hide ] 182 | type w = { 183 | age: int [@to_yaml fun i -> `Float (float_of_int (i - 10))]}[@@deriving 184 | yaml] 185 | include 186 | struct 187 | let w_to_yaml (x : w) = 188 | `O 189 | (Stdlib.List.filter_map (fun x -> x) 190 | [Some ("age", (((fun i -> `Float (float_of_int (i - 10)))) x.age))]) 191 | let w_of_yaml = 192 | let (>>=) v f = match v with | Ok v -> f v | Error _ as e -> e[@@warning 193 | "-26"] in 194 | function 195 | | `O xs -> 196 | let rec loop xs (arg0 as _state) = 197 | match xs with 198 | | ("age", x)::xs -> 199 | loop xs 200 | ((function 201 | | `Float x -> Ok (int_of_float x) 202 | | _ -> 203 | Error 204 | (`Msg 205 | "Was expecting 'int' but got a different type")) 206 | x) 207 | | [] -> arg0 >>= ((fun arg0 -> Ok { age = arg0 })) 208 | | (x, _y)::_ -> 209 | Error (`Msg ("Failed to find the case for: " ^ x)) in 210 | loop xs (Error (`Msg "Didn't find the function for key: age")) 211 | | _ -> 212 | Error (`Msg "Failed building a key-value object expecting a list") 213 | end[@@ocaml.doc "@inline"][@@merlin.hide ] 214 | type x = 215 | { 216 | age: int 217 | [@of_yaml 218 | function 219 | | `Float f -> Ok (int_of_float (f +. 10.)) 220 | | _ -> Error (`Msg "Expected a Yaml `Float")]}[@@deriving yaml] 221 | include 222 | struct 223 | let x_to_yaml (x : x) = 224 | `O 225 | (Stdlib.List.filter_map (fun x -> x) 226 | [Some 227 | ("age", (((fun (x : int) -> `Float (float_of_int x))) x.age))]) 228 | let x_of_yaml = 229 | let (>>=) v f = match v with | Ok v -> f v | Error _ as e -> e[@@warning 230 | "-26"] in 231 | function 232 | | `O xs -> 233 | let rec loop xs (arg0 as _state) = 234 | match xs with 235 | | ("age", x)::xs -> 236 | loop xs 237 | ((function 238 | | `Float f -> Ok (int_of_float (f +. 10.)) 239 | | _ -> Error (`Msg "Expected a Yaml `Float")) x) 240 | | [] -> arg0 >>= ((fun arg0 -> Ok { age = arg0 })) 241 | | (x, _y)::_ -> 242 | Error (`Msg ("Failed to find the case for: " ^ x)) in 243 | loop xs (Error (`Msg "Didn't find the function for key: age")) 244 | | _ -> 245 | Error (`Msg "Failed building a key-value object expecting a list") 246 | end[@@ocaml.doc "@inline"][@@merlin.hide ] 247 | -------------------------------------------------------------------------------- /test/expect_yaml/passing/simple.ml: -------------------------------------------------------------------------------- 1 | type var = Hello | World of string [@@deriving yaml] 2 | type poly_var = [ `Hello | `World of string ] [@@deriving yaml] 3 | type a = { x : [ `Simple | `Example ] } [@@deriving yaml] 4 | type t = { name : string; age : int option } [@@deriving yaml] 5 | type u = { name : string [@default "Una"] } [@@deriving to_yaml] 6 | type v = { age : int [@key "AGE"] [@default 10] } [@@deriving of_yaml] 7 | 8 | type w = { age : int [@to_yaml fun i -> `Float (float_of_int (i - 10))] } 9 | [@@deriving yaml] 10 | 11 | type x = { 12 | age : int; 13 | [@of_yaml 14 | function 15 | | `Float f -> Ok (int_of_float (f +. 10.)) 16 | | _ -> Error (`Msg "Expected a Yaml `Float")] 17 | } 18 | [@@deriving yaml] 19 | -------------------------------------------------------------------------------- /test/expect_yaml/passing/skip_unknown.expected: -------------------------------------------------------------------------------- 1 | type t = { 2 | name: string ; 3 | age: int }[@@deriving of_yaml ~skip_unknown] 4 | include 5 | struct 6 | let of_yaml = 7 | let (>>=) v f = match v with | Ok v -> f v | Error _ as e -> e[@@warning 8 | "-26"] in 9 | function 10 | | `O xs -> 11 | let rec loop xs ((arg0, arg1) as _state) = 12 | match xs with 13 | | ("name", x)::xs -> 14 | loop xs 15 | (((function 16 | | `String x -> Ok x 17 | | _ -> 18 | Error 19 | (`Msg 20 | "Was expecting 'string' but got a different type")) 21 | x), arg1) 22 | | ("age", x)::xs -> 23 | loop xs 24 | (arg0, 25 | ((function 26 | | `Float x -> Ok (int_of_float x) 27 | | _ -> 28 | Error 29 | (`Msg 30 | "Was expecting 'int' but got a different type")) 31 | x)) 32 | | [] -> 33 | arg1 >>= 34 | ((fun arg1 -> 35 | arg0 >>= (fun arg0 -> Ok { name = arg0; age = arg1 }))) 36 | | _::xs -> loop xs _state in 37 | loop xs 38 | ((Error (`Msg "Didn't find the function for key: name")), 39 | (Error (`Msg "Didn't find the function for key: age"))) 40 | | _ -> 41 | Error (`Msg "Failed building a key-value object expecting a list") 42 | end[@@ocaml.doc "@inline"][@@merlin.hide ] 43 | -------------------------------------------------------------------------------- /test/expect_yaml/passing/skip_unknown.ml: -------------------------------------------------------------------------------- 1 | type t = { name : string; age : int } [@@deriving of_yaml ~skip_unknown] 2 | -------------------------------------------------------------------------------- /test/test.ml: -------------------------------------------------------------------------------- 1 | let yaml = Alcotest.testable Yaml.pp Stdlib.( = ) 2 | let pp_error ppf (`Msg x) = Fmt.string ppf x 3 | let error = Alcotest.testable pp_error ( = ) 4 | 5 | type str = string [@@deriving yaml] 6 | type flo = float [@@deriving yaml] 7 | 8 | let flo = Alcotest.testable Format.pp_print_float Stdlib.( = ) 9 | 10 | type integer = int [@@deriving yaml] 11 | type boolean = bool [@@deriving yaml] 12 | 13 | let test_primitives () = 14 | let correct_str = `String "hello world" in 15 | let test_str = str_to_yaml "hello world" in 16 | let correct_str_of = "hello world" in 17 | let test_str_of = str_of_yaml correct_str in 18 | let correct_float = `Float 1.234 in 19 | let test_float = flo_to_yaml 1.234 in 20 | let correct_float_of = 1.234 in 21 | let test_float_of = flo_of_yaml correct_float in 22 | let correct_float_int = `Float 1. in 23 | let test_float_int = integer_to_yaml 1 in 24 | let correct_float_int_of = 1 in 25 | let test_float_int_of = integer_of_yaml correct_float_int in 26 | let correct_bool = `Bool true in 27 | let test_bool = boolean_to_yaml true in 28 | let correct_bool_of = true in 29 | let test_bool_of = boolean_of_yaml correct_bool in 30 | Alcotest.check yaml "(to_yaml) same string" correct_str test_str; 31 | Alcotest.(check (result string error)) 32 | "(of_yaml) same string" (Ok correct_str_of) test_str_of; 33 | Alcotest.check yaml "(to_yaml) same float" correct_float test_float; 34 | Alcotest.(check (result flo error)) 35 | "(of_yaml) same float" (Ok correct_float_of) test_float_of; 36 | Alcotest.check yaml "(to_yaml) same float from int" correct_float_int 37 | test_float_int; 38 | Alcotest.(check (result int error)) 39 | "(of_yaml) same int from int" (Ok correct_float_int_of) test_float_int_of; 40 | Alcotest.check yaml "(to_yaml) same bool" correct_bool test_bool; 41 | Alcotest.(check (result bool error)) 42 | "(of_yaml) same bool" (Ok correct_bool_of) test_bool_of 43 | 44 | type person = { name : string; [@default "Alice"] age : int } [@@deriving yaml] 45 | 46 | let pp_person ppf x = 47 | Format.pp_print_string ppf x.name; 48 | Format.pp_print_int ppf x.age 49 | 50 | type users = { db : person list } [@@deriving yaml] 51 | 52 | let users = 53 | Alcotest.testable 54 | (fun ppf users -> List.iter (pp_person ppf) users.db) 55 | Stdlib.( = ) 56 | 57 | let test_record_list () = 58 | let correct = 59 | `O 60 | [ 61 | ( "db", 62 | `A 63 | [ 64 | `O [ ("age", `Float 20.) ]; 65 | `O [ ("name", `String "Bob"); ("age", `Float 21.) ]; 66 | ] ); 67 | ] 68 | in 69 | let with_default_correct = 70 | `O 71 | [ 72 | ( "db", 73 | `A 74 | [ 75 | `O [ ("age", `Float 20.) ]; 76 | `O [ ("name", `String "Bob"); ("age", `Float 21.) ]; 77 | ] ); 78 | ] 79 | in 80 | let test = 81 | users_to_yaml 82 | { db = [ { name = "Alice"; age = 20 }; { name = "Bob"; age = 21 } ] } 83 | in 84 | let correct_of : (users, [> `Msg of string ]) result = 85 | Ok { db = [ { name = "Alice"; age = 20 }; { name = "Bob"; age = 21 } ] } 86 | in 87 | let test_of = users_of_yaml correct in 88 | let test_of_default = users_of_yaml with_default_correct in 89 | Alcotest.check yaml "(to_yaml) same object" correct test; 90 | Alcotest.(check (result users error)) 91 | "(of_yaml) same object" correct_of test_of; 92 | Alcotest.(check (result users error)) 93 | "(of_yaml) same object" correct_of test_of_default 94 | 95 | type tup = int * string * float [@@deriving yaml] 96 | 97 | let tup = 98 | Alcotest.testable 99 | (fun ppf (a, b, c) -> 100 | Format.pp_print_int ppf a; 101 | Format.pp_print_string ppf b; 102 | Format.pp_print_float ppf c) 103 | Stdlib.( = ) 104 | 105 | let test_tuple () = 106 | let correct = `A [ `Float 1.; `String "OCaml"; `Float 3.14 ] in 107 | let test = tup_to_yaml (1, "OCaml", 3.14) in 108 | let correct_of = Ok (1, "OCaml", 3.14) in 109 | let test_of = tup_of_yaml correct in 110 | Alcotest.check yaml "same tuple (list)" correct test; 111 | Alcotest.(check (result tup error)) "(of_yaml) same tuple" correct_of test_of 112 | 113 | type 'a pol = { txt : 'a } [@@deriving yaml] 114 | 115 | let str_pol = 116 | Alcotest.testable (fun ppf x -> Format.pp_print_string ppf x.txt) Stdlib.( = ) 117 | 118 | let test_simple_poly () = 119 | let correct_str = `O [ ("txt", `String "arg0") ] in 120 | let test_str = pol_to_yaml (fun x -> `String x) { txt = "arg0" } in 121 | let correct_str_of = { txt = "arg0" } in 122 | let test_str_of = 123 | pol_of_yaml (function `String s -> Ok s | _ -> failwith "") correct_str 124 | in 125 | Alcotest.check yaml "(to_yaml) same polymorhpic record" correct_str test_str; 126 | Alcotest.(check (result str_pol error)) 127 | "(of_yaml) same polymorhpic record" (Ok correct_str_of) test_str_of 128 | 129 | type var = Alpha | Beta of int | Gamma of string * int [@@deriving yaml] 130 | 131 | let var = 132 | Alcotest.testable 133 | (fun ppf -> function 134 | | Alpha -> Fmt.string ppf "Alpha" 135 | | Beta i -> Fmt.pf ppf "Beta %i" i 136 | | Gamma (s, i) -> Fmt.pf ppf "Gamma (%s,%i)" s i) 137 | Stdlib.( = ) 138 | 139 | let test_var () = 140 | let correct_yaml_a = `O [ ("Alpha", `A []) ] in 141 | let test_yaml_a = var_to_yaml Alpha in 142 | let correct_yaml_b = `O [ ("Beta", `A [ `Float 3. ]) ] in 143 | let test_yaml_b = var_to_yaml (Beta 3) in 144 | let correct_yaml_c = `O [ ("Gamma", `A [ `String "hello"; `Float 3. ]) ] in 145 | let test_yaml_c = var_to_yaml (Gamma ("hello", 3)) in 146 | let correct_yaml_a_of = Ok Alpha in 147 | let test_yaml_a_of = var_of_yaml correct_yaml_a in 148 | let correct_yaml_b_of = Ok (Beta 3) in 149 | let test_yaml_b_of = var_of_yaml correct_yaml_b in 150 | let correct_yaml_c_of = Ok (Gamma ("hello", 3)) in 151 | let test_yaml_c_of = var_of_yaml correct_yaml_c in 152 | Alcotest.check yaml "same variant" correct_yaml_a test_yaml_a; 153 | Alcotest.check yaml "same variant" correct_yaml_b test_yaml_b; 154 | Alcotest.check yaml "same variant" correct_yaml_c test_yaml_c; 155 | Alcotest.(check (result var error)) 156 | "(of_yaml) same variant" correct_yaml_a_of test_yaml_a_of; 157 | Alcotest.(check (result var error)) 158 | "(of_yaml) same variant" correct_yaml_b_of test_yaml_b_of; 159 | Alcotest.(check (result var error)) 160 | "(of_yaml) same variant" correct_yaml_c_of test_yaml_c_of 161 | 162 | type poly_var = [ `Alpha | `Beta of int | `Gamma of string * int ] 163 | [@@deriving yaml] 164 | 165 | let poly_var : poly_var Alcotest.testable = 166 | Alcotest.testable 167 | (fun ppf -> function 168 | | `Alpha -> Fmt.pf ppf "Alpha" 169 | | `Beta i -> Fmt.pf ppf "Beta %i" i 170 | | `Gamma (s, i) -> Fmt.pf ppf "Gamma (%s, %i)" s i) 171 | Stdlib.( = ) 172 | 173 | let test_poly_variants () = 174 | let correct_yaml_a = `O [ ("Alpha", `A []) ] in 175 | let test_yaml_a = poly_var_to_yaml `Alpha in 176 | let correct_yaml_b = `O [ ("Beta", `A [ `Float 3. ]) ] in 177 | let test_yaml_b = poly_var_to_yaml (`Beta 3) in 178 | let correct_yaml_c = `O [ ("Gamma", `A [ `String "hello"; `Float 3. ]) ] in 179 | let test_yaml_c = poly_var_to_yaml (`Gamma ("hello", 3)) in 180 | let correct_yaml_a_of = Ok `Alpha in 181 | let test_yaml_a_of = poly_var_of_yaml correct_yaml_a in 182 | let correct_yaml_b_of = Ok (`Beta 3) in 183 | let test_yaml_b_of = poly_var_of_yaml correct_yaml_b in 184 | let correct_yaml_c_of = Ok (`Gamma ("hello", 3)) in 185 | let test_yaml_c_of = poly_var_of_yaml correct_yaml_c in 186 | Alcotest.check yaml "same polymorphic variant" correct_yaml_a test_yaml_a; 187 | Alcotest.check yaml "same polymorphic variant" correct_yaml_b test_yaml_b; 188 | Alcotest.check yaml "same polymorphic variant" correct_yaml_c test_yaml_c; 189 | Alcotest.(check (result poly_var error)) 190 | "(of_yaml) same polymorphic variant" correct_yaml_a_of test_yaml_a_of; 191 | Alcotest.(check (result poly_var error)) 192 | "(of_yaml) same polymorphic variant" correct_yaml_b_of test_yaml_b_of; 193 | Alcotest.(check (result poly_var error)) 194 | "(of_yaml) same polymorphic variant" correct_yaml_c_of test_yaml_c_of 195 | 196 | (** Attributes *) 197 | type vattrib = Camel of int [@name "camel"] [@@deriving yaml] 198 | 199 | type rattrib = { camel_name : string [@key "camel-name"] } [@@deriving yaml] 200 | 201 | let vattrib = 202 | Alcotest.testable (fun ppf (Camel i) -> Fmt.int ppf i) Stdlib.( = ) 203 | 204 | let rattrib = 205 | Alcotest.testable 206 | (fun ppf v -> Fmt.pf ppf "{ camel-name: %s }" v.camel_name) 207 | Stdlib.( = ) 208 | 209 | let test_attrib () = 210 | let correct_yaml_v = `O [ ("camel", `A [ `Float 1. ]) ] in 211 | let test_yaml_v = vattrib_to_yaml (Camel 1) in 212 | let correct_yaml_r = `O [ ("camel-name", `String "lawrence") ] in 213 | let test_yaml_r = rattrib_to_yaml { camel_name = "lawrence" } in 214 | let correct_yaml_v_of = Ok (Camel 1) in 215 | let test_yaml_v_of = vattrib_of_yaml correct_yaml_v in 216 | let correct_yaml_r_of = Ok { camel_name = "lawrence" } in 217 | let test_yaml_r_of = rattrib_of_yaml correct_yaml_r in 218 | Alcotest.check yaml "same variant" correct_yaml_v test_yaml_v; 219 | Alcotest.check yaml "same record" correct_yaml_r test_yaml_r; 220 | Alcotest.(check (result vattrib error)) 221 | "(of_yaml) same variant" correct_yaml_v_of test_yaml_v_of; 222 | Alcotest.(check (result rattrib error)) 223 | "(of_yaml) same record" correct_yaml_r_of test_yaml_r_of 224 | 225 | type unknown = { name : string; age : int } [@@deriving yaml ~skip_unknown] 226 | 227 | let unknown = Alcotest.of_pp (fun ppf v -> Yaml.pp ppf (unknown_to_yaml v)) 228 | 229 | let test_unknown () = 230 | let yaml = "name: Bob\nmisc: We don't need this!\nage: 42" in 231 | let v = Yaml.of_string_exn yaml |> unknown_of_yaml in 232 | let expected = Ok { name = "Bob"; age = 42 } in 233 | Alcotest.(check (result unknown error)) "same unknown" expected v 234 | 235 | type recursive = { name : string; children : recursive list } [@@deriving yaml] 236 | 237 | let recursive = Alcotest.of_pp (fun ppf v -> Yaml.pp ppf (recursive_to_yaml v)) 238 | 239 | let test_recursive () = 240 | let yaml = "name: Bob\nchildren:\n - name: Alice\n children: []\n" in 241 | let v = Yaml.of_string_exn yaml |> recursive_of_yaml in 242 | let expected = 243 | Ok { name = "Bob"; children = [ { name = "Alice"; children = [] } ] } 244 | in 245 | Alcotest.(check (result recursive error)) "same unknown" expected v 246 | 247 | let tests : unit Alcotest.test_case list = 248 | [ 249 | ("test_primitives", `Quick, test_primitives); 250 | ("test_record_list", `Quick, test_record_list); 251 | ("test_tuple", `Quick, test_tuple); 252 | ("test_simple_poly", `Quick, test_simple_poly); 253 | ("test_var", `Quick, test_var); 254 | ("test_poly_variants", `Quick, test_poly_variants); 255 | ("test_attrib", `Quick, test_attrib); 256 | ("test_unknown", `Quick, test_unknown); 257 | ("test_recursive", `Quick, test_recursive); 258 | ] 259 | 260 | let () = Alcotest.run "ppx_deriving_yaml" [ ("ppx", tests) ] 261 | --------------------------------------------------------------------------------