├── .github └── workflows │ └── build.yml ├── .gitignore ├── .ocamlformat ├── CHANGES.md ├── LICENSE ├── Makefile ├── README.md ├── __tests__ ├── decoders_bs_json_test.ml └── decoders_bs_xml_test.ml ├── bsconfig.json ├── decoders-bencode.opam ├── decoders-cbor.opam ├── decoders-ezjsonm.opam ├── decoders-ezxmlm.opam ├── decoders-jsonaf.opam ├── decoders-jsonm.opam ├── decoders-msgpck.opam ├── decoders-msgpck.opam.template ├── decoders-otoml.opam ├── decoders-sexplib.opam ├── decoders-yojson.opam ├── decoders.opam ├── dune ├── dune-project ├── flake.lock ├── flake.nix ├── package-lock.json ├── package.json ├── src-bencode ├── decode.ml ├── decode.mli ├── dune ├── encode.ml └── encode.mli ├── src-bs ├── bs_json.ml ├── bs_json.mli ├── bs_xml.ml ├── bs_xml.mli ├── shims_let_ops_.ml ├── util.ml └── util.mli ├── src-cbor ├── decode.ml ├── decode.mli ├── dune ├── encode.ml └── encode.mli ├── src-ezjsonm ├── decode.ml ├── decode.mli ├── dune ├── encode.ml └── encode.mli ├── src-ezxmlm ├── decode.ml ├── decode.mli └── dune ├── src-jsonaf ├── decoders_jsonaf.ml ├── dune ├── jsonaf_decodeable.ml ├── jsonaf_decodeable.mli ├── jsonaf_encodeable.ml └── jsonaf_encodeable.mli ├── src-jsonm ├── dune ├── encode.ml └── encode.mli ├── src-msgpck ├── decode.ml ├── decode.mli ├── dune ├── encode.ml └── encode.mli ├── src-ocyaml ├── decode.ml ├── decode.mli └── dune ├── src-otoml ├── decoders_otoml.ml ├── decoders_otoml.mli └── dune ├── src-sexplib ├── decode.ml ├── decode.mli └── dune ├── src-yojson ├── basic.ml ├── basic.mli ├── dune ├── raw.ml ├── raw.mli ├── safe.ml └── safe.mli ├── src ├── decode.ml ├── decode.mli ├── decoder.ml ├── decoder.mli ├── decoders.ml ├── dune ├── encode.ml ├── encode.mli ├── error.ml ├── error.mli ├── gen │ ├── dune │ └── mkshims.ml ├── sig.ml ├── util.ml ├── util.mli └── xml.ml ├── test-bencode ├── dune └── main.ml ├── test-cbor ├── dune └── main.ml ├── test-ezjsonm ├── dune └── main.ml ├── test-ezxmlm ├── dune ├── test_ezxmlm_decode.expected └── test_ezxmlm_decode.ml ├── test-jsonaf ├── dune └── main.ml ├── test-jsonm ├── dune └── main.ml ├── test-msgpck ├── dune └── main.ml ├── test-otoml ├── dune └── main.ml ├── test-sexplib ├── dune └── main.ml └── test-yojson ├── dune └── main.ml /.github/workflows/build.yml: -------------------------------------------------------------------------------- 1 | name: build 2 | 3 | on: 4 | pull_request: 5 | push: 6 | branches: 7 | - master 8 | 9 | jobs: 10 | build-ocaml: 11 | strategy: 12 | fail-fast: false 13 | matrix: 14 | os: 15 | - ubuntu-latest 16 | - windows-latest 17 | - macos-latest 18 | ocaml-compiler: 19 | - 4.14.x 20 | package: 21 | - decoders-bencode 22 | - decoders-cbor 23 | - decoders-ezjsonm 24 | - decoders-ezxmlm 25 | - decoders-jsonaf 26 | - decoders-jsonm 27 | - decoders-msgpck 28 | - decoders-sexplib 29 | - decoders-yojson 30 | include: 31 | - os: ubuntu-latest 32 | ocaml-compiler: 4.08.x 33 | package: decoders-yojson 34 | 35 | 36 | runs-on: ${{ matrix.os }} 37 | 38 | steps: 39 | - uses: actions/checkout@v3 40 | 41 | - name: Use OCaml ${{ matrix.ocaml-compiler }} 42 | uses: ocaml/setup-ocaml@v2 43 | with: 44 | ocaml-compiler: ${{ matrix.ocaml-compiler }} 45 | opam-depext-flags: --with-test 46 | allow-prerelease-opam: true 47 | dune-cache: true 48 | opam-local-packages: | 49 | decoders.opam 50 | ${{ matrix.package }}.opam 51 | 52 | - run: opam install "${{ matrix.package }}" --with-test 53 | 54 | build-node: 55 | strategy: 56 | fail-fast: false 57 | matrix: 58 | os: 59 | - ubuntu-latest 60 | node-version: 61 | - 16.x 62 | 63 | runs-on: ${{ matrix.os }} 64 | 65 | steps: 66 | - uses: actions/checkout@v3 67 | 68 | - name: Use Node.js ${{ matrix.node-version }} 69 | uses: actions/setup-node@v3 70 | with: 71 | node-version: ${{ matrix.node-version }} 72 | cache: 'npm' 73 | 74 | - run: npm ci 75 | - run: npm run build 76 | - run: npm test 77 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.install 2 | .merlin 3 | _build 4 | _opam 5 | *.bs.js 6 | .bsb.lock 7 | /lib/ 8 | /node_modules/ 9 | .DS_Store 10 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | version = 0.20.1 2 | profile = sparse 3 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | ## v1.0.0 (2022-08-08) 2 | 3 | * Extract and expose `Decoder.t`, useful for "decoding" things outside of the JSON family (#40, @mattjbray). 4 | * Add `Decoders.Xml.S` to `decoders`, create `decoders-ezxmlm`, and add `Decoders_bs_xml` to `bs-decoders` (#49, @mattjbray). 5 | * BREAKING: namespace `bs-decoders` modules under `Decoders`. To upgrade, 6 | replace `Decoders_bs` with `Decoders.Bs_json` (#49, @mattjbray). 7 | * Add `decoders-jsonaf` (#50, @dvmitrv). 8 | 9 | ## 0.7.0 (2022-05-11) 10 | 11 | * Add `Decode.field_opt_or` (#43, @c-cube) 12 | * Add `Decode.pick` (#43, @c-cube) 13 | * Add `Decode.decode_sub` (#45, @c-cube) 14 | 15 | ### `bs-decoders` 16 | 17 | * Improve `int` decoder (@actionshrimp) 18 | 19 | ### `decoders-yojson` 20 | 21 | * Move away from deprecated `Yojson.json` to `Yojson.t` (#37, @idkjs) 22 | 23 | ## 0.6.0 (2021-03-12) 24 | 25 | * Add `Decode.of_of_string` and `Encode.of_to_string` (@mattjbray) 26 | * Add `Decode.array` with bs-specific impl (#28, #30, @actionshrimp) 27 | 28 | ## 0.5.0 (2020-10-28) 29 | 30 | * Add `Decoders_msgpck` (#26, @c-cube) 31 | * Add `let` operators (#24, @c-cube) 32 | * Alias `Decode.map` as `<$>` (#21, @hamza0867) 33 | 34 | ## 0.4.0 (2020-05-06) 35 | 36 | * Expose `null` decoder (#18, @mattjbray) 37 | * Rename `Encode.option` to `Encode.nullable` (#19, @mattjbray) 38 | * Add `Decoders_jsonm` (#20, @mattjbray) 39 | 40 | ## 0.3.0 (2019-06-24) 41 | 42 | * Add `uncons` primitive (#7, @mattjbray) 43 | * Add `Decoders_sexplib` (#7, @mattjbray) 44 | * Add `Decoders_cbor` (#9, @mattjbray) 45 | * Add `Decoders_bencode` (#14, @c-cube) 46 | * Remove `containers` dependency (#16, @c-cube) 47 | 48 | ## 0.2.0 (2019-06-24) 49 | 50 | * Add `field_opt` decoder (#5, @actionshrimp) 51 | * Add `list_fold_left` decoder (#8, @ewenmaclean) 52 | 53 | ## 0.1.2 (2019-01-09) 54 | 55 | * Upgrade from `jbuilder` to `dune` 56 | * Remove `cppo` build dependency (#4) 57 | 58 | ## 0.1.1 (2018-12-13) 59 | 60 | * Fix some non-tail-recursive stuff. 61 | * Add `stringlit` encoder and decoder for `Decoders_yojson.Raw` 62 | 63 | ## 0.1.0 (2018-09-26) 64 | 65 | Initial release. 66 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | ISC -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: all 2 | all: build test build-bs test-bs 3 | 4 | .PHONY: clean-all 5 | clean-all: clean clean-bs 6 | 7 | .PHONY: build 8 | build: 9 | dune build 10 | 11 | .PHONY: test 12 | test: 13 | dune runtest 14 | 15 | .PHONY: watch-check 16 | watch-check: 17 | dune build @check --watch 18 | 19 | .PHONY: watch-test 20 | watch-test: 21 | dune build @runtest --watch 22 | 23 | .PHONY: doc 24 | doc: 25 | dune build @doc 26 | 27 | .PHONY: format 28 | format: 29 | dune build @fmt --auto-promote 30 | 31 | .PHONY: clean 32 | clean: 33 | dune clean 34 | 35 | _opam: 36 | opam switch create . --empty 37 | opam install -y ocaml-base-compiler.4.12.0 utop ocaml-lsp-server 38 | 39 | install-dependencies: _opam 40 | opam install . --deps-only --with-test 41 | 42 | DOCS_WORKTREE_PATH=../ocaml-decoders-doc 43 | 44 | .PHONY: publish-doc 45 | publish-doc: doc 46 | [ -d "$(DOCS_WORKTREE_PATH)" ] || git worktree add "$(DOCS_WORKTREE_PATH)" gh-pages 47 | cd "$(DOCS_WORKTREE_PATH)" && git pull --ff-only 48 | cd "$(DOCS_WORKTREE_PATH)" && git rm -r . 49 | cp -r _build/default/_doc/_html/* "$(DOCS_WORKTREE_PATH)" 50 | COMMIT_SHA=$$(git rev-parse HEAD) && cd "$(DOCS_WORKTREE_PATH)" && git add . && git commit -m "Update docs from revision $${COMMIT_SHA}" 51 | cd "$(DOCS_WORKTREE_PATH)" && git push origin gh-pages 52 | 53 | 54 | 55 | install-bs-dependencies: 56 | npm i 57 | 58 | build-bs: 59 | npm run build 60 | 61 | test-bs: 62 | npm test 63 | 64 | watch-build-bs: 65 | npm run build-watch 66 | 67 | watch-test-bs: 68 | npm run test-watch 69 | 70 | clean-bs: 71 | npm run clean 72 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # ocaml-decoders: Elm-inspired decoders for OCaml 2 | 3 | A combinator library for "decoding" JSON-like values into your own OCaml types, inspired by Elm's `Json.Decode` and `Json.Encode`. 4 | 5 | > Eh? 6 | 7 | An OCaml program having a JSON (or YAML) data source usually goes something like this: 8 | 9 | 1. Get your data from somewhere. Now you have a `string`. 10 | 2. *Parse* the `string` as JSON (or YAML). Now you have a `Yojson.Basic.t`, or maybe an `Ezjsonm.value`. 11 | 3. *Decode* the JSON value to an OCaml type that's actually useful for your program's domain. 12 | 13 | This library helps with step 3. 14 | 15 | # Getting started 16 | 17 | Install one of the supported decoder backends: 18 | 19 | ### For ocaml 20 | 21 | ``` 22 | opam install decoders-bencode # For bencode 23 | opam install decoders-cbor # For CBOR 24 | opam install decoders-ezjsonm # For ezjsonm 25 | opam install decoders-jsonm # For jsonm 26 | opam install decoders-msgpck # For msgpck 27 | opam install decoders-sexplib # For sexplib 28 | opam install decoders-yojson # For yojson 29 | ``` 30 | 31 | ### For bucklescript 32 | 33 | ``` 34 | npm install --save-dev bs-decoders 35 | ``` 36 | 37 | ## Decoding 38 | 39 | Now we can start decoding stuff! 40 | 41 | First, a module alias to save some keystrokes. In this guide, we'll parse JSON 42 | using `Yojson`'s `Basic` variant. 43 | 44 | ```ocaml 45 | utop # module D = Decoders_yojson.Basic.Decode;; 46 | module D = Decoders_yojson.Basic.Decode 47 | ``` 48 | 49 | Let's set our sights high and decode an integer. 50 | 51 | ```ocaml 52 | utop # D.decode_value D.int (`Int 1);; 53 | - : (int, error) result = Ok 1 54 | ``` 55 | 56 | Nice! We used `decode_value`, which takes a `decoder` and a `value` (in this 57 | case a `Yojson.Basic.t`) and... decodes the value. 58 | 59 | ```ocaml 60 | utop # D.decode_value;; 61 | - : 'a decoder -> value -> ('a, error) result = 62 | ``` 63 | 64 | For convenience we also have `decode_string`, which takes a `string` and calls 65 | `Yojson`'s parser under the hood. 66 | 67 | ```ocaml 68 | utop # D.decode_string D.int "1";; 69 | - : (int, error) result = Ok 1 70 | ``` 71 | 72 | What about a `list` of `int`s? Here's where the "combinator" part comes in. 73 | 74 | ```ocaml 75 | utop # D.decode_string D.(list int) "[1,2,3]";; 76 | - : (int list, error) result = Ok [1; 2; 3] 77 | ``` 78 | 79 | Success! 80 | 81 | Ok, so what if we get some unexpected JSON? 82 | 83 | ```ocaml 84 | utop # #install_printer D.pp_error;; 85 | utop # D.decode_string D.(list int) "[1,2,true]";; 86 | - : (int list, error) result = 87 | Error while decoding a list: element 2: Expected an int, but got true 88 | ``` 89 | 90 | ## Complicated JSON structure 91 | 92 | To decode a JSON object with many fields, we can use the let-binding operators 93 | (`let*`, etc.) from the `Infix` module. 94 | 95 | ```ocaml 96 | type my_user = 97 | { name : string 98 | ; age : int 99 | } 100 | 101 | let my_user_decoder : my_user decoder = 102 | let open D in 103 | let* name = field "name" string in 104 | let* age = field "age" int in 105 | succeed { name; age } 106 | ``` 107 | 108 | > *Note for Bucklescript users*: let-binding operators are not currently available 109 | > in Bucklescript, so if you need your decoders to be compatible with Bucklescript 110 | > you can use the monadic bind operator (`>>=`): 111 | > 112 | > ```ocaml 113 | > let my_user_decoder : my_user decoder = 114 | > let open D in 115 | > field "name" string >>= fun name -> 116 | > field "age" int >>= fun age -> 117 | > succeed { name; age } 118 | > ``` 119 | 120 | We can also use these operators to decode objects with inconsistent structure. Say, for 121 | example, our JSON is a list of shapes. Squares have a side length, circles have 122 | a radius, and triangles have a base and a height. 123 | 124 | ```json 125 | [{ "shape": "square", "side": 11 }, 126 | { "shape": "circle", "radius": 5 }, 127 | { "shape": "triange", "base": 3, "height": 7 }] 128 | ``` 129 | 130 | We could represent these types in OCaml and decode them like this: 131 | 132 | ```ocaml 133 | type square = { side : int } 134 | 135 | type circle = { radius : int } 136 | 137 | type triangle = { base : int; height : int } 138 | 139 | type shape = 140 | | Square of square 141 | | Circle of circle 142 | | Triangle of triangle 143 | 144 | let square_decoder : square decoder = 145 | D.(let+ s = field "side" int in { side = s }) 146 | 147 | let circle_decoder : circle decoder = 148 | D.(let+ r = field "radius" int in { radius = r }) 149 | 150 | let triangle_decoder : triangle decoder = 151 | D.( 152 | let* b = field "base" int in 153 | let+ h = field "height" int in 154 | { base = b; height = h }) 155 | 156 | let shape_decoder : shape decoder = 157 | let open D in 158 | let* shape = field "shape" string in 159 | match shape with 160 | | "square" -> let+ s = square_decoder in Square s 161 | | "circle" -> let+ c = circle_decoder in Circle c 162 | | "triangle" -> let+ t = triangle_decoder in Triangle t 163 | | _ -> fail "Expected a shape" 164 | 165 | 166 | let decode_list (json_string : string) : (shape list, _) result = 167 | D.(decode_string (list shape_decoder) json_string) 168 | ``` 169 | 170 | Now, say that we didn't have the benefit of the `"shape"` field describing the 171 | type of the shape in our JSON list. We can still decode the shapes by trying 172 | each decoder in turn using the `one_of` combinator. 173 | 174 | `one_of` takes a list of `string * 'a decoder` pairs and tries each decoder in 175 | turn. The `string` element of each pair is just used to name the decoder in 176 | error messages. 177 | 178 | ```ocaml 179 | let shape_decoder_2 : shape decoder = 180 | D.( 181 | one_of 182 | [ ("a square", let+ s = square_decoder in Square s) 183 | ; ("a circle", let+ c = circle_decoder in Circle c) 184 | ; ("a triangle", let+ t = triangle_decoder in Triangle t) 185 | ] 186 | ) 187 | ``` 188 | 189 | ## Generic decoders 190 | 191 | 192 | Suppose our program deals with users and roles. We want to decode our JSON input 193 | into these types. 194 | 195 | ```ocaml 196 | type role = Admin | User 197 | 198 | type user = 199 | { name : string 200 | ; roles : role list 201 | } 202 | ``` 203 | 204 | Let's define our decoders. We'll write a module functor so we can re-use the 205 | same decoders across different JSON libraries, with YAML input, or with 206 | Bucklescript. 207 | 208 | ```ocaml 209 | module My_decoders(D : Decoders.Decode.S) = struct 210 | open D 211 | 212 | let role : role decoder = 213 | string >>= function 214 | | "ADMIN" -> succeed Admin 215 | | "USER" -> succeed User 216 | | _ -> fail "Expected a role" 217 | 218 | let user : user decoder = 219 | let* name = field "name" string in 220 | let* roles = field "roles" (list role) in 221 | succeed { name; roles } 222 | end 223 | 224 | module My_yojson_decoders = My_decoders(Decoders_yojson.Basic.Decode) 225 | ``` 226 | 227 | Great! Let's try them out. 228 | 229 | ```ocaml 230 | utop # open My_yojson_decoders;; 231 | utop # D.decode_string role {| "USER" |};; 232 | - : (role, error) result = Ok User 233 | 234 | utop # D.decode_string D.(field "users" (list user)) 235 | {| {"users": [{"name": "Alice", "roles": ["ADMIN", "USER"]}, 236 | {"name": "Bob", "roles": ["USER"]}]} 237 | |};; 238 | - : (user list, error) result = 239 | Ok [{name = "Alice"; roles = [Admin; User]}; {name = "Bob"; roles = [User]}] 240 | ``` 241 | 242 | Let's introduce an error in the JSON: 243 | 244 | ```ocaml 245 | utop # D.decode_string D.(field "users" (list user)) 246 | {| {"users": [{"name": "Alice", "roles": ["ADMIN", "USER"]}, 247 | {"name": "Bob", "roles": ["SUPER_USER"]}]} 248 | |};; 249 | - : (user list, error) result = 250 | Error 251 | in field "users": 252 | while decoding a list: 253 | element 1: 254 | in field "roles": 255 | while decoding a list: 256 | element 0: Expected a role, but got "SUPER_USER" 257 | ``` 258 | 259 | We get a nice pointer that we forgot to handle the `SUPER_USER` role. 260 | 261 | ## Encoding 262 | 263 | `ocaml-decoders` also has support for defining backend-agnostic encoders, for 264 | turning your OCaml values into JSON values. 265 | 266 | ```ocaml 267 | module My_encoders(E : Decoders.Encode.S) = struct 268 | open E 269 | 270 | let role : role encoder = 271 | function 272 | | Admin -> string "ADMIN" 273 | | User -> string "USER" 274 | 275 | let user : user encoder = 276 | fun u -> 277 | obj 278 | [ ("name", string u.name) 279 | ; ("roles", list role u.roles) 280 | ] 281 | end 282 | 283 | module My_yojson_encoders = My_encoders(Decoders_yojson.Basic.Encode) 284 | ``` 285 | 286 | ```ocaml 287 | utop # module E = Decoders_yojson.Basic.Encode;; 288 | utop # open My_yojson_encoders;; 289 | utop # let users = 290 | [ {name = "Alice"; roles = [Admin; User]} 291 | ; {name = "Bob"; roles = [User]} 292 | ];; 293 | utop # E.encode_string E.obj [("users", E.list user users)];; 294 | - : string = 295 | "{\"users\":[{\"name\":\"Alice\",\"roles\":[\"ADMIN\",\"USER\"]},{\"name\":\"Bob\",\"roles\":[\"USER\"]}]}" 296 | ``` 297 | 298 | ## API Documentation 299 | 300 | For more details, see the API documentation: 301 | 302 | * [`Decoders.Decode.S`](https://mattjbray.github.io/ocaml-decoders/decoders/Decoders/Decode/module-type-S/index.html) interface 303 | * [`Decoders.Encode.S`](https://mattjbray.github.io/ocaml-decoders/decoders/Decoders/Encode/module-type-S/index.html) interface 304 | 305 | # Decoding XML 306 | 307 | A similar decoders interface exists for decoding XML. See the interface file [`src/xml.ml`](src/xml.ml) for documentation. 308 | 309 | ### XML implementations 310 | 311 | | Platform | Package | Module | Example usage | 312 | |----------|-----------------|--------------------------|----------------------------------------------------------------------------------| 313 | | opam | decoders-ezxmlm | `Decoders_ezxmlm.Decode` | [`src-ezxmlm/test/test_ezxmlm_decode.ml`](src-ezxmlm/test/test_ezxmlm_decode.ml) | 314 | | npm | bs-decoders | `Decoders.Bs_xml.Decode` | [`__tests__/decoders_bs_xml_test.ml`](__tests__/decoders_bs_xml_test.ml) | 315 | 316 | # Release 317 | 318 | After updating CHANGES.md: 319 | 320 | ``` 321 | npm version # e.g. npm version 0.7.0 322 | git push --tags 323 | dune-release 324 | npm publish 325 | ``` 326 | -------------------------------------------------------------------------------- /__tests__/decoders_bs_json_test.ml: -------------------------------------------------------------------------------- 1 | open Jest 2 | open Bs_json 3 | 4 | external parse_int : string -> int = "parseInt" [@@bs.scope "window"] [@@bs.val] 5 | 6 | let () = 7 | describe 8 | "decoders-bs decode" 9 | Expect.( 10 | fun () -> 11 | test 12 | "string" 13 | Decode.( 14 | fun () -> 15 | let json_str = {|"Hello world"|} in 16 | let decoded = decode_string string json_str in 17 | expect decoded |> toEqual (Belt.Result.Ok "Hello world"))) 18 | 19 | 20 | let () = 21 | describe 22 | "decoders-bs decode int" 23 | Expect.( 24 | fun () -> 25 | test 26 | "int" 27 | Decode.( 28 | fun () -> 29 | let json_str = {|5078476151|} in 30 | let decoded = decode_string int json_str in 31 | expect decoded |> toEqual (Belt.Result.Ok (parse_int "5078476151")))) 32 | 33 | 34 | let () = 35 | describe 36 | "decoders-bs decode array" 37 | Expect.( 38 | fun () -> 39 | test 40 | "array" 41 | Decode.( 42 | fun () -> 43 | let json_str = {|["a", "b", "c"]|} in 44 | let decoded = decode_string (array string) json_str in 45 | expect decoded |> toEqual (Belt.Result.Ok [| "a"; "b"; "c" |]))) 46 | 47 | 48 | let () = 49 | describe 50 | "decoders-bs decode error" 51 | Expect.( 52 | fun () -> 53 | test 54 | "array" 55 | Decode.( 56 | fun () -> 57 | let json_str = {|["a", 1, "c"]|} in 58 | let decoded = decode_string (array string) json_str in 59 | expect decoded 60 | |> toEqual 61 | (Belt.Result.Error 62 | Decoders.Error.( 63 | tag_group 64 | "while decoding an array" 65 | [ tag 66 | "element 1" 67 | (make 68 | "Expected a string" 69 | ~context:(Js.Json.number 1.) ) 70 | ]) ))) 71 | 72 | 73 | let () = 74 | describe 75 | "decoders-bs encode" 76 | Expect.( 77 | fun () -> 78 | test 79 | "string" 80 | Encode.( 81 | fun () -> 82 | let str = "Hello world" in 83 | let encoded = encode_string string str in 84 | expect encoded |> toEqual {|"Hello world"|})) 85 | 86 | 87 | let () = 88 | describe 89 | "decoders-bs encode array" 90 | Expect.( 91 | fun () -> 92 | test 93 | "string" 94 | Encode.( 95 | fun () -> 96 | let x = [| "a"; "b"; "c" |] in 97 | let encoded = encode_string (array string) x in 98 | expect encoded |> toEqual {|["a","b","c"]|})) 99 | -------------------------------------------------------------------------------- /__tests__/decoders_bs_xml_test.ml: -------------------------------------------------------------------------------- 1 | open Jest 2 | open Bs_xml 3 | 4 | let () = 5 | describe 6 | "decoders-bs-xml decode" 7 | Expect.( 8 | fun () -> 9 | test 10 | "tag" 11 | Decode.( 12 | fun () -> 13 | let xml_str = {||} in 14 | let decoded = decode_string (tag "root") xml_str in 15 | expect decoded |> toEqual (Belt.Result.Ok ()))) 16 | 17 | 18 | let () = 19 | describe 20 | "decoders-bs-xml decode" 21 | Expect.( 22 | fun () -> 23 | test 24 | "empty attrs" 25 | Decode.( 26 | fun () -> 27 | let xml_str = {||} in 28 | let decoded = decode_string attrs xml_str in 29 | expect decoded |> toEqual (Belt.Result.Ok []))) 30 | 31 | 32 | let () = 33 | describe 34 | "decoders-bs-xml decode" 35 | Expect.( 36 | fun () -> 37 | test 38 | "non-empty attrs" 39 | Decode.( 40 | fun () -> 41 | let xml_str = {||} in 42 | let decoded = decode_string attrs xml_str in 43 | expect decoded |> toEqual (Belt.Result.Ok [ ("id", "1") ]))) 44 | 45 | 46 | let () = 47 | describe 48 | "decoders-bs-xml decode" 49 | Expect.( 50 | fun () -> 51 | test 52 | "attr_opt none" 53 | Decode.( 54 | fun () -> 55 | let xml_str = {||} in 56 | let decoded = decode_string (attr_opt "id") xml_str in 57 | expect decoded |> toEqual (Belt.Result.Ok None))) 58 | 59 | 60 | let () = 61 | describe 62 | "decoders-bs-xml decode" 63 | Expect.( 64 | fun () -> 65 | test 66 | "attr_opt some" 67 | Decode.( 68 | fun () -> 69 | let xml_str = {||} in 70 | let decoded = decode_string (attr_opt "id") xml_str in 71 | expect decoded |> toEqual (Belt.Result.Ok (Some "1")))) 72 | 73 | 74 | let () = 75 | describe 76 | "decoders-bs-xml decode" 77 | Expect.( 78 | fun () -> 79 | test 80 | "attr fail" 81 | Decode.( 82 | fun () -> 83 | let xml_str = {||} in 84 | let decoded = decode_string (attr "id") xml_str in 85 | expect (match decoded with Ok _ -> false | Error _ -> true) 86 | |> toBe true)) 87 | 88 | 89 | let () = 90 | describe 91 | "decoders-bs-xml decode" 92 | Expect.( 93 | fun () -> 94 | test 95 | "attr succeed" 96 | Decode.( 97 | fun () -> 98 | let xml_str = {||} in 99 | let decoded = decode_string (attr "id") xml_str in 100 | expect decoded |> toEqual (Belt.Result.Ok "1"))) 101 | 102 | 103 | let () = 104 | describe 105 | "decoders-bs-xml decode" 106 | Expect.( 107 | fun () -> 108 | test 109 | "skip comments" 110 | Decode.( 111 | fun () -> 112 | let xml_str = {| Some data |} in 113 | let decoder = tag "root" >>= fun () -> children data in 114 | let decoded = decode_string decoder xml_str in 115 | expect decoded |> toEqual (Belt.Result.Ok [ " Some data " ]))) 116 | 117 | 118 | let xml_str = 119 | {| 120 | 121 | 122 | 123 | 124 | 125 | 126 | 127 | 128 | 129 | 130 | 131 | 132 | 133 | 134 | 135 | 136 | 137 | 138 | 139 | 140 | 141 | |} 142 | 143 | 144 | type root = 145 | { main : string 146 | ; trees : (string * node) array 147 | } 148 | 149 | and node = 150 | | Action of 151 | { id : string 152 | ; attrs : (string * string) array 153 | } 154 | | Sequence of node array 155 | | Subtree of { id : string } 156 | 157 | let xml_tree = 158 | { main = "MainTree" 159 | ; trees = 160 | [| ( "MainTree" 161 | , Sequence 162 | [| Action 163 | { id = "SayA" 164 | ; attrs = [| ("message", "Hello World"); ("env", "cruel") |] 165 | } 166 | ; Subtree { id = "GraspObject" } 167 | |] ) 168 | ; ( "GraspObject" 169 | , Sequence 170 | [| Action { id = "Open"; attrs = [||] } 171 | ; Action { id = "Approach"; attrs = [||] } 172 | ; Action { id = "Close"; attrs = [||] } 173 | ; Subtree { id = "DestroyObject" } 174 | |] ) 175 | ; ("DestroyObject", Sequence [| Action { id = "Booom"; attrs = [||] } |]) 176 | |] 177 | } 178 | 179 | 180 | open Decode 181 | 182 | let rec node node_ty : node decoder = 183 | match node_ty with 184 | | "Action" -> 185 | attr "ID" 186 | >>= fun id -> 187 | attrs 188 | >>= fun attrs -> 189 | let attrs = 190 | attrs |> List.filter (fun (name, _) -> name <> "ID") |> Array.of_list 191 | in 192 | succeed (Action { id; attrs }) 193 | | "Sequence" -> 194 | pick_children (any_tag >>= fun node_ty -> pure (node node_ty)) 195 | >>= fun nodes -> succeed (Sequence (Array.of_list nodes)) 196 | | "Subtree" -> 197 | attr "ID" >>= fun id -> succeed (Subtree { id }) 198 | | _ -> 199 | fail "Unknown node type" 200 | 201 | 202 | let tree : (string * node) decoder = 203 | attr "ID" 204 | >>= fun id -> 205 | pick_children (any_tag >>= fun node_ty -> pure (node node_ty)) 206 | >>= function 207 | | [ node ] -> succeed (id, node) | _ -> fail "Expected a single child" 208 | 209 | 210 | let root : root decoder = 211 | tag "root" 212 | >>= fun () -> 213 | attr "main_tree_to_execute" 214 | >>= fun main -> 215 | pick_children (tag "BehaviorTree" >>= fun () -> pure tree) 216 | >>= fun trees -> succeed { main; trees = Array.of_list trees } 217 | 218 | 219 | let () = 220 | describe 221 | "decoders-bs-xml decode" 222 | Expect.( 223 | fun () -> 224 | test 225 | "tree" 226 | Decode.( 227 | fun () -> 228 | let decoded = decode_string root xml_str in 229 | expect decoded |> toEqual (Belt.Result.Ok xml_tree))) 230 | 231 | 232 | open Encode 233 | 234 | let rec node = function 235 | | Action { id; attrs } -> 236 | tag "Action" ~attrs:(("ID", id) :: Array.to_list attrs) [] 237 | | Sequence nodes -> 238 | tag "Sequence" (Array.to_list (Array.map node nodes)) 239 | | Subtree { id } -> 240 | tag "Subtree" ~attrs:[ ("ID", id) ] [] 241 | 242 | 243 | let tree (name, n) = tag "BehaviorTree" ~attrs:[ ("ID", name) ] [ node n ] 244 | 245 | let root t = 246 | tag 247 | "root" 248 | ~attrs:[ ("main_tree_to_execute", t.main) ] 249 | (Array.to_list (Array.map tree t.trees)) 250 | 251 | 252 | let () = 253 | describe 254 | "decoders-bs-xml encode" 255 | Expect.( 256 | fun () -> 257 | test "tree" (fun () -> 258 | let encoded = encode_string root xml_tree in 259 | let expected = 260 | Js.String.splitByRe [%re "/\\n/"] xml_str 261 | |> Array.to_list 262 | |> Decoders.Util.My_list.filter_map (function 263 | | None -> 264 | None 265 | | Some line -> 266 | Some (Js.String.trim line) ) 267 | |> String.concat "" 268 | in 269 | 270 | expect encoded |> toEqual expected )) 271 | -------------------------------------------------------------------------------- /bsconfig.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "bs-decoders", 3 | "namespace": "decoders", 4 | "version": "0.1.0", 5 | "sources": [{ 6 | "dir" : "src", 7 | "files" : [ 8 | "decode.ml", 9 | "decode.mli", 10 | "decoder.ml", 11 | "decoder.mli", 12 | "decoders.ml", 13 | "encode.ml", 14 | "encode.mli", 15 | "error.ml", 16 | "error.mli", 17 | "sig.ml", 18 | "xml.ml" 19 | ] 20 | }, { 21 | "dir" : "src-bs" 22 | }, { 23 | "dir": "__tests__", 24 | "type": "dev" 25 | }], 26 | "package-specs": { 27 | "module": "commonjs", 28 | "in-source": true 29 | }, 30 | "suffix": ".bs.js", 31 | "bs-dependencies": [ 32 | ], 33 | "bs-dev-dependencies": ["@glennsl/bs-jest"], 34 | "warnings": { 35 | "number": "-44", 36 | "error" : "+101" 37 | }, 38 | "refmt": 3 39 | } 40 | -------------------------------------------------------------------------------- /decoders-bencode.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Bencode backend for decoders" 4 | description: 5 | "A combinator library for \"decoding\" JSON-like values into your own Ocaml types, inspired by Elm's `Json.Decode` and `Json.Encode`." 6 | maintainer: ["Matt Bray "] 7 | authors: ["Simon Cruanes "] 8 | license: "ISC" 9 | homepage: "https://github.com/mattjbray/ocaml-decoders" 10 | doc: "https://mattjbray.github.io/ocaml-decoders/" 11 | bug-reports: "https://github.com/mattjbray/ocaml-decoders/issues" 12 | depends: [ 13 | "dune" {>= "3.1"} 14 | "ocaml" {>= "4.03.0"} 15 | "decoders" {= version} 16 | "bencode" {>= "2.0"} 17 | "odoc" {with-doc} 18 | "containers" {with-test & >= "0.16"} 19 | "ounit2" {with-test} 20 | ] 21 | build: [ 22 | ["dune" "subst"] {dev} 23 | [ 24 | "dune" 25 | "build" 26 | "-p" 27 | name 28 | "-j" 29 | jobs 30 | "@install" 31 | "@runtest" {with-test} 32 | "@doc" {with-doc} 33 | ] 34 | ] 35 | dev-repo: "git+https://github.com/mattjbray/ocaml-decoders.git" 36 | -------------------------------------------------------------------------------- /decoders-cbor.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "CBOR backend for decoders" 4 | description: 5 | "A combinator library for \"decoding\" JSON-like values into your own Ocaml types, inspired by Elm's `Json.Decode` and `Json.Encode`." 6 | maintainer: ["Matt Bray "] 7 | authors: ["Matt Bray "] 8 | license: "ISC" 9 | homepage: "https://github.com/mattjbray/ocaml-decoders" 10 | doc: "https://mattjbray.github.io/ocaml-decoders/" 11 | bug-reports: "https://github.com/mattjbray/ocaml-decoders/issues" 12 | depends: [ 13 | "dune" {>= "3.1"} 14 | "ocaml" {>= "4.03.0"} 15 | "decoders" {= version} 16 | "cbor" 17 | "odoc" {with-doc} 18 | "containers" {with-test & >= "0.16"} 19 | "ounit2" {with-test} 20 | ] 21 | build: [ 22 | ["dune" "subst"] {dev} 23 | [ 24 | "dune" 25 | "build" 26 | "-p" 27 | name 28 | "-j" 29 | jobs 30 | "@install" 31 | "@runtest" {with-test} 32 | "@doc" {with-doc} 33 | ] 34 | ] 35 | dev-repo: "git+https://github.com/mattjbray/ocaml-decoders.git" 36 | -------------------------------------------------------------------------------- /decoders-ezjsonm.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Ezjsonm backend for decoders" 4 | description: 5 | "A combinator library for \"decoding\" JSON-like values into your own Ocaml types, inspired by Elm's `Json.Decode` and `Json.Encode`." 6 | maintainer: ["Matt Bray "] 7 | authors: ["Matt Bray "] 8 | license: "ISC" 9 | homepage: "https://github.com/mattjbray/ocaml-decoders" 10 | doc: "https://mattjbray.github.io/ocaml-decoders/" 11 | bug-reports: "https://github.com/mattjbray/ocaml-decoders/issues" 12 | depends: [ 13 | "dune" {>= "3.1"} 14 | "ocaml" {>= "4.03.0"} 15 | "decoders" {= version} 16 | "ezjsonm" {>= "0.4.0"} 17 | "odoc" {with-doc} 18 | "containers" {with-test & >= "0.16"} 19 | "ounit2" {with-test} 20 | ] 21 | build: [ 22 | ["dune" "subst"] {dev} 23 | [ 24 | "dune" 25 | "build" 26 | "-p" 27 | name 28 | "-j" 29 | jobs 30 | "@install" 31 | "@runtest" {with-test} 32 | "@doc" {with-doc} 33 | ] 34 | ] 35 | dev-repo: "git+https://github.com/mattjbray/ocaml-decoders.git" 36 | -------------------------------------------------------------------------------- /decoders-ezxmlm.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Ezxmlm backend for decoders" 4 | description: 5 | "A combinator library for \"decoding\" JSON-like values into your own Ocaml types, inspired by Elm's `Json.Decode` and `Json.Encode`." 6 | maintainer: ["Matt Bray "] 7 | authors: ["Matt Bray "] 8 | license: "ISC" 9 | homepage: "https://github.com/mattjbray/ocaml-decoders" 10 | doc: "https://mattjbray.github.io/ocaml-decoders/" 11 | bug-reports: "https://github.com/mattjbray/ocaml-decoders/issues" 12 | depends: [ 13 | "dune" {>= "3.1"} 14 | "ocaml" {>= "4.03.0"} 15 | "decoders" {= version} 16 | "ezxmlm" {>= "1.1.0"} 17 | "containers" {with-test & >= "0.16"} 18 | "odoc" {with-doc} 19 | ] 20 | build: [ 21 | ["dune" "subst"] {dev} 22 | [ 23 | "dune" 24 | "build" 25 | "-p" 26 | name 27 | "-j" 28 | jobs 29 | "@install" 30 | "@runtest" {with-test} 31 | "@doc" {with-doc} 32 | ] 33 | ] 34 | dev-repo: "git+https://github.com/mattjbray/ocaml-decoders.git" 35 | -------------------------------------------------------------------------------- /decoders-jsonaf.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Jsonaf backend for decoders" 4 | description: 5 | "A combinator library for \"decoding\" JSON-like values into your own Ocaml types, inspired by Elm's `Json.Decode` and `Json.Encode`." 6 | maintainer: ["Matt Bray "] 7 | authors: [ 8 | "Vlad Dumitru " "Matt Bray " 9 | ] 10 | license: "ISC" 11 | homepage: "https://github.com/mattjbray/ocaml-decoders" 12 | doc: "https://mattjbray.github.io/ocaml-decoders/" 13 | bug-reports: "https://github.com/mattjbray/ocaml-decoders/issues" 14 | depends: [ 15 | "dune" {>= "3.1"} 16 | "ocaml" {>= "4.10.0"} 17 | "decoders" {= version} 18 | "jsonaf" {>= "0.15.0"} 19 | "odoc" {with-doc} 20 | "ounit2" {with-test} 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/mattjbray/ocaml-decoders.git" 37 | -------------------------------------------------------------------------------- /decoders-jsonm.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Jsonm backend for decoders" 4 | description: 5 | "A combinator library for \"decoding\" JSON-like values into your own Ocaml types, inspired by Elm's `Json.Decode` and `Json.Encode`." 6 | maintainer: ["Matt Bray "] 7 | authors: ["Matt Bray "] 8 | license: "ISC" 9 | homepage: "https://github.com/mattjbray/ocaml-decoders" 10 | doc: "https://mattjbray.github.io/ocaml-decoders/" 11 | bug-reports: "https://github.com/mattjbray/ocaml-decoders/issues" 12 | depends: [ 13 | "dune" {>= "3.1"} 14 | "ocaml" {>= "4.03.0"} 15 | "decoders" {= version} 16 | "jsonm" 17 | "odoc" {with-doc} 18 | "containers" {with-test & >= "0.16"} 19 | "ounit2" {with-test} 20 | ] 21 | build: [ 22 | ["dune" "subst"] {dev} 23 | [ 24 | "dune" 25 | "build" 26 | "-p" 27 | name 28 | "-j" 29 | jobs 30 | "@install" 31 | "@runtest" {with-test} 32 | "@doc" {with-doc} 33 | ] 34 | ] 35 | dev-repo: "git+https://github.com/mattjbray/ocaml-decoders.git" 36 | -------------------------------------------------------------------------------- /decoders-msgpck.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Msgpck backend for decoders" 4 | description: 5 | "A combinator library for \"decoding\" JSON-like values into your own Ocaml types, inspired by Elm's `Json.Decode` and `Json.Encode`." 6 | maintainer: ["Matt Bray "] 7 | authors: [ 8 | "Matt Bray " "Simon Cruanes " 9 | ] 10 | license: "ISC" 11 | homepage: "https://github.com/mattjbray/ocaml-decoders" 12 | doc: "https://mattjbray.github.io/ocaml-decoders/" 13 | bug-reports: "https://github.com/mattjbray/ocaml-decoders/issues" 14 | depends: [ 15 | "dune" {>= "3.1"} 16 | "ocaml" {>= "4.03.0"} 17 | "decoders" {= version} 18 | "msgpck" {>= "1.3"} 19 | "ocplib-endian" {>= "0.6"} 20 | "odoc" {with-doc} 21 | "containers" {with-test & >= "0.16"} 22 | "ounit2" {with-test} 23 | ] 24 | dev-repo: "git+https://github.com/mattjbray/ocaml-decoders.git" 25 | build: [ 26 | ["dune" "subst"] {dev} 27 | [ 28 | "dune" 29 | "build" 30 | "-p" 31 | name 32 | "-j" 33 | jobs 34 | "@install" 35 | "@runtest" {with-test & ocaml:version >= "4.08"} 36 | "@doc" {with-doc} 37 | ] 38 | ] -------------------------------------------------------------------------------- /decoders-msgpck.opam.template: -------------------------------------------------------------------------------- 1 | build: [ 2 | ["dune" "subst"] {dev} 3 | [ 4 | "dune" 5 | "build" 6 | "-p" 7 | name 8 | "-j" 9 | jobs 10 | "@install" 11 | "@runtest" {with-test & ocaml:version >= "4.08"} 12 | "@doc" {with-doc} 13 | ] 14 | ] -------------------------------------------------------------------------------- /decoders-otoml.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Otoml backend for decoders" 4 | maintainer: ["Matt Bray "] 5 | authors: ["Matt Bray "] 6 | license: "ISC" 7 | homepage: "https://github.com/mattjbray/ocaml-decoders" 8 | doc: "https://mattjbray.github.io/ocaml-decoders/" 9 | bug-reports: "https://github.com/mattjbray/ocaml-decoders/issues" 10 | depends: [ 11 | "dune" {>= "3.1"} 12 | "ocaml" {>= "4.03.0"} 13 | "decoders" {= version} 14 | "otoml" {>= "1.0"} 15 | "containers" {with-test & >= "0.16"} 16 | "odoc" {with-doc} 17 | ] 18 | build: [ 19 | ["dune" "subst"] {dev} 20 | [ 21 | "dune" 22 | "build" 23 | "-p" 24 | name 25 | "-j" 26 | jobs 27 | "@install" 28 | "@runtest" {with-test} 29 | "@doc" {with-doc} 30 | ] 31 | ] 32 | dev-repo: "git+https://github.com/mattjbray/ocaml-decoders.git" 33 | -------------------------------------------------------------------------------- /decoders-sexplib.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Sexplib backend for decoders" 4 | description: 5 | "A combinator library for \"decoding\" JSON-like values into your own Ocaml types, inspired by Elm's `Json.Decode` and `Json.Encode`." 6 | maintainer: ["Matt Bray "] 7 | authors: ["Matt Bray "] 8 | license: "ISC" 9 | homepage: "https://github.com/mattjbray/ocaml-decoders" 10 | doc: "https://mattjbray.github.io/ocaml-decoders/" 11 | bug-reports: "https://github.com/mattjbray/ocaml-decoders/issues" 12 | depends: [ 13 | "dune" {>= "3.1"} 14 | "ocaml" {>= "4.03.0"} 15 | "decoders" {= version} 16 | "sexplib0" 17 | "sexplib" 18 | "odoc" {with-doc} 19 | "containers" {with-test & >= "0.16"} 20 | "ounit2" {with-test} 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/mattjbray/ocaml-decoders.git" 37 | -------------------------------------------------------------------------------- /decoders-yojson.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Yojson backend for decoders" 4 | description: 5 | "A combinator library for \"decoding\" JSON-like values into your own Ocaml types, inspired by Elm's `Json.Decode` and `Json.Encode`." 6 | maintainer: ["Matt Bray "] 7 | authors: ["Matt Bray "] 8 | license: "ISC" 9 | homepage: "https://github.com/mattjbray/ocaml-decoders" 10 | doc: "https://mattjbray.github.io/ocaml-decoders/" 11 | bug-reports: "https://github.com/mattjbray/ocaml-decoders/issues" 12 | depends: [ 13 | "dune" {>= "3.1"} 14 | "ocaml" {>= "4.03.0"} 15 | "decoders" {= version} 16 | "yojson" {>= "1.6.0"} 17 | "odoc" {with-doc} 18 | "containers" {with-test & >= "0.16"} 19 | "ounit2" {with-test} 20 | ] 21 | build: [ 22 | ["dune" "subst"] {dev} 23 | [ 24 | "dune" 25 | "build" 26 | "-p" 27 | name 28 | "-j" 29 | jobs 30 | "@install" 31 | "@runtest" {with-test} 32 | "@doc" {with-doc} 33 | ] 34 | ] 35 | dev-repo: "git+https://github.com/mattjbray/ocaml-decoders.git" 36 | -------------------------------------------------------------------------------- /decoders.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Elm-inspired decoders for Ocaml" 4 | description: 5 | "A combinator library for \"decoding\" JSON-like values into your own Ocaml types, inspired by Elm's `Json.Decode` and `Json.Encode`." 6 | maintainer: ["Matt Bray "] 7 | authors: ["Matt Bray "] 8 | license: "ISC" 9 | homepage: "https://github.com/mattjbray/ocaml-decoders" 10 | doc: "https://mattjbray.github.io/ocaml-decoders/" 11 | bug-reports: "https://github.com/mattjbray/ocaml-decoders/issues" 12 | depends: [ 13 | "dune" {>= "3.1"} 14 | "ocaml" {>= "4.03.0"} 15 | "odoc" {with-doc} 16 | "containers" {with-test & >= "0.16"} 17 | ] 18 | build: [ 19 | ["dune" "subst"] {dev} 20 | [ 21 | "dune" 22 | "build" 23 | "-p" 24 | name 25 | "-j" 26 | jobs 27 | "@install" 28 | "@runtest" {with-test} 29 | "@doc" {with-doc} 30 | ] 31 | ] 32 | dev-repo: "git+https://github.com/mattjbray/ocaml-decoders.git" 33 | -------------------------------------------------------------------------------- /dune: -------------------------------------------------------------------------------- 1 | (dirs :standard \ node_modules) 2 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.1) 2 | (name decoders) 3 | (generate_opam_files true) 4 | (license ISC) 5 | (authors "Matt Bray ") 6 | (maintainers "Matt Bray ") 7 | (source (github "mattjbray/ocaml-decoders")) 8 | (documentation "https://mattjbray.github.io/ocaml-decoders/") 9 | 10 | (package 11 | (name decoders-bencode) 12 | (authors "Simon Cruanes ") 13 | (synopsis "Bencode backend for decoders") 14 | (description 15 | "A combinator library for \"decoding\" JSON-like values into your own Ocaml types, inspired by Elm's `Json.Decode` and `Json.Encode`.") 16 | (depends 17 | (ocaml (>= 4.03.0)) 18 | (decoders (= :version)) 19 | (bencode (>= 2.0)) 20 | (odoc :with-doc) 21 | (containers (and :with-test (>= 0.16))) 22 | (ounit2 :with-test))) 23 | 24 | (package 25 | (name decoders-cbor) 26 | (synopsis "CBOR backend for decoders") 27 | (description 28 | "A combinator library for \"decoding\" JSON-like values into your own Ocaml types, inspired by Elm's `Json.Decode` and `Json.Encode`.") 29 | (depends 30 | (ocaml (>= 4.03.0)) 31 | (decoders (= :version)) 32 | cbor 33 | (odoc :with-doc) 34 | (containers (and :with-test (>= 0.16))) 35 | (ounit2 :with-test))) 36 | 37 | (package 38 | (name decoders-ezjsonm) 39 | (synopsis "Ezjsonm backend for decoders") 40 | (description 41 | "A combinator library for \"decoding\" JSON-like values into your own Ocaml types, inspired by Elm's `Json.Decode` and `Json.Encode`.") 42 | (depends 43 | (ocaml (>= 4.03.0)) 44 | (decoders (= :version)) 45 | (ezjsonm (>= 0.4.0)) 46 | (odoc :with-doc) 47 | (containers (and :with-test (>= 0.16))) 48 | (ounit2 :with-test))) 49 | 50 | (package 51 | (name decoders-jsonaf) 52 | (synopsis "Jsonaf backend for decoders") 53 | (authors "Vlad Dumitru " "Matt Bray ") 54 | (description 55 | "A combinator library for \"decoding\" JSON-like values into your own Ocaml types, inspired by Elm's `Json.Decode` and `Json.Encode`.") 56 | (depends 57 | (ocaml (>= 4.10.0)) 58 | (decoders (= :version)) 59 | (jsonaf (>= 0.15.0)) 60 | (odoc :with-doc) 61 | (ounit2 :with-test))) 62 | 63 | (package 64 | (name decoders-jsonm) 65 | (synopsis "Jsonm backend for decoders") 66 | (description 67 | "A combinator library for \"decoding\" JSON-like values into your own Ocaml types, inspired by Elm's `Json.Decode` and `Json.Encode`.") 68 | (depends 69 | (ocaml (>= 4.03.0)) 70 | (decoders (= :version)) 71 | jsonm 72 | (odoc :with-doc) 73 | (containers (and :with-test (>= 0.16))) 74 | (ounit2 :with-test))) 75 | 76 | (package 77 | (name decoders-msgpck) 78 | (authors "Matt Bray " "Simon Cruanes ") 79 | (synopsis "Msgpck backend for decoders") 80 | (description 81 | "A combinator library for \"decoding\" JSON-like values into your own Ocaml types, inspired by Elm's `Json.Decode` and `Json.Encode`.") 82 | (depends 83 | (ocaml (>= 4.03.0)) 84 | (decoders (= :version)) 85 | (msgpck (>= 1.3)) 86 | (ocplib-endian (>= 0.6)) ; lower bound missing from msgpck 87 | (odoc :with-doc) 88 | (containers (and :with-test (>= 0.16))) 89 | (ounit2 :with-test))) 90 | 91 | (package 92 | (name decoders-sexplib) 93 | (synopsis "Sexplib backend for decoders") 94 | (description 95 | "A combinator library for \"decoding\" JSON-like values into your own Ocaml types, inspired by Elm's `Json.Decode` and `Json.Encode`.") 96 | (depends 97 | (ocaml (>= 4.03.0)) 98 | (decoders (= :version)) 99 | sexplib0 100 | sexplib 101 | (odoc :with-doc) 102 | (containers (and :with-test (>= 0.16))) 103 | (ounit2 :with-test))) 104 | 105 | (package 106 | (name decoders-ezxmlm) 107 | (synopsis "Ezxmlm backend for decoders") 108 | (description 109 | "A combinator library for \"decoding\" JSON-like values into your own Ocaml types, inspired by Elm's `Json.Decode` and `Json.Encode`.") 110 | (depends 111 | (ocaml (>= 4.03.0)) 112 | (decoders (= :version)) 113 | (ezxmlm (>= 1.1.0)) 114 | (containers (and :with-test (>= 0.16))) 115 | (odoc :with-doc))) 116 | 117 | (package 118 | (name decoders-otoml) 119 | (synopsis "Otoml backend for decoders") 120 | (depends 121 | (ocaml (>= 4.03.0)) 122 | (decoders (= :version)) 123 | (otoml (>= 1.0)) 124 | (containers (and :with-test (>= 0.16))) 125 | (odoc :with-doc))) 126 | 127 | (package 128 | (name decoders-yojson) 129 | (synopsis "Yojson backend for decoders") 130 | (description 131 | "A combinator library for \"decoding\" JSON-like values into your own Ocaml types, inspired by Elm's `Json.Decode` and `Json.Encode`.") 132 | (depends 133 | (ocaml (>= 4.03.0)) 134 | (decoders (= :version)) 135 | (yojson (>= 1.6.0)) 136 | (odoc :with-doc) 137 | (containers (and :with-test (>= 0.16))) 138 | (ounit2 :with-test))) 139 | 140 | (package 141 | (name decoders) 142 | (synopsis "Elm-inspired decoders for Ocaml") 143 | (description 144 | "A combinator library for \"decoding\" JSON-like values into your own Ocaml types, inspired by Elm's `Json.Decode` and `Json.Encode`.") 145 | (depends 146 | (ocaml (>= 4.03.0)) 147 | (odoc :with-doc) 148 | (containers (and :with-test (>= 0.16))))) 149 | -------------------------------------------------------------------------------- /flake.lock: -------------------------------------------------------------------------------- 1 | { 2 | "nodes": { 3 | "flake-utils": { 4 | "inputs": { 5 | "systems": "systems" 6 | }, 7 | "locked": { 8 | "lastModified": 1710146030, 9 | "narHash": "sha256-SZ5L6eA7HJ/nmkzGG7/ISclqe6oZdOZTNoesiInkXPQ=", 10 | "owner": "numtide", 11 | "repo": "flake-utils", 12 | "rev": "b1d9ab70662946ef0850d488da1c9019f3a9752a", 13 | "type": "github" 14 | }, 15 | "original": { 16 | "owner": "numtide", 17 | "repo": "flake-utils", 18 | "type": "github" 19 | } 20 | }, 21 | "nixpkgs": { 22 | "locked": { 23 | "lastModified": 1710827359, 24 | "narHash": "sha256-/KY8hffTh9SN/tTcDn/FrEiYwTXnU8NKnr4D7/stmmA=", 25 | "owner": "NixOS", 26 | "repo": "nixpkgs", 27 | "rev": "5710127d9693421e78cca4f74fac2db6d67162b1", 28 | "type": "github" 29 | }, 30 | "original": { 31 | "id": "nixpkgs", 32 | "ref": "nixpkgs-unstable", 33 | "type": "indirect" 34 | } 35 | }, 36 | "nixpkgs2305": { 37 | "locked": { 38 | "lastModified": 1704290814, 39 | "narHash": "sha256-LWvKHp7kGxk/GEtlrGYV68qIvPHkU9iToomNFGagixU=", 40 | "owner": "NixOS", 41 | "repo": "nixpkgs", 42 | "rev": "70bdadeb94ffc8806c0570eb5c2695ad29f0e421", 43 | "type": "github" 44 | }, 45 | "original": { 46 | "id": "nixpkgs", 47 | "ref": "nixos-23.05", 48 | "type": "indirect" 49 | } 50 | }, 51 | "root": { 52 | "inputs": { 53 | "flake-utils": "flake-utils", 54 | "nixpkgs": "nixpkgs", 55 | "nixpkgs2305": "nixpkgs2305" 56 | } 57 | }, 58 | "systems": { 59 | "locked": { 60 | "lastModified": 1681028828, 61 | "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", 62 | "owner": "nix-systems", 63 | "repo": "default", 64 | "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", 65 | "type": "github" 66 | }, 67 | "original": { 68 | "owner": "nix-systems", 69 | "repo": "default", 70 | "type": "github" 71 | } 72 | } 73 | }, 74 | "root": "root", 75 | "version": 7 76 | } 77 | -------------------------------------------------------------------------------- /flake.nix: -------------------------------------------------------------------------------- 1 | { 2 | inputs = { 3 | nixpkgs.url = "nixpkgs/nixpkgs-unstable"; 4 | 5 | #ocamlformat 0.22.4 is a bit old, so is only in older versions of nixpkgs 6 | nixpkgs2305.url = "nixpkgs/nixos-23.05"; 7 | 8 | flake-utils.url = "github:numtide/flake-utils"; 9 | }; 10 | 11 | outputs = { self, nixpkgs, nixpkgs2305, flake-utils }@attrs: 12 | flake-utils.lib.eachDefaultSystem (system: 13 | let 14 | pkgs = nixpkgs.legacyPackages.${system}; 15 | pkgs2305 = nixpkgs2305.legacyPackages.${system}; 16 | in 17 | { 18 | # for use by nix fmt 19 | formatter = pkgs.nixpkgs-fmt; 20 | 21 | devShells.default = 22 | pkgs.mkShell { 23 | buildInputs = 24 | (if pkgs.stdenv.isDarwin then 25 | (with pkgs.darwin.apple_sdk.frameworks; [ CoreServices Foundation ]) 26 | 27 | else 28 | [ pkgs.inotify-tools ]) ++ [ 29 | pkgs.opam 30 | pkgs2305.ocamlformat_0_20_1 31 | #pkgs.pkg-config 32 | ] 33 | ; 34 | }; 35 | 36 | }); 37 | } 38 | -------------------------------------------------------------------------------- /package.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "bs-decoders", 3 | "version": "1.0.0", 4 | "description": "", 5 | "main": "index.js", 6 | "directories": { 7 | "test": "test" 8 | }, 9 | "scripts": { 10 | "build": "bsb -make-world", 11 | "build-watch": "bsb -make-world -w", 12 | "test": "bsb -make-world && jest", 13 | "test-watch": "jest --watch", 14 | "clean": "bsb -clean-world" 15 | }, 16 | "repository": { 17 | "type": "git", 18 | "url": "git+https://github.com/mattjbray/ocaml-decoders.git" 19 | }, 20 | "author": "", 21 | "license": "ISC", 22 | "bugs": { 23 | "url": "https://github.com/mattjbray/ocaml-decoders/issues" 24 | }, 25 | "homepage": "https://github.com/mattjbray/ocaml-decoders#readme", 26 | "devDependencies": { 27 | "@glennsl/bs-jest": "^0.7.0" 28 | }, 29 | "peerDependencies": { 30 | "bs-platform": "^9.0.2" 31 | }, 32 | "jest": { 33 | "modulePathIgnorePatterns": [ 34 | "_opam" 35 | ] 36 | } 37 | } 38 | -------------------------------------------------------------------------------- /src-bencode/decode.ml: -------------------------------------------------------------------------------- 1 | open Decoders 2 | 3 | module Bencode_decodeable : Decode.Decodeable with type value = Bencode.t = 4 | struct 5 | type value = Bencode.t 6 | 7 | let pp fmt t = Format.fprintf fmt "@[%s@]" (Bencode.pretty_print t) 8 | 9 | let of_string (input : string) : (value, string) result = 10 | try Ok (Bencode.decode (`String input)) with _ -> Error "invalid bencode" 11 | 12 | 13 | let of_file (file : string) : (value, string) result = 14 | try 15 | let v = Util.with_file_in file (fun ic -> Bencode.decode (`Channel ic)) in 16 | Ok v 17 | with 18 | | e -> 19 | Error (Printexc.to_string e) 20 | 21 | 22 | let get_string = function Bencode.String str -> Some str | _ -> None 23 | 24 | let get_int = function 25 | | Bencode.Integer int -> 26 | Some (Int64.to_int int) 27 | | Bencode.String s -> 28 | (try Some (int_of_string s) with _ -> None) 29 | | _ -> 30 | None 31 | 32 | 33 | let get_float = function 34 | | Bencode.String s -> 35 | (try Some (float_of_string s) with _ -> None) 36 | | _ -> 37 | None 38 | 39 | 40 | let get_null = function 41 | | Bencode.Integer 0L | Bencode.List [] -> 42 | Some () 43 | | _ -> 44 | None 45 | 46 | 47 | let get_bool = function 48 | | Bencode.Integer 1L | Bencode.String "true" -> 49 | Some true 50 | | Bencode.Integer 0L | Bencode.String "false" -> 51 | Some false 52 | | _ -> 53 | None 54 | 55 | 56 | let get_list = function Bencode.List a -> Some a | _ -> None 57 | 58 | let get_key_value_pairs = function 59 | | Bencode.Dict assoc -> 60 | Some (List.rev_map (fun (s, v) -> (Bencode.String s, v)) assoc) 61 | | _ -> 62 | None 63 | 64 | 65 | let to_list vs = Bencode.List vs 66 | end 67 | 68 | include Decode.Make (Bencode_decodeable) 69 | 70 | let int64 : int64 decoder = 71 | { Decoder.dec = 72 | (fun t -> 73 | match t with 74 | | Bencode.Integer value -> 75 | Ok value 76 | | _ -> 77 | (fail "Expected an int64").dec t ) 78 | } 79 | -------------------------------------------------------------------------------- /src-bencode/decode.mli: -------------------------------------------------------------------------------- 1 | include Decoders.Decode.S with type value = Bencode.t 2 | 3 | val int64 : int64 decoder 4 | -------------------------------------------------------------------------------- /src-bencode/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name decoders_bencode) 3 | (public_name decoders-bencode) 4 | (libraries decoders bencode)) 5 | -------------------------------------------------------------------------------- /src-bencode/encode.ml: -------------------------------------------------------------------------------- 1 | open Decoders 2 | 3 | module Bencode_encodeable = struct 4 | type value = Bencode.t 5 | 6 | let to_string value = Bencode.encode_to_string value 7 | 8 | let of_string x = Bencode.String x 9 | 10 | let of_int x = Bencode.Integer (Int64.of_int x) 11 | 12 | let of_float x = Bencode.String (string_of_float x) 13 | 14 | let of_bool x = Bencode.Integer (if x then 1L else 0L) 15 | 16 | let null = Bencode.Integer 0L 17 | 18 | let of_list xs = Bencode.List xs 19 | 20 | let of_key_value_pairs xs = 21 | let xs = 22 | Util.My_list.filter_map 23 | (function Bencode.String s, v -> Some (s, v) | _ -> None) 24 | xs 25 | in 26 | Bencode.Dict xs 27 | end 28 | 29 | include Decoders.Encode.Make (Bencode_encodeable) 30 | 31 | let int64 i = Bencode.Integer i 32 | -------------------------------------------------------------------------------- /src-bencode/encode.mli: -------------------------------------------------------------------------------- 1 | include Decoders.Encode.S with type value = Bencode.t 2 | 3 | val int64 : int64 encoder 4 | -------------------------------------------------------------------------------- /src-bs/bs_json.ml: -------------------------------------------------------------------------------- 1 | (** {2 Bucklescript Js.Json implementation} *) 2 | 3 | open Decoders 4 | 5 | type ('good, 'bad) result = ('good, 'bad) Util.My_result.t = 6 | | Ok of 'good 7 | | Error of 'bad 8 | 9 | module Json_decodeable : Decode.Decodeable with type value = Js.Json.t = struct 10 | type value = Js.Json.t 11 | 12 | let pp fmt json = 13 | Format.fprintf fmt "@[%s@]" (Js.Json.stringifyWithSpace json 2) 14 | 15 | 16 | let of_string : string -> (value, string) result = 17 | fun string -> 18 | try Ok (Js.Json.parseExn string) with 19 | | Js.Exn.Error e -> 20 | Error (Js.Exn.message e |. Belt.Option.getWithDefault "unknown") 21 | 22 | 23 | let of_file _file = failwith "Not implemented" 24 | 25 | let get_string = Js.Json.decodeString 26 | 27 | let is_integer json = 28 | Js.Float.isFinite json && Js.Math.floor_float json == json 29 | 30 | 31 | let get_int json = 32 | Js.Json.decodeNumber json 33 | |. Belt.Option.flatMap (fun n -> 34 | if is_integer n then Some (Obj.magic (n : float) : int) else None ) 35 | 36 | 37 | let get_float = Js.Json.decodeNumber 38 | 39 | let get_bool = Js.Json.decodeBoolean 40 | 41 | let get_null value = Js.Json.decodeNull value |. Belt.Option.map (fun _ -> ()) 42 | 43 | let get_list (value : value) : value list option = 44 | Js.Json.decodeArray value |. Belt.Option.map Array.to_list 45 | 46 | 47 | let get_key_value_pairs (value : value) : (value * value) list option = 48 | Js.Json.decodeObject value 49 | |. Belt.Option.map (fun dict -> 50 | Js.Dict.entries dict 51 | |. Array.to_list 52 | |> List.map (fun (key, value) -> (Js.Json.string key, value)) ) 53 | 54 | 55 | let to_list values = Js.Json.array (Array.of_list values) 56 | end 57 | 58 | module Decode = struct 59 | module D = Decode.Make (Json_decodeable) 60 | include D 61 | 62 | let array : 'a decoder -> 'a array decoder = 63 | fun decoder -> 64 | { Decoder.dec = 65 | (fun t -> 66 | match Js.Json.decodeArray t with 67 | | None -> 68 | (fail "Expected an array").dec t 69 | | Some arr -> 70 | let oks, errs = 71 | arr 72 | |> Js.Array.reducei 73 | (fun (oks, errs) x i -> 74 | match decoder.dec x with 75 | | Ok a -> 76 | let _ = Js.Array.push a oks in 77 | (oks, errs) 78 | | Error e -> 79 | let _ = 80 | Js.Array.push 81 | (Error.tag ("element " ^ Js.Int.toString i) e) 82 | errs 83 | in 84 | (oks, errs) ) 85 | ([||], [||]) 86 | in 87 | if Js.Array.length errs > 0 88 | then 89 | Error 90 | (Error.tag_group 91 | "while decoding an array" 92 | (errs |> Array.to_list) ) 93 | else Ok oks ) 94 | } 95 | end 96 | 97 | module Json_encodeable = struct 98 | type value = Js.Json.t 99 | 100 | let to_string json = Js.Json.stringify json 101 | 102 | let of_string x = Js.Json.string x 103 | 104 | let of_int x = Js.Json.number (float_of_int x) 105 | 106 | let of_float x = Js.Json.number x 107 | 108 | let of_bool x = Js.Json.boolean x 109 | 110 | let null = Js.Json.null 111 | 112 | let of_list xs = Js.Json.array (Array.of_list xs) 113 | 114 | let of_key_value_pairs xs = 115 | Js.Json.object_ 116 | ( xs 117 | |. Belt.List.keepMap (fun (k, v) -> 118 | Js.Json.decodeString k |. Belt.Option.map (fun k -> (k, v)) ) 119 | |. Js.Dict.fromList ) 120 | end 121 | 122 | module Encode = struct 123 | include Encode.Make (Json_encodeable) 124 | 125 | let array encoder xs = 126 | xs |> Js.Array.map (fun x -> encoder x) |> Js.Json.array 127 | end 128 | -------------------------------------------------------------------------------- /src-bs/bs_json.mli: -------------------------------------------------------------------------------- 1 | (** Turn JSON values into Ocaml values. *) 2 | 3 | module Decode : sig 4 | include Decoders.Decode.S with type value = Js.Json.t 5 | end 6 | 7 | module Encode : sig 8 | include Decoders.Encode.S with type value = Js.Json.t 9 | end 10 | -------------------------------------------------------------------------------- /src-bs/bs_xml.ml: -------------------------------------------------------------------------------- 1 | module DOMParser = struct 2 | type t 3 | 4 | external create : unit -> t = "DOMParser" [@@bs.new] 5 | 6 | external parseFromString : t -> string -> string -> Dom.element 7 | = "parseFromString" 8 | [@@bs.send] 9 | 10 | external firstElementChildUnsafe : Dom.element -> Dom.element 11 | = "firstElementChild" 12 | [@@bs.get] 13 | 14 | external querySelector : 15 | Dom.element -> string -> Dom.element Js.null_undefined = "querySelector" 16 | [@@bs.send] 17 | 18 | external textContent : Dom.element -> string = "textContent" [@@bs.get] 19 | 20 | let parse_xml text = 21 | let parser = create () in 22 | let doc = parseFromString parser text "text/xml" in 23 | let e = querySelector doc "parsererror" in 24 | match Js.toOption e with 25 | | None -> 26 | firstElementChildUnsafe doc 27 | | Some e -> 28 | failwith (textContent e) 29 | end 30 | 31 | module Node = struct 32 | (* See https://developer.mozilla.org/en-US/docs/Web/API/Node/nodeType *) 33 | external element_node : int = "ELEMENT_NODE" [@@bs.val] [@@bs.scope "Node"] 34 | 35 | external text_node : int = "TEXT_NODE" [@@bs.val] [@@bs.scope "Node"] 36 | 37 | external comment_node : int = "COMMENT_NODE" [@@bs.val] [@@bs.scope "Node"] 38 | 39 | external nodeType : Dom.node -> int = "nodeType" [@@bs.get] 40 | 41 | external of_element : Dom.element -> Dom.node = "%identity" 42 | 43 | external to_element_unsafe : Dom.node -> Dom.element = "%identity" 44 | 45 | external of_text : Dom.text -> Dom.node = "%identity" 46 | 47 | external to_text_unsafe : Dom.node -> Dom.text = "%identity" 48 | end 49 | 50 | type value = 51 | [ `El of Dom.element 52 | | `Data of Dom.text 53 | ] 54 | 55 | module Node_list = struct 56 | external to_array_like : Dom.nodeList -> Dom.node Js.Array.array_like 57 | = "%identity" 58 | 59 | let to_array (nodesList : Dom.nodeList) : value array = 60 | nodesList 61 | |> to_array_like 62 | |> Js.Array.from 63 | |. Belt.Array.keepMap (fun node -> 64 | let ty = Node.nodeType node in 65 | if ty = Node.element_node 66 | then Some (`El (Node.to_element_unsafe node)) 67 | else if ty = Node.text_node 68 | then Some (`Data (Node.to_text_unsafe node)) 69 | else if ty = Node.comment_node 70 | then None 71 | else failwith (Format.asprintf "Unexpected node type %i" ty) ) 72 | end 73 | 74 | module Text = struct 75 | external data : Dom.text -> string = "data" [@@bs.get] 76 | end 77 | 78 | module Element = struct 79 | external childNodes : Dom.element -> Dom.nodeList = "childNodes" [@@bs.get] 80 | 81 | let child_nodes elt = childNodes elt |> Node_list.to_array |> Array.to_list 82 | 83 | external tagName : Dom.element -> string = "tagName" [@@bs.get] 84 | 85 | external getAttribute : Dom.element -> string -> string Js.Nullable.t 86 | = "getAttribute" 87 | [@@bs.send] 88 | 89 | external getAttributeNames : Dom.element -> string Js.Array.t 90 | = "getAttributeNames" 91 | [@@bs.send] 92 | 93 | let get_attribute elt attr = 94 | let v = getAttribute elt attr in 95 | Js.Nullable.toOption v 96 | 97 | 98 | external append : Dom.element -> Dom.node array -> unit = "append" 99 | [@@bs.send] [@@variadic] 100 | 101 | external setAttribute : Dom.element -> string -> string -> unit 102 | = "setAttribute" 103 | [@@bs.send] 104 | end 105 | 106 | module XMLSerializer = struct 107 | type t 108 | 109 | external create : unit -> t = "XMLSerializer" [@@bs.new] 110 | 111 | external serializeToString : t -> Dom.node -> string = "serializeToString" 112 | [@@bs.send] 113 | end 114 | 115 | module Document = struct 116 | external createElementNS : string -> string -> Dom.element = "createElementNS" 117 | [@@val] [@@scope "window", "document"] 118 | 119 | external createTextNode : string -> Dom.text = "createTextNode" 120 | [@@val] [@@scope "window", "document"] 121 | end 122 | 123 | module Encode = struct 124 | type nonrec value = value 125 | 126 | type 'a encoder = 'a -> value 127 | 128 | let to_node = function 129 | | `El el -> 130 | Node.of_element el 131 | | `Data text -> 132 | Node.of_text text 133 | 134 | 135 | let tag name ?(attrs = []) children = 136 | (* Remove xmlns="http://www.w3.org/1999/xhtml" and "NS1:" prefix *) 137 | let xmlns = "" in 138 | let el = Document.createElementNS xmlns name in 139 | Element.append el (List.map to_node children |> Array.of_list) ; 140 | List.iter (fun (name, value) -> Element.setAttribute el name value) attrs ; 141 | `El el 142 | 143 | 144 | let data string = `Data (Document.createTextNode string) 145 | 146 | let value x = x 147 | 148 | let encode_string encoder v = 149 | let s = XMLSerializer.create () in 150 | XMLSerializer.serializeToString s (to_node (encoder v)) 151 | end 152 | 153 | module Decode = struct 154 | module E = Encode 155 | open Decoders 156 | open Util 157 | 158 | type nonrec value = value 159 | 160 | let pp fmt v = Format.fprintf fmt "%s" E.(encode_string value v) 161 | 162 | type error = value Error.t 163 | 164 | let pp_error = Error.pp pp 165 | 166 | let string_of_error = Error.to_string pp 167 | 168 | type 'a decoder = (value, 'a) Decoder.t 169 | 170 | include Decoder.Infix 171 | include Decoder 172 | 173 | let succeed = pure 174 | 175 | let and_then = bind 176 | 177 | let from_result = of_result 178 | 179 | let tag (name : string) : unit decoder = 180 | { Decoder.dec = 181 | (fun (v : value) -> 182 | match v with 183 | | `El el when Element.tagName el = name -> 184 | Ok () 185 | | _ -> 186 | (fail (Format.asprintf "Expected a tag with name %S" name)).dec v 187 | ) 188 | } 189 | 190 | 191 | let any_tag : string decoder = 192 | { Decoder.dec = 193 | (fun (v : value) -> 194 | match v with 195 | | `El el -> 196 | Ok (Element.tagName el) 197 | | _ -> 198 | (fail "Expected a Tag").dec v ) 199 | } 200 | 201 | 202 | let data : string decoder = 203 | { Decoder.dec = 204 | (fun (v : value) -> 205 | match v with 206 | | `Data text -> 207 | Ok (Text.data text) 208 | | `El _ -> 209 | (fail "Expected Data").dec v ) 210 | } 211 | 212 | 213 | let float : float decoder = 214 | data 215 | >>= fun s -> 216 | match s |> String.trim |> float_of_string_opt with 217 | | None -> 218 | fail "Expected a float" 219 | | Some f -> 220 | succeed f 221 | 222 | 223 | let int : int decoder = 224 | data 225 | >>= fun s -> 226 | match s |> String.trim |> int_of_string_opt with 227 | | None -> 228 | fail "Expected an int" 229 | | Some f -> 230 | succeed f 231 | 232 | 233 | let bool : bool decoder = 234 | data 235 | >>= fun s -> 236 | match s |> String.trim |> bool_of_string_opt with 237 | | None -> 238 | fail "Expected a bool" 239 | | Some f -> 240 | succeed f 241 | 242 | 243 | let attr_opt name : string option decoder = 244 | { Decoder.dec = 245 | (fun (v : value) -> 246 | match v with 247 | | `El el -> 248 | Ok (Element.get_attribute el name) 249 | | `Data _ -> 250 | (fail "Expected a Tag").dec v ) 251 | } 252 | 253 | 254 | let attr name : string decoder = 255 | attr_opt name 256 | >>= function 257 | | Some value -> 258 | succeed value 259 | | None -> 260 | fail (Format.asprintf "Expected an attribute named %S" name) 261 | 262 | 263 | let attrs : (string * string) list decoder = 264 | { Decoder.dec = 265 | (fun (v : value) -> 266 | match v with 267 | | `El el -> 268 | let names = Element.getAttributeNames el |> Array.to_list in 269 | let attrs = 270 | names 271 | |> List.map (fun name -> 272 | let value = 273 | match Element.get_attribute el name with 274 | | Some v -> 275 | v 276 | | None -> 277 | assert false 278 | in 279 | (name, value) ) 280 | in 281 | Ok attrs 282 | | `Data _ -> 283 | (fail "Expected a Tag").dec v ) 284 | } 285 | 286 | 287 | let pick_children (child : 'a decoder decoder) : 'a list decoder = 288 | { Decoder.dec = 289 | (function 290 | | `El el -> 291 | Element.child_nodes el 292 | |> My_list.filter_mapi (fun i v -> 293 | match child.dec v with 294 | | Error _ -> 295 | None 296 | | Ok dec -> 297 | Some 298 | ( dec.dec v 299 | |> My_result.map_err 300 | (Error.tag 301 | (Format.asprintf "While decoding child %i" i) ) 302 | ) ) 303 | |> My_result.combine_l 304 | |> My_result.map_err 305 | (Error.tag_group 306 | (Format.asprintf "In tag %s" (Element.tagName el)) ) 307 | | `Data _ as v -> 308 | (fail "Expected a Tag").dec v ) 309 | } 310 | 311 | 312 | let children (child : 'a decoder) : 'a list decoder = 313 | pick_children (pure child) 314 | 315 | 316 | let decode_value decoder v = decoder.dec v 317 | 318 | let of_string str = 319 | try Ok (`El (DOMParser.parse_xml str)) with 320 | | e -> 321 | Error (Error.tag "Parse error" (Error.make (Printexc.to_string e))) 322 | 323 | 324 | let decode_string decoder str = 325 | My_result.Infix.(of_string str >>= decode_value decoder) 326 | 327 | 328 | let of_file _ = failwith "Not implemented" 329 | 330 | let decode_file _ = failwith "Not implemented" 331 | end 332 | -------------------------------------------------------------------------------- /src-bs/bs_xml.mli: -------------------------------------------------------------------------------- 1 | type value = 2 | [ `El of Dom.element 3 | | `Data of Dom.text 4 | ] 5 | 6 | module Decode : sig 7 | include Decoders.Xml.Decode with type value = value 8 | end 9 | 10 | module Encode : sig 11 | include Decoders.Xml.Encode with type value = value 12 | end 13 | -------------------------------------------------------------------------------- /src-bs/shims_let_ops_.ml: -------------------------------------------------------------------------------- 1 | (* Note: copied from src/gen/mkshims.ml *) 2 | module type I = sig 3 | type ('i, 'a) t 4 | 5 | val ( >|= ) : ('i, 'a) t -> ('a -> 'b) -> ('i, 'b) t 6 | 7 | val monoid_product : ('i, 'a) t -> ('i, 'b) t -> ('i, 'a * 'b) t 8 | 9 | val ( >>= ) : ('i, 'a) t -> ('a -> ('i, 'b) t) -> ('i, 'b) t 10 | end 11 | 12 | module type S = sig 13 | type ('i, 'a) t_let 14 | end 15 | 16 | module Make (X : I) = struct 17 | type ('i, 'a) t_let = ('i, 'a) X.t 18 | end 19 | -------------------------------------------------------------------------------- /src-bs/util.ml: -------------------------------------------------------------------------------- 1 | module My_result = struct 2 | type ('good, 'bad) t = ('good, 'bad) Belt.Result.t = 3 | | Ok of 'good 4 | | Error of 'bad 5 | 6 | let return x = Ok x 7 | 8 | let map : ('a -> 'b) -> ('a, 'err) t -> ('b, 'err) t = 9 | fun f x -> Belt.Result.map x f 10 | 11 | 12 | let map_err : ('err1 -> 'err2) -> ('a, 'err1) t -> ('a, 'err2) t = 13 | fun f -> function Ok x -> Ok x | Error e -> Error (f e) 14 | 15 | 16 | let combine_l (results : ('a, 'e) result list) : ('a list, 'e list) result = 17 | let rec aux combined = function 18 | | [] -> 19 | ( match combined with 20 | | Ok xs -> 21 | Ok (List.rev xs) 22 | | Error es -> 23 | Error (List.rev es) ) 24 | | result :: rest -> 25 | let combined = 26 | match (result, combined) with 27 | | Ok x, Ok xs -> 28 | Ok (x :: xs) 29 | | Error e, Error es -> 30 | Error (e :: es) 31 | | Error e, Ok _ -> 32 | Error [ e ] 33 | | Ok _, Error es -> 34 | Error es 35 | in 36 | aux combined rest 37 | in 38 | aux (Ok []) results 39 | 40 | 41 | module Infix = struct 42 | let ( >|= ) : ('a, 'err) t -> ('a -> 'b) -> ('b, 'err) t = Belt.Result.map 43 | 44 | let ( >>= ) : ('a, 'err) t -> ('a -> ('b, 'err) t) -> ('b, 'err) t = 45 | Belt.Result.flatMap 46 | end 47 | end 48 | 49 | module My_opt = struct 50 | let return x = Some x 51 | 52 | let map f x = Belt.Option.map x f 53 | 54 | let flat_map f x = Belt.Option.flatMap x f 55 | end 56 | 57 | module My_list = struct 58 | let take i xs = xs |. Belt.List.take i |. Belt.Option.getWithDefault [] 59 | 60 | let map f xs = Belt.List.map xs f 61 | 62 | let mapi f xs = Belt.List.mapWithIndex xs f 63 | 64 | let filter_mapi f l = 65 | let rec recurse (acc, i) l = 66 | match l with 67 | | [] -> 68 | List.rev acc 69 | | x :: l' -> 70 | let acc' = match f i x with None -> acc | Some y -> y :: acc in 71 | recurse (acc', i + 1) l' 72 | in 73 | recurse ([], 0) l 74 | 75 | 76 | let filter_map f xs = filter_mapi (fun _i x -> f x) xs 77 | 78 | let find_map f xs = 79 | xs 80 | |. Belt.List.getBy (fun x -> 81 | match f x with Some _ -> true | None -> false ) 82 | |. Belt.Option.flatMap f 83 | 84 | 85 | let fold_left f init xs = Belt.List.reduce xs init f 86 | end 87 | -------------------------------------------------------------------------------- /src-bs/util.mli: -------------------------------------------------------------------------------- 1 | module My_result : sig 2 | type ('good, 'bad) t = ('good, 'bad) Belt.Result.t = 3 | | Ok of 'good 4 | | Error of 'bad 5 | 6 | val return : 'good -> ('good, 'bad) t 7 | 8 | val map : ('a -> 'b) -> ('a, 'err) t -> ('b, 'err) t 9 | 10 | val map_err : ('err1 -> 'err2) -> ('a, 'err1) t -> ('a, 'err2) t 11 | 12 | val combine_l : ('a, 'e) result list -> ('a list, 'e list) result 13 | 14 | module Infix : sig 15 | val ( >|= ) : ('a, 'err) t -> ('a -> 'b) -> ('b, 'err) t 16 | 17 | val ( >>= ) : ('a, 'err) t -> ('a -> ('b, 'err) t) -> ('b, 'err) t 18 | end 19 | end 20 | 21 | module My_opt : sig 22 | val return : 'a -> 'a option 23 | 24 | val map : ('a -> 'b) -> 'a option -> 'b option 25 | 26 | val flat_map : ('a -> 'b option) -> 'a option -> 'b option 27 | end 28 | 29 | module My_list : sig 30 | val take : int -> 'a list -> 'a list 31 | 32 | val map : ('a -> 'b) -> 'a list -> 'b list 33 | 34 | val mapi : (int -> 'a -> 'b) -> 'a list -> 'b list 35 | 36 | val filter_map : ('a -> 'b option) -> 'a list -> 'b list 37 | 38 | val filter_mapi : (int -> 'a -> 'b option) -> 'a list -> 'b list 39 | 40 | val find_map : ('a -> 'b option) -> 'a list -> 'b option 41 | 42 | val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a 43 | end 44 | -------------------------------------------------------------------------------- /src-cbor/decode.ml: -------------------------------------------------------------------------------- 1 | open Decoders 2 | 3 | module Cbor_decodeable : Decode.Decodeable with type value = CBOR.Simple.t = 4 | struct 5 | type value = CBOR.Simple.t 6 | 7 | let pp fmt t = Format.fprintf fmt "@[%s@]" (CBOR.Simple.to_diagnostic t) 8 | 9 | let of_string (input : string) : (value, string) result = 10 | try Ok (CBOR.Simple.decode input) with CBOR.Error msg -> Error msg 11 | 12 | 13 | let of_file (file : string) : (value, string) result = 14 | try 15 | Ok 16 | (Util.with_file_in file (fun chan -> 17 | Util.read_all chan |> CBOR.Simple.decode ) ) 18 | with 19 | | e -> 20 | Error (Printexc.to_string e) 21 | 22 | 23 | let get_string = function `Text str -> Some str | _ -> None 24 | 25 | let get_int = function `Int int -> Some int | _ -> None 26 | 27 | let get_float = function `Float float -> Some float | _ -> None 28 | 29 | let get_null = function `Null -> Some () | _ -> None 30 | 31 | let get_bool = function `Bool bool -> Some bool | _ -> None 32 | 33 | let get_list = function `Array a -> Some a | _ -> None 34 | 35 | let get_key_value_pairs = function `Map assoc -> Some assoc | _ -> None 36 | 37 | let to_list vs = `Array vs 38 | end 39 | 40 | include Decode.Make (Cbor_decodeable) 41 | 42 | (* CBOR-specific decoders *) 43 | 44 | let undefined : unit decoder = 45 | { Decoder.dec = 46 | (function 47 | | `Undefined -> Ok () | json -> (fail "Expected Undefined").dec json ) 48 | } 49 | 50 | 51 | let simple : int decoder = 52 | { Decoder.dec = 53 | (function `Simple i -> Ok i | json -> (fail "Expected Simple").dec json) 54 | } 55 | 56 | 57 | let bytes : string decoder = 58 | { Decoder.dec = 59 | (function `Bytes b -> Ok b | json -> (fail "Expected bytes").dec json) 60 | } 61 | -------------------------------------------------------------------------------- /src-cbor/decode.mli: -------------------------------------------------------------------------------- 1 | include Decoders.Decode.S with type value = CBOR.Simple.t 2 | 3 | val undefined : unit decoder 4 | 5 | val simple : int decoder 6 | 7 | val bytes : string decoder 8 | -------------------------------------------------------------------------------- /src-cbor/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name decoders_cbor) 3 | (public_name decoders-cbor) 4 | (libraries decoders cbor)) 5 | -------------------------------------------------------------------------------- /src-cbor/encode.ml: -------------------------------------------------------------------------------- 1 | module Cbor_encodeable = struct 2 | type value = CBOR.Simple.t 3 | 4 | let to_string value = CBOR.Simple.encode value 5 | 6 | let of_string x = `Text x 7 | 8 | let of_int x = `Int x 9 | 10 | let of_float x = `Float x 11 | 12 | let of_bool x = `Bool x 13 | 14 | let null = `Null 15 | 16 | let of_list xs = `Array xs 17 | 18 | let of_key_value_pairs xs = `Map xs 19 | end 20 | 21 | include Decoders.Encode.Make (Cbor_encodeable) 22 | 23 | let undefined : unit encoder = fun _ -> `Undefined 24 | 25 | let simple : int encoder = fun i -> `Simple i 26 | 27 | let bytes : string encoder = fun b -> `Bytes b 28 | -------------------------------------------------------------------------------- /src-cbor/encode.mli: -------------------------------------------------------------------------------- 1 | include Decoders.Encode.S with type value = CBOR.Simple.t 2 | 3 | val undefined : unit encoder 4 | 5 | val simple : int encoder 6 | 7 | val bytes : string encoder 8 | -------------------------------------------------------------------------------- /src-ezjsonm/decode.ml: -------------------------------------------------------------------------------- 1 | open Decoders 2 | 3 | module Ezjsonm_decodeable : Decode.Decodeable with type value = Ezjsonm.value = 4 | struct 5 | type value = Ezjsonm.value 6 | 7 | let pp_t fmt t = 8 | match t with 9 | | `Null -> 10 | Format.fprintf fmt "@[null@]" 11 | | `Bool bool -> 12 | Format.fprintf fmt "@[%a@]" Format.pp_print_bool bool 13 | | `Float float -> 14 | Format.fprintf fmt "@[%a@]" Format.pp_print_float float 15 | | `String string -> 16 | Format.fprintf fmt "@[%S@]" string 17 | | (`A _ | `O _) as t -> 18 | Format.fprintf fmt "@[%s@]" Ezjsonm.(to_string t) 19 | 20 | 21 | let pp fmt t = Format.fprintf fmt "@[%a@]" pp_t t 22 | 23 | let of_string (input : string) : (value, string) result = 24 | try Ok (Ezjsonm.from_string input) with 25 | | Ezjsonm.Parse_error (_json, msg) -> 26 | Error msg 27 | 28 | 29 | let of_file (file : string) : (value, string) result = 30 | try Ok (Util.with_file_in file Ezjsonm.from_channel) with 31 | | e -> 32 | Error (Printexc.to_string e) 33 | 34 | 35 | let get_string = function `String str -> Some str | _ -> None 36 | 37 | let get_int = function 38 | | `Float float -> 39 | (* TODO: fail if not an int? *) 40 | Some (int_of_float float) 41 | | _ -> 42 | None 43 | 44 | 45 | let get_float = function `Float float -> Some float | _ -> None 46 | 47 | let get_null = function `Null -> Some () | _ -> None 48 | 49 | let get_bool = function `Bool bool -> Some bool | _ -> None 50 | 51 | let get_list = function `A a -> Some a | _ -> None 52 | 53 | let get_key_value_pairs = function 54 | | `O assoc -> 55 | Some (List.map (fun (key, value) -> (`String key, value)) assoc) 56 | | _ -> 57 | None 58 | 59 | 60 | let to_list values = `A values 61 | end 62 | 63 | include Decode.Make (Ezjsonm_decodeable) 64 | -------------------------------------------------------------------------------- /src-ezjsonm/decode.mli: -------------------------------------------------------------------------------- 1 | (** Turn JSON values into Ocaml values via Jsonm. *) 2 | 3 | include Decoders.Decode.S with type value = Ezjsonm.value 4 | -------------------------------------------------------------------------------- /src-ezjsonm/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name decoders_ezjsonm) 3 | (public_name decoders-ezjsonm) 4 | (libraries decoders ezjsonm)) 5 | -------------------------------------------------------------------------------- /src-ezjsonm/encode.ml: -------------------------------------------------------------------------------- 1 | module Ezjsonm_encodeable = struct 2 | type value = Ezjsonm.value 3 | 4 | let to_string = function 5 | | `Null -> 6 | "null" 7 | | `Bool bool -> 8 | string_of_bool bool 9 | | `Float float -> 10 | string_of_float float 11 | | `String string -> 12 | Printf.sprintf "%S" string 13 | | (`A _ | `O _) as json -> 14 | Ezjsonm.(to_string json) 15 | 16 | 17 | let of_string x = `String x 18 | 19 | let of_int x = `Float (float_of_int x) 20 | 21 | let of_float x = `Float x 22 | 23 | let of_bool x = `Bool x 24 | 25 | let null = `Null 26 | 27 | let of_list xs = `A xs 28 | 29 | let of_key_value_pairs xs = 30 | `O 31 | ( xs 32 | |> Decoders.Util.My_list.filter_map (fun (k, v) -> 33 | match k with `String k -> Some (k, v) | _ -> None ) ) 34 | end 35 | 36 | include Decoders.Encode.Make (Ezjsonm_encodeable) 37 | -------------------------------------------------------------------------------- /src-ezjsonm/encode.mli: -------------------------------------------------------------------------------- 1 | include Decoders.Encode.S with type value = Ezjsonm.value 2 | -------------------------------------------------------------------------------- /src-ezxmlm/decode.ml: -------------------------------------------------------------------------------- 1 | open Decoders 2 | open Util 3 | 4 | type value = Ezxmlm.node 5 | 6 | let pp fmt v = Ezxmlm.pp fmt [ v ] 7 | 8 | type error = value Error.t 9 | 10 | let pp_error = Error.pp pp 11 | 12 | let string_of_error = Error.to_string pp 13 | 14 | let pp_name fmt (ns, name) = Format.fprintf fmt "(%S, %S)" ns name 15 | 16 | let of_dtd_nodes = function 17 | | _dtd, [ node ] -> 18 | Ok node 19 | | _ -> 20 | Error (Error.make "expected an XML document with a single root node") 21 | 22 | 23 | let try_parse_with f x = 24 | match f x with 25 | | dtd, nodes -> 26 | of_dtd_nodes (dtd, nodes) 27 | | exception e -> 28 | Error 29 | (Error.tag 30 | "Could not parse an XML document" 31 | (Error.make (Printexc.to_string e)) ) 32 | 33 | 34 | let of_string (s : string) = try_parse_with Ezxmlm.from_string s 35 | 36 | let of_channel (ic : in_channel) = try_parse_with Ezxmlm.from_channel ic 37 | 38 | let of_file (file : string) = 39 | try Util.with_file_in file of_channel with 40 | | e -> 41 | Error 42 | (Error.tag "could not open file" (Error.make (Printexc.to_string e))) 43 | 44 | 45 | type 'a decoder = (value, 'a) Decoder.t 46 | 47 | include Decoder 48 | include Decoder.Infix 49 | 50 | let succeed = pure 51 | 52 | let and_then = bind 53 | 54 | let from_result = of_result 55 | 56 | let tag_ns (name : Xmlm.name) : unit decoder = 57 | Decoder.of_decode_fun 58 | @@ fun (v : value) -> 59 | match v with 60 | | `El ((name', _), _) when name = name' -> 61 | Ok () 62 | | `El _ -> 63 | Error 64 | (Error.make 65 | (Format.asprintf "Expected a tag with name %a" pp_name name) 66 | ~context:v ) 67 | | `Data _ -> 68 | (fail "Expected a Tag").dec v 69 | 70 | 71 | let tag (name : string) : unit decoder = 72 | Decoder.of_decode_fun 73 | @@ fun (v : value) -> 74 | match v with 75 | | `El (((_ns, name'), _), _) when name = name' -> 76 | Ok () 77 | | `El _ -> 78 | Error 79 | (Error.make 80 | (Format.asprintf "Expected a tag with name %S" name) 81 | ~context:v ) 82 | | `Data _ -> 83 | (fail "Expected a Tag").dec v 84 | 85 | 86 | let any_tag_ns : Xmlm.name decoder = 87 | Decoder.of_decode_fun 88 | @@ fun (v : value) -> 89 | match v with 90 | | `El ((name, _), _) -> 91 | Ok name 92 | | `Data _ -> 93 | (fail "Expected a Tag").dec v 94 | 95 | 96 | let any_tag : string decoder = 97 | Decoder.of_decode_fun 98 | @@ fun (v : value) -> 99 | match v with 100 | | `El (((_ns, name), _), _) -> 101 | Ok name 102 | | `Data _ -> 103 | (fail "Expected a Tag").dec v 104 | 105 | 106 | let data : string decoder = 107 | Decoder.of_decode_fun 108 | @@ fun (v : value) -> 109 | match v with `Data s -> Ok s | `El _ -> (fail "Expected Data").dec v 110 | 111 | 112 | let float : float decoder = 113 | data 114 | >>= fun s -> 115 | match s |> String.trim |> float_of_string_opt with 116 | | None -> 117 | fail "Expected a float" 118 | | Some f -> 119 | succeed f 120 | 121 | 122 | let int : int decoder = 123 | data 124 | >>= fun s -> 125 | match s |> String.trim |> int_of_string_opt with 126 | | None -> 127 | fail "Expected an int" 128 | | Some f -> 129 | succeed f 130 | 131 | 132 | let bool : bool decoder = 133 | data 134 | >>= fun s -> 135 | match s |> String.trim |> bool_of_string_opt with 136 | | None -> 137 | fail "Expected a bool" 138 | | Some f -> 139 | succeed f 140 | 141 | 142 | let attrs_ns : Xmlm.attribute list decoder = 143 | Decoder.of_decode_fun 144 | @@ function 145 | | `El ((_tag, attrs), _children) -> 146 | Ok attrs 147 | | `Data _ as v -> 148 | (fail "Expected a Tag").dec v 149 | 150 | 151 | let attr_opt_ns (name : Xmlm.name) : string option decoder = 152 | attrs_ns 153 | >|= My_list.find_map (fun (name', value) -> 154 | if name = name' then Some value else None ) 155 | 156 | 157 | let attr_ns (name : Xmlm.name) : string decoder = 158 | attr_opt_ns name 159 | >>= function 160 | | Some value -> 161 | pure value 162 | | None -> 163 | fail (Format.asprintf "Expected an attribute named %a" pp_name name) 164 | 165 | 166 | let attrs : (string * string) list decoder = 167 | attrs_ns >|= My_list.map (fun ((_ns, name), value) -> (name, value)) 168 | 169 | 170 | let attr_opt (name : string) : string option decoder = 171 | attrs 172 | >|= My_list.find_map (fun (name', value) -> 173 | if name = name' then Some value else None ) 174 | 175 | 176 | let attr (name : string) : string decoder = 177 | attr_opt name 178 | >>= function 179 | | Some value -> 180 | pure value 181 | | None -> 182 | fail (Format.asprintf "Expected an attribute named %s" name) 183 | 184 | 185 | let pick_children (child : 'a decoder decoder) : 'a list decoder = 186 | Decoder.of_decode_fun 187 | @@ function 188 | | `El ((name, _attrs), els) -> 189 | els 190 | |> My_list.filter_mapi (fun i el -> 191 | match child.dec el with 192 | | Error _ -> 193 | None 194 | | Ok dec -> 195 | Some 196 | ( dec.dec el 197 | |> My_result.map_err 198 | (Error.tag 199 | (Format.asprintf "While decoding child %i" i) ) ) ) 200 | |> My_result.combine_l 201 | |> My_result.map_err 202 | (Error.tag_group (Format.asprintf "In tag %a" pp_name name)) 203 | | `Data _ as v -> 204 | (fail "Expected a Tag").dec v 205 | 206 | 207 | let children (child : 'a decoder) : 'a list decoder = pick_children (pure child) 208 | 209 | let decode_value decoder v = decoder.dec v 210 | 211 | let decode_string : 'a decoder -> string -> ('a, error) result = 212 | fun decoder string -> 213 | My_result.Infix.(of_string string >>= decode_value decoder) 214 | 215 | 216 | let decode_file : 'a decoder -> string -> ('a, error) result = 217 | fun decoder file -> My_result.Infix.(of_file file >>= decode_value decoder) 218 | -------------------------------------------------------------------------------- /src-ezxmlm/decode.mli: -------------------------------------------------------------------------------- 1 | include Decoders.Xml.Decode with type value = Ezxmlm.node 2 | 3 | val tag_ns : Xmlm.name -> unit decoder 4 | 5 | val any_tag_ns : Xmlm.name decoder 6 | 7 | val attrs_ns : Xmlm.attribute list decoder 8 | 9 | val attr_opt_ns : Xmlm.name -> string option decoder 10 | 11 | val attr_ns : Xmlm.name -> string decoder 12 | -------------------------------------------------------------------------------- /src-ezxmlm/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name decoders_ezxmlm) 3 | (public_name decoders-ezxmlm) 4 | (libraries decoders ezxmlm)) 5 | -------------------------------------------------------------------------------- /src-jsonaf/decoders_jsonaf.ml: -------------------------------------------------------------------------------- 1 | open Decoders 2 | 3 | module Decode = struct 4 | include Decode.Make (Jsonaf_decodeable) 5 | 6 | let number : string decoder = 7 | { Decoder.dec = 8 | (fun t -> 9 | match Jsonaf_decodeable.get_number t with 10 | | Some value -> 11 | Ok value 12 | | None -> 13 | Error (Decoders.Error.make ~context:t "not a number") ) 14 | } 15 | end 16 | 17 | module Encode = struct 18 | include Encode.Make (Jsonaf_encodeable) 19 | 20 | let number n = Jsonaf_encodeable.of_number n 21 | end 22 | -------------------------------------------------------------------------------- /src-jsonaf/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name decoders_jsonaf) 3 | (public_name decoders-jsonaf) 4 | (libraries decoders jsonaf)) 5 | -------------------------------------------------------------------------------- /src-jsonaf/jsonaf_decodeable.ml: -------------------------------------------------------------------------------- 1 | type value = Jsonaf.t 2 | 3 | let pp fmt json = Format.fprintf fmt "@[%s@]" (Jsonaf.to_string_hum json) 4 | 5 | let of_string : string -> (value, string) Result.t = 6 | fun string -> 7 | match Jsonaf.parse string with 8 | | Ok json -> 9 | Ok json 10 | | Error e -> 11 | Error (Base.Error.to_string_hum e) 12 | 13 | 14 | let of_file _ = failwith "Json_decodeable.of_file: not implemented" 15 | 16 | let get_string : value -> string option = function 17 | | `String value -> 18 | Some value 19 | | _ -> 20 | None 21 | 22 | 23 | let get_number : value -> string option = function 24 | | `Number value -> 25 | Some value 26 | | _ -> 27 | None 28 | 29 | 30 | let get_int : value -> int option = function 31 | | `Number value -> 32 | int_of_string_opt value 33 | | _ -> 34 | None 35 | 36 | 37 | let get_float : value -> float option = function 38 | | `Number value -> 39 | float_of_string_opt value 40 | | _ -> 41 | None 42 | 43 | 44 | let get_bool : value -> bool option = function 45 | | `True -> 46 | Some true 47 | | `False -> 48 | Some false 49 | | _ -> 50 | None 51 | 52 | 53 | let get_null : value -> unit option = function `Null -> Some () | _ -> None 54 | 55 | let get_list : value -> value list option = function 56 | | `Array values -> 57 | Some values 58 | | _ -> 59 | None 60 | 61 | 62 | let get_key_value_pairs : value -> (value * value) list option = function 63 | | `Object pairs -> 64 | Some (List.map (fun (k, v) -> (`String k, v)) pairs) 65 | | _ -> 66 | None 67 | 68 | 69 | let to_list values = `Array values 70 | -------------------------------------------------------------------------------- /src-jsonaf/jsonaf_decodeable.mli: -------------------------------------------------------------------------------- 1 | open Decoders 2 | 3 | type value = Jsonaf.t 4 | 5 | include Decode.Decodeable with type value := value 6 | 7 | val get_number : value -> string option 8 | -------------------------------------------------------------------------------- /src-jsonaf/jsonaf_encodeable.ml: -------------------------------------------------------------------------------- 1 | type value = Jsonaf.t 2 | 3 | let to_string json = Jsonaf.to_string json 4 | 5 | let of_string s = `String s 6 | 7 | let of_int i = `Number (string_of_int i) 8 | 9 | let of_number n = `Number n 10 | 11 | let of_float f = 12 | let s = string_of_float f in 13 | let len = String.length s in 14 | if String.get s (len - 1) = '.' 15 | then `Number (String.sub s 0 (len - 1)) 16 | else `Number s 17 | 18 | 19 | let of_bool x = if x then `True else `False 20 | 21 | let null = `Null 22 | 23 | let of_list xs = `Array xs 24 | 25 | let of_key_value_pairs xs = 26 | let string_keyed (k, v) = 27 | match k with `String k -> Some (k, v) | _ -> None 28 | in 29 | let pairs = List.filter_map string_keyed xs in 30 | `Object pairs 31 | -------------------------------------------------------------------------------- /src-jsonaf/jsonaf_encodeable.mli: -------------------------------------------------------------------------------- 1 | open Decoders 2 | 3 | type value = Jsonaf.t 4 | 5 | include Encode.Encodeable with type value := value 6 | 7 | val of_number : string -> value 8 | -------------------------------------------------------------------------------- /src-jsonm/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name decoders_jsonm) 3 | (public_name decoders-jsonm) 4 | (libraries decoders jsonm)) 5 | -------------------------------------------------------------------------------- /src-jsonm/encode.ml: -------------------------------------------------------------------------------- 1 | type env = 2 | { encoder : Jsonm.encoder 3 | ; on_partial : unit -> unit 4 | } 5 | 6 | let make_env 7 | ~encoder ?(on_partial = fun () -> failwith "Not expecting `Partial") () = 8 | { encoder; on_partial } 9 | 10 | 11 | let make_encoder' x { encoder; on_partial } = 12 | let rec await () = 13 | on_partial () ; 14 | match Jsonm.encode encoder `Await with `Ok -> () | `Partial -> await () 15 | in 16 | match Jsonm.encode encoder x with `Ok -> () | `Partial -> await () 17 | 18 | 19 | let make_encoder l env = make_encoder' (`Lexeme l) env 20 | 21 | type v = env -> unit 22 | 23 | let ( >> ) (v1 : v) (v2 : v) : v = 24 | fun env -> 25 | v1 env ; 26 | v2 env 27 | 28 | 29 | let iter encode xs : v = fun env -> xs |> List.iter (fun x -> encode x env) 30 | 31 | let object_start = make_encoder `Os 32 | 33 | let name x = make_encoder (`Name x) 34 | 35 | let object_end = make_encoder `Oe 36 | 37 | let array_start = make_encoder `As 38 | 39 | let array_end = make_encoder `Ae 40 | 41 | let end_ = make_encoder' `End 42 | 43 | module Jsonm_encodeable = struct 44 | type value = v 45 | 46 | let to_string (_v : value) : string = failwith "Not implemented" 47 | 48 | let of_string x : value = make_encoder (`String x) 49 | 50 | let of_int x : value = make_encoder (`Float (float_of_int x)) 51 | 52 | let of_float x : value = make_encoder (`Float x) 53 | 54 | let of_bool x : value = make_encoder (`Bool x) 55 | 56 | let null : value = make_encoder `Null 57 | 58 | let of_list (xs : value list) : value = 59 | array_start >> iter (fun x -> x) xs >> array_end 60 | 61 | 62 | let of_key_value_pairs (xs : (value * value) list) : value = 63 | object_start >> iter (fun (k, v) -> k >> v) xs >> object_end 64 | end 65 | 66 | include Decoders.Encode.Make (Jsonm_encodeable) 67 | 68 | (* Override with more efficient implementations *) 69 | 70 | let list encode xs = array_start >> iter encode xs >> array_end 71 | 72 | let obj (xs : (string * value) list) : value = 73 | object_start >> iter (fun (k, v) -> name k >> v) xs >> object_end 74 | 75 | 76 | let encode_value encoder x = encoder x >> end_ 77 | 78 | let encode_string encoder x = 79 | let b = Buffer.create 16 in 80 | let env = make_env ~encoder:(Jsonm.encoder ~minify:true (`Buffer b)) () in 81 | let () = encode_value encoder x env in 82 | Buffer.contents b 83 | -------------------------------------------------------------------------------- /src-jsonm/encode.mli: -------------------------------------------------------------------------------- 1 | (** Streaming encoding using [Jsonm]. 2 | 3 | Example usage: 4 | 5 | {[ 6 | module E = Decoders_jsonm.Encode 7 | 8 | let run_encoder out_channel (encode : t E.encoder) (x : t) = 9 | let dst = `Channel out_channel in 10 | let encoder = Jsonm.encoder ~minify:true dst in 11 | let env = E.make_env ~encoder () in 12 | E.encode_value encode x env 13 | ]} 14 | *) 15 | 16 | type env 17 | 18 | val make_env : 19 | encoder:Jsonm.encoder -> ?on_partial:(unit -> unit) -> unit -> env 20 | 21 | include Decoders.Encode.S with type value = env -> unit 22 | 23 | (** {2 Low-level combinators} 24 | 25 | Assuming we have: 26 | 27 | {[ 28 | type member 29 | val member : member encoder 30 | ]} 31 | 32 | And a type [x]: 33 | 34 | {[ 35 | type x = 36 | { id : string 37 | ; members : member list 38 | } 39 | ]} 40 | 41 | An encoder for [x] might look like this: 42 | 43 | {[ 44 | let x_encoder x = 45 | object_start >> 46 | 47 | name "id" >> 48 | string x.id >> 49 | 50 | name "members" >> 51 | array_start >> 52 | iter member x.members >> 53 | array_end >> 54 | 55 | object_end 56 | ]} 57 | *) 58 | 59 | val ( >> ) : value -> value -> value 60 | 61 | val iter : 'a encoder -> 'a list -> value 62 | 63 | val object_start : value 64 | 65 | val name : string -> value 66 | 67 | val object_end : value 68 | 69 | val array_start : value 70 | 71 | val array_end : value 72 | 73 | val end_ : value 74 | -------------------------------------------------------------------------------- /src-msgpck/decode.ml: -------------------------------------------------------------------------------- 1 | open Decoders 2 | module M = Msgpck 3 | 4 | module Msgpck_decodeable : Decode.Decodeable with type value = Msgpck.t = struct 5 | type value = Msgpck.t 6 | 7 | let pp fmt t = Format.fprintf fmt "@[%a@]" Msgpck.pp t 8 | 9 | let of_string (input : string) : (value, string) result = 10 | try Ok (snd @@ M.StringBuf.read input) with Invalid_argument s -> Error s 11 | 12 | 13 | let of_file (file : string) : (value, string) result = 14 | try 15 | Ok 16 | (Util.with_file_in file (fun chan -> 17 | Util.read_all chan |> M.StringBuf.read |> snd ) ) 18 | with 19 | | e -> 20 | Error (Printexc.to_string e) 21 | 22 | 23 | let get_string = function M.String str | M.Bytes str -> Some str | _ -> None 24 | 25 | (* note: the other int constructors are only used for values that do 26 | not fit in [int]. *) 27 | let get_int = function M.Int int -> Some int | _ -> None 28 | 29 | let get_float = function 30 | | M.Float float -> 31 | Some float 32 | | M.Float32 f -> 33 | Some (Int32.float_of_bits f) 34 | | _ -> 35 | None 36 | 37 | 38 | let get_null = function M.Nil -> Some () | _ -> None 39 | 40 | let get_bool = function M.Bool bool -> Some bool | _ -> None 41 | 42 | let get_list = function M.List a -> Some a | _ -> None 43 | 44 | let get_key_value_pairs = function M.Map assoc -> Some assoc | _ -> None 45 | 46 | let to_list vs = M.List vs 47 | end 48 | 49 | include Decode.Make (Msgpck_decodeable) 50 | 51 | let string_strict : string decoder = 52 | { Decoder.dec = 53 | (function 54 | | M.String b -> Ok b | m -> (fail "Expected string (strict)").dec m ) 55 | } 56 | 57 | 58 | let bytes : string decoder = 59 | { Decoder.dec = 60 | (function M.Bytes b -> Ok b | m -> (fail "Expected bytes").dec m) 61 | } 62 | 63 | 64 | let int32 : _ decoder = 65 | { Decoder.dec = 66 | (function M.Int32 i -> Ok i | m -> (fail "Expected int32").dec m) 67 | } 68 | 69 | 70 | let int64 : _ decoder = 71 | { Decoder.dec = 72 | (function M.Int64 i -> Ok i | m -> (fail "Expected int64").dec m) 73 | } 74 | 75 | 76 | let uint32 : _ decoder = 77 | { Decoder.dec = 78 | (function M.Uint32 i -> Ok i | m -> (fail "Expected uint32").dec m) 79 | } 80 | 81 | 82 | let uint64 : _ decoder = 83 | { Decoder.dec = 84 | (function M.Uint64 i -> Ok i | m -> (fail "Expected uint64").dec m) 85 | } 86 | 87 | 88 | let ext : (int * string) decoder = 89 | { Decoder.dec = 90 | (function 91 | | M.Ext (i, s) -> Ok (i, s) | m -> (fail "Expected extension").dec m ) 92 | } 93 | -------------------------------------------------------------------------------- /src-msgpck/decode.mli: -------------------------------------------------------------------------------- 1 | include Decoders.Decode.S with type value = Msgpck.t 2 | 3 | val string_strict : string decoder 4 | (** Only accepts [String], not [Bytes]. The string should be valid UTF8 5 | per the spec. *) 6 | 7 | val bytes : string decoder 8 | (** Raw data only. *) 9 | 10 | val int32 : int32 decoder 11 | 12 | val int64 : int64 decoder 13 | 14 | val uint32 : int32 decoder 15 | 16 | val uint64 : int64 decoder 17 | 18 | val ext : (int * string) decoder 19 | -------------------------------------------------------------------------------- /src-msgpck/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name decoders_msgpck) 3 | (public_name decoders-msgpck) 4 | (flags :standard -warn-error -a+8) 5 | (libraries decoders msgpck)) 6 | -------------------------------------------------------------------------------- /src-msgpck/encode.ml: -------------------------------------------------------------------------------- 1 | module M = Msgpck 2 | 3 | module Msgpck_encodeable = struct 4 | type value = M.t 5 | 6 | let to_string value = 7 | let buf = M.StringBuf.to_string value in 8 | Buffer.contents buf 9 | 10 | 11 | let of_string x = M.String x 12 | 13 | let of_int x = M.Int x 14 | 15 | let of_float x = M.Float x 16 | 17 | let of_bool x = M.Bool x 18 | 19 | let null = M.Nil 20 | 21 | let of_list xs = M.List xs 22 | 23 | let of_key_value_pairs xs = M.Map xs 24 | end 25 | 26 | include Decoders.Encode.Make (Msgpck_encodeable) 27 | 28 | let ext (i, s) = M.Ext (i, s) 29 | 30 | let int32 i = M.Int32 i 31 | 32 | let int64 i = M.Int64 i 33 | 34 | let uint32 i = M.Uint32 i 35 | 36 | let uint64 i = M.Uint64 i 37 | 38 | let bytes : string encoder = fun b -> M.Bytes b 39 | -------------------------------------------------------------------------------- /src-msgpck/encode.mli: -------------------------------------------------------------------------------- 1 | include Decoders.Encode.S with type value = Msgpck.t 2 | 3 | val ext : (int * string) encoder 4 | 5 | val int32 : int32 encoder 6 | 7 | val int64 : int64 encoder 8 | 9 | val uint32 : int32 encoder 10 | 11 | val uint64 : int64 encoder 12 | 13 | val bytes : string encoder 14 | -------------------------------------------------------------------------------- /src-ocyaml/decode.ml: -------------------------------------------------------------------------------- 1 | (** {2 Ocyaml implementation} *) 2 | 3 | open Decoders 4 | 5 | module Yaml_decodeable : Decode.Decodeable with type value = Ocyaml.yaml = 6 | struct 7 | open Ocyaml 8 | 9 | type value = yaml 10 | 11 | let rec pp fmt = function 12 | | Scalar string -> 13 | Format.fprintf fmt "@[%S@]" string 14 | | Collection xs -> 15 | Format.fprintf 16 | fmt 17 | "@[%a@]" 18 | (Format.pp_print_list (fun fmt yaml -> 19 | Format.fprintf fmt "- @[%a@]" pp yaml ) ) 20 | xs 21 | | Structure xs -> 22 | Format.fprintf 23 | fmt 24 | "@[%a@]" 25 | (Format.pp_print_list (fun fmt (key, value) -> 26 | Format.fprintf fmt "@[%a@]:@ @[%a@]" pp key pp value ) ) 27 | xs 28 | 29 | 30 | let of_string : string -> (value, string) result = 31 | fun string -> 32 | try Ok (Ocyaml.of_string string) with 33 | | exn -> 34 | Error (Printexc.to_string exn) 35 | 36 | 37 | let of_file file = 38 | try Ok (Ocyaml.of_file file) with e -> Error (Printexc.to_string e) 39 | 40 | 41 | let get_string : value -> string option = function 42 | | Scalar value -> 43 | Some value 44 | | _ -> 45 | None 46 | 47 | 48 | let get_int : value -> int option = 49 | fun t -> 50 | try get_string t |> Util.My_opt.map int_of_string with Failure _ -> None 51 | 52 | 53 | let get_float : value -> float option = 54 | fun t -> 55 | try get_string t |> Util.My_opt.map float_of_string with Failure _ -> None 56 | 57 | 58 | let get_bool : value -> bool option = 59 | fun t -> 60 | try get_string t |> Util.My_opt.map bool_of_string with Failure _ -> None 61 | 62 | 63 | let get_null : value -> unit option = 64 | fun t -> 65 | get_string t |> Util.My_opt.flat_map (function "" -> Some () | _ -> None) 66 | 67 | 68 | let get_list = function Collection l -> Some l | _ -> None 69 | 70 | let get_key_value_pairs = function Structure assoc -> Some assoc | _ -> None 71 | 72 | let to_list values = Collection values 73 | end 74 | 75 | include Decode.Make (Yaml_decodeable) 76 | -------------------------------------------------------------------------------- /src-ocyaml/decode.mli: -------------------------------------------------------------------------------- 1 | (** Turn Yaml values into Ocaml values. *) 2 | 3 | include Decoders.Decode.S with type value = Ocyaml.yaml 4 | -------------------------------------------------------------------------------- /src-ocyaml/dune: -------------------------------------------------------------------------------- 1 | ; (library 2 | ; (name decoders_ocyaml) 3 | ; (public_name decoders-ocyaml) 4 | ; (libraries decoders containers ocyaml)) 5 | -------------------------------------------------------------------------------- /src-otoml/decoders_otoml.ml: -------------------------------------------------------------------------------- 1 | (** {2 Yojson implementation} *) 2 | 3 | open Decoders 4 | 5 | module Make 6 | (Toml : Otoml.Base.TomlImplementation 7 | with type toml_integer = int 8 | and type toml_float = float) = 9 | struct 10 | module T = Toml 11 | 12 | module Toml_decodeable : Decode.Decodeable with type value = T.t = struct 13 | type value = Toml.t 14 | 15 | let pp fmt v = Format.fprintf fmt "@[%s@]" (T.Printer.to_string v) 16 | 17 | let of_string : string -> (value, string) result = 18 | fun string -> T.Parser.from_string_result string 19 | 20 | 21 | let of_file file = T.Parser.from_file_result file 22 | 23 | let get_string = function T.TomlString value -> Some value | _ -> None 24 | 25 | let get_int = function T.TomlInteger value -> Some value | _ -> None 26 | 27 | let get_float = function 28 | | T.TomlFloat value -> 29 | Some value 30 | | T.TomlInteger value -> 31 | Some (float_of_int value) 32 | | _ -> 33 | None 34 | 35 | 36 | let get_bool = function T.TomlBoolean value -> Some value | _ -> None 37 | 38 | let get_null = function T.TomlString "" -> Some () | _ -> None 39 | 40 | let get_list : value -> value list option = function 41 | | T.TomlArray l | T.TomlTableArray l -> 42 | Some l 43 | | _ -> 44 | None 45 | 46 | 47 | let get_key_value_pairs : value -> (value * value) list option = function 48 | | T.TomlTable assoc | T.TomlInlineTable assoc -> 49 | Some (List.map (fun (key, value) -> (T.string key, value)) assoc) 50 | | _ -> 51 | None 52 | 53 | 54 | let to_list values = T.array values 55 | end 56 | 57 | module Decode = Decode.Make (Toml_decodeable) 58 | 59 | module Toml_encodeable = struct 60 | type value = Toml.t 61 | 62 | let to_string v = Toml.Printer.to_string v 63 | 64 | let of_string = Toml.string 65 | 66 | let of_int = Toml.integer 67 | 68 | let of_float = Toml.float 69 | 70 | let of_bool = Toml.boolean 71 | 72 | let null = Toml.string "" 73 | 74 | let of_list = Toml.array 75 | 76 | let of_key_value_pairs xs = 77 | Toml.inline_table 78 | ( xs 79 | |> Util.My_list.filter_map (fun (k, v) -> 80 | match k with Toml.TomlString k -> Some (k, v) | _ -> None ) ) 81 | end 82 | 83 | module Encode = Encode.Make (Toml_encodeable) 84 | end 85 | 86 | include Make (Otoml) 87 | -------------------------------------------------------------------------------- /src-otoml/decoders_otoml.mli: -------------------------------------------------------------------------------- 1 | (** Turn JSON values into Ocaml values. *) 2 | 3 | module Make 4 | (Toml : Otoml.Base.TomlImplementation 5 | with type toml_integer = int 6 | and type toml_float = float) : sig 7 | module Decode : Decoders.Decode.S with type value = Toml.t 8 | 9 | module Encode : Decoders.Encode.S with type value = Toml.t 10 | end 11 | 12 | module Decode : Decoders.Decode.S with type value = Otoml.t 13 | 14 | module Encode : Decoders.Encode.S with type value = Otoml.t 15 | -------------------------------------------------------------------------------- /src-otoml/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name decoders_otoml) 3 | (public_name decoders-otoml) 4 | (flags :standard -warn-error -a+8) 5 | (libraries decoders otoml)) 6 | -------------------------------------------------------------------------------- /src-sexplib/decode.ml: -------------------------------------------------------------------------------- 1 | open Decoders 2 | open Sexplib0 3 | 4 | module Sexplib_decodeable : Decode.Decodeable with type value = Sexp.t = struct 5 | type value = Sexp.t 6 | 7 | let pp fmt value = Format.fprintf fmt "@[%a@]" Sexp.pp_hum value 8 | 9 | let of_string (input : string) : (value, string) result = 10 | try Ok (Sexplib.Sexp.of_string input) with Failure msg -> Error msg 11 | 12 | 13 | let of_file (file : string) : (value, string) result = 14 | try Ok (Sexplib.Sexp.load_sexp file) with 15 | | e -> 16 | Error (Printexc.to_string e) 17 | 18 | 19 | let try_get f value = 20 | try Some (f value) with Sexp_conv.Of_sexp_error _ -> None 21 | 22 | 23 | let get_string = try_get Sexp_conv.string_of_sexp 24 | 25 | let get_int = try_get Sexp_conv.int_of_sexp 26 | 27 | let get_float = try_get Sexp_conv.float_of_sexp 28 | 29 | let get_null = try_get Sexp_conv.unit_of_sexp 30 | 31 | let get_bool = try_get Sexp_conv.bool_of_sexp 32 | 33 | let get_list = function Sexp.List lst -> Some lst | _ -> None 34 | 35 | let get_key_value_pairs = function 36 | | Sexp.List lst -> 37 | lst 38 | |> Util.My_list.map (function 39 | | Sexp.List [ key; value ] -> 40 | Some (key, value) 41 | | Sexp.List (key :: values) -> 42 | Some (key, Sexp.List values) 43 | | _ -> 44 | None ) 45 | |> Util.My_list.all_some 46 | | _ -> 47 | None 48 | 49 | 50 | let to_list values = Sexp.List values 51 | end 52 | 53 | include Decode.Make (Sexplib_decodeable) 54 | -------------------------------------------------------------------------------- /src-sexplib/decode.mli: -------------------------------------------------------------------------------- 1 | (** Turn S-expressions into Ocaml values via Sexplib. *) 2 | 3 | (** Following the convention of [Sexplib0.Sexp_conv.hashtbl_of_sexp], we 4 | consider an S-expression to be an "object" if it is a list of two-element 5 | lists. For example: 6 | 7 | ((field1 value1) (field2 (value2 value3))) 8 | 9 | Following `dune` conventions, we also allow as "objects" S-expressions like: 10 | 11 | ((field1 value1) (field2 value2 value3)) 12 | 13 | These two S-expressions will be treated in the same way by the object 14 | combinators below (e.g. [field]). 15 | 16 | Like YAML, fields of an object are not necessarily atoms. To handle these, 17 | look for the primed combinators (e.g. [keys']). 18 | *) 19 | 20 | include Decoders.Decode.S with type value = Sexplib0.Sexp.t 21 | -------------------------------------------------------------------------------- /src-sexplib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name decoders_sexplib) 3 | (public_name decoders-sexplib) 4 | (libraries decoders sexplib sexplib0)) 5 | -------------------------------------------------------------------------------- /src-yojson/basic.ml: -------------------------------------------------------------------------------- 1 | (** {2 Yojson implementation} *) 2 | 3 | open Decoders 4 | 5 | module Json_decodeable : Decode.Decodeable with type value = Yojson.Basic.t = 6 | struct 7 | type value = Yojson.Basic.t 8 | 9 | let pp fmt json = 10 | Format.fprintf fmt "@[%s@]" (Yojson.Basic.pretty_to_string json) 11 | 12 | 13 | let of_string : string -> (value, string) result = 14 | fun string -> 15 | try Ok (Yojson.Basic.from_string string) with 16 | | Yojson.Json_error msg -> 17 | Error msg 18 | 19 | 20 | let of_file file = 21 | try Ok (Yojson.Basic.from_file file) with 22 | | e -> 23 | Error (Printexc.to_string e) 24 | 25 | 26 | let get_string = function `String value -> Some value | _ -> None 27 | 28 | let get_int = function `Int value -> Some value | _ -> None 29 | 30 | let get_float = function 31 | | `Float value -> 32 | Some value 33 | | `Int value -> 34 | Some (float_of_int value) 35 | | _ -> 36 | None 37 | 38 | 39 | let get_bool = function `Bool value -> Some value | _ -> None 40 | 41 | let get_null = function `Null -> Some () | _ -> None 42 | 43 | let get_list : value -> value list option = function 44 | | `List l -> 45 | Some l 46 | | _ -> 47 | None 48 | 49 | 50 | let get_key_value_pairs : value -> (value * value) list option = function 51 | | `Assoc assoc -> 52 | Some (List.map (fun (key, value) -> (`String key, value)) assoc) 53 | | _ -> 54 | None 55 | 56 | 57 | let to_list values = `List values 58 | end 59 | 60 | module Decode = Decode.Make (Json_decodeable) 61 | 62 | module Json_encodeable = struct 63 | type value = Yojson.Basic.t 64 | 65 | let to_string json = Yojson.Basic.to_string json 66 | 67 | let of_string x = `String x 68 | 69 | let of_int x = `Int x 70 | 71 | let of_float x = `Float x 72 | 73 | let of_bool x = `Bool x 74 | 75 | let null = `Null 76 | 77 | let of_list xs = `List xs 78 | 79 | let of_key_value_pairs xs = 80 | `Assoc 81 | ( xs 82 | |> Util.My_list.filter_map (fun (k, v) -> 83 | match k with `String k -> Some (k, v) | _ -> None ) ) 84 | end 85 | 86 | module Encode = Encode.Make (Json_encodeable) 87 | -------------------------------------------------------------------------------- /src-yojson/basic.mli: -------------------------------------------------------------------------------- 1 | (** Turn JSON values into Ocaml values. *) 2 | 3 | module Decode : Decoders.Decode.S with type value = Yojson.Basic.t 4 | 5 | module Encode : Decoders.Encode.S with type value = Yojson.Basic.t 6 | -------------------------------------------------------------------------------- /src-yojson/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name decoders_yojson) 3 | (public_name decoders-yojson) 4 | (flags :standard -warn-error -3) 5 | (libraries decoders yojson)) 6 | -------------------------------------------------------------------------------- /src-yojson/raw.ml: -------------------------------------------------------------------------------- 1 | (** {2 Yojson implementation} *) 2 | 3 | open Decoders 4 | 5 | module Json_decodeable : Decode.Decodeable with type value = Yojson.Raw.t = 6 | struct 7 | type value = Yojson.Raw.t 8 | 9 | let pp fmt json = 10 | Format.fprintf fmt "@[%s@]" (Yojson.Raw.pretty_to_string json) 11 | 12 | 13 | let of_string : string -> (value, string) result = 14 | fun string -> 15 | try Ok (Yojson.Raw.from_string string) with 16 | | Yojson.Json_error msg -> 17 | Error msg 18 | 19 | 20 | let of_file file = 21 | try Ok (Yojson.Raw.from_file file) with e -> Error (Printexc.to_string e) 22 | 23 | 24 | let get_string = function 25 | | `Stringlit s -> 26 | (* Stringlits are wrapped in double-quotes. *) 27 | Some (String.sub s 1 (String.length s - 2)) 28 | | _ -> 29 | None 30 | 31 | 32 | let get_int = function 33 | | `Intlit value -> 34 | (try Some (int_of_string value) with _ -> None) 35 | | _ -> 36 | None 37 | 38 | 39 | let get_float = function 40 | | `Floatlit value -> 41 | Some (float_of_string value) 42 | | `Intlit value -> 43 | Some (float_of_string value) 44 | | _ -> 45 | None 46 | 47 | 48 | let get_bool = function `Bool value -> Some value | _ -> None 49 | 50 | let get_null = function `Null -> Some () | _ -> None 51 | 52 | let get_list : value -> value list option = function 53 | | `List l -> 54 | Some l 55 | | _ -> 56 | None 57 | 58 | 59 | let get_key_value_pairs : value -> (value * value) list option = function 60 | | `Assoc assoc -> 61 | Some 62 | (List.map 63 | (fun (key, value) -> (`Stringlit (Printf.sprintf "%S" key), value)) 64 | assoc ) 65 | | _ -> 66 | None 67 | 68 | 69 | let to_list values = `List values 70 | end 71 | 72 | module Decode = struct 73 | include Decode.Make (Json_decodeable) 74 | 75 | (* Yojson.Raw specific decoders *) 76 | 77 | let stringlit : string decoder = 78 | { Decoder.dec = 79 | (function 80 | | `Stringlit value -> 81 | Ok value 82 | | json -> 83 | (fail "Expected a string").dec json ) 84 | } 85 | 86 | 87 | let intlit : string decoder = 88 | { Decoder.dec = 89 | (function 90 | | `Intlit value -> Ok value | json -> (fail "Expected an int").dec json 91 | ) 92 | } 93 | 94 | 95 | let floatlit : string decoder = 96 | { Decoder.dec = 97 | (function 98 | | `Floatlit value -> 99 | Ok value 100 | | `Intlit value -> 101 | Ok value 102 | | json -> 103 | (fail "Expected a float").dec json ) 104 | } 105 | end 106 | 107 | module Json_encodeable = struct 108 | type value = Yojson.Raw.t 109 | 110 | let to_string json = Yojson.Raw.to_string json 111 | 112 | let of_string x = `Stringlit (Printf.sprintf "%S" x) 113 | 114 | let of_int x = `Intlit (string_of_int x) 115 | 116 | let of_float x = `Floatlit (string_of_float x) 117 | 118 | let of_bool x = `Bool x 119 | 120 | let null = `Null 121 | 122 | let of_list xs = `List xs 123 | 124 | let of_key_value_pairs xs = 125 | `Assoc 126 | ( xs 127 | |> Util.My_list.filter_map (fun (k, v) -> 128 | Json_decodeable.get_string k |> Util.My_opt.map (fun k -> (k, v)) ) 129 | ) 130 | end 131 | 132 | module Encode = struct 133 | include Encode.Make (Json_encodeable) 134 | 135 | let stringlit x = `Stringlit x 136 | 137 | let intlit x = `Intlit x 138 | 139 | let floatlit x = `Floatlit x 140 | end 141 | -------------------------------------------------------------------------------- /src-yojson/raw.mli: -------------------------------------------------------------------------------- 1 | (** Turn JSON values into Ocaml values. *) 2 | 3 | module Decode : sig 4 | include Decoders.Decode.S with type value = Yojson.Raw.t 5 | 6 | (** {2 Yojson.Raw-specific decoders}*) 7 | 8 | val stringlit : string decoder 9 | 10 | val intlit : string decoder 11 | 12 | val floatlit : string decoder 13 | end 14 | 15 | module Encode : sig 16 | include Decoders.Encode.S with type value = Yojson.Raw.t 17 | 18 | (** {2 Yojson.Raw-specific encoders}*) 19 | 20 | val stringlit : string encoder 21 | 22 | val intlit : string encoder 23 | 24 | val floatlit : string encoder 25 | end 26 | -------------------------------------------------------------------------------- /src-yojson/safe.ml: -------------------------------------------------------------------------------- 1 | (** {2 Yojson.Safe implementation} *) 2 | 3 | open Decoders 4 | 5 | module Json_decodeable : Decode.Decodeable with type value = Yojson.Safe.t = 6 | struct 7 | type value = Yojson.Safe.t 8 | 9 | let pp fmt json = 10 | Format.fprintf fmt "@[%s@]" (Yojson.Safe.pretty_to_string json) 11 | 12 | 13 | let of_string : string -> (value, string) result = 14 | fun string -> 15 | try Ok (Yojson.Safe.from_string string) with 16 | | Yojson.Json_error msg -> 17 | Error msg 18 | 19 | 20 | let of_file file = 21 | try Ok (Yojson.Safe.from_file file) with e -> Error (Printexc.to_string e) 22 | 23 | 24 | let get_string = function `String value -> Some value | _ -> None 25 | 26 | let get_int = function `Int value -> Some value | _ -> None 27 | 28 | let get_float = function 29 | | `Float value -> 30 | Some value 31 | | `Int value -> 32 | Some (float_of_int value) 33 | | _ -> 34 | None 35 | 36 | 37 | let get_bool = function `Bool value -> Some value | _ -> None 38 | 39 | let get_null = function `Null -> Some () | _ -> None 40 | 41 | let get_list : value -> value list option = function 42 | | `List l -> 43 | Some l 44 | | _ -> 45 | None 46 | 47 | 48 | let get_key_value_pairs : value -> (value * value) list option = function 49 | | `Assoc assoc -> 50 | Some (List.map (fun (key, value) -> (`String key, value)) assoc) 51 | | _ -> 52 | None 53 | 54 | 55 | let to_list values = `List values 56 | end 57 | 58 | module Decode = Decode.Make (Json_decodeable) 59 | 60 | module Json_encodeable = struct 61 | type value = Yojson.Safe.t 62 | 63 | let to_string json = Yojson.Safe.to_string json 64 | 65 | let of_string x = `String x 66 | 67 | let of_int x = `Int x 68 | 69 | let of_float x = `Float x 70 | 71 | let of_bool x = `Bool x 72 | 73 | let null = `Null 74 | 75 | let of_list xs = `List xs 76 | 77 | let of_key_value_pairs xs = 78 | `Assoc 79 | ( xs 80 | |> Util.My_list.filter_map (fun (k, v) -> 81 | match k with `String k -> Some (k, v) | _ -> None ) ) 82 | end 83 | 84 | module Encode = Encode.Make (Json_encodeable) 85 | -------------------------------------------------------------------------------- /src-yojson/safe.mli: -------------------------------------------------------------------------------- 1 | (** Turn JSON values into Ocaml values. *) 2 | 3 | module Decode : Decoders.Decode.S with type value = Yojson.Safe.t 4 | 5 | module Encode : Decoders.Encode.S with type value = Yojson.Safe.t 6 | -------------------------------------------------------------------------------- /src/decode.ml: -------------------------------------------------------------------------------- 1 | (** Functors for creating Decoders. *) 2 | 3 | open Util 4 | 5 | type ('good, 'bad) result = ('good, 'bad) My_result.t = 6 | | Ok of 'good 7 | | Error of 'bad 8 | 9 | module type S = Sig.S 10 | 11 | module type Decodeable = Sig.Decodeable 12 | 13 | module Make (Decodeable : Decodeable) : 14 | Sig.S 15 | with type value = Decodeable.value 16 | and type 'a decoder = (Decodeable.value, 'a) Decoder.t = struct 17 | type value = Decodeable.value 18 | 19 | let pp = Decodeable.pp 20 | 21 | type error = value Error.t 22 | 23 | let pp_error = Error.pp pp 24 | 25 | let string_of_error = Error.to_string pp 26 | 27 | let of_string : string -> (value, error) result = 28 | fun string -> 29 | Decodeable.of_string string 30 | |> My_result.map_err (fun msg -> 31 | Error.tag "Json parse error" (Error.make msg) ) 32 | 33 | 34 | let of_file : string -> (value, error) result = 35 | fun file -> 36 | Decodeable.of_file file 37 | |> My_result.map_err (fun msg -> 38 | Error.tag (Printf.sprintf "While reading %s" file) (Error.make msg) ) 39 | 40 | 41 | type 'a decoder = (value, 'a) Decoder.t 42 | 43 | let succeed x = Decoder.pure x 44 | 45 | let fail = Decoder.fail 46 | 47 | let fail_with = Decoder.fail_with 48 | 49 | let from_result = Decoder.of_result 50 | 51 | let value = Decoder.value 52 | 53 | let map = Decoder.map 54 | 55 | let apply = Decoder.apply 56 | 57 | let and_then = Decoder.bind 58 | 59 | let fix = Decoder.fix 60 | 61 | let maybe = Decoder.maybe 62 | 63 | module Infix = struct 64 | include Decoder.Infix 65 | 66 | let ( <$> ) = map 67 | end 68 | 69 | let nullable (decoder : 'a decoder) : 'a option decoder = 70 | Decoder.of_decode_fun 71 | @@ fun input -> 72 | match Decodeable.get_null input with 73 | | Some () -> 74 | Ok None 75 | | None -> 76 | decoder.dec input 77 | |> My_result.map My_opt.return 78 | |> My_result.map_err (Error.tag "Expected null or") 79 | 80 | 81 | let one_of (decoders : (string * 'a decoder) list) : 'a decoder = 82 | let decoders = 83 | decoders 84 | |> My_list.map (fun (name, d) -> 85 | d 86 | |> Decoder.map_err (fun e -> 87 | Error.tag_group (Printf.sprintf "%S decoder" name) [ e ] ) ) 88 | in 89 | Decoder.one_of decoders 90 | |> Decoder.map_err 91 | (Error.tag "I tried the following decoders but they all failed") 92 | 93 | 94 | let pick decoders = 95 | let decoders = 96 | decoders 97 | |> My_list.map (fun (name, d) -> 98 | d 99 | |> Decoder.map_err (fun e -> 100 | Error.tag_group (Printf.sprintf "%S decoder" name) [ e ] ) ) 101 | in 102 | Decoder.pick decoders 103 | |> Decoder.map_err 104 | (Error.tag "I tried the following decoders but they all failed") 105 | 106 | 107 | let decode_sub = Decoder.decode_sub 108 | 109 | let primitive_decoder (get_value : value -> 'a option) (message : string) : 110 | 'a decoder = 111 | Decoder.of_decode_fun 112 | @@ fun t -> 113 | match get_value t with Some value -> Ok value | _ -> (fail message).dec t 114 | 115 | 116 | let string : string decoder = 117 | Decoder.of_to_opt Decodeable.get_string (fail "Expected a string").dec 118 | 119 | 120 | let int : int decoder = primitive_decoder Decodeable.get_int "Expected an int" 121 | 122 | let float : float decoder = 123 | primitive_decoder Decodeable.get_float "Expected a float" 124 | 125 | 126 | let bool : bool decoder = 127 | primitive_decoder Decodeable.get_bool "Expected a bool" 128 | 129 | 130 | let null : unit decoder = 131 | primitive_decoder Decodeable.get_null "Expected a null" 132 | 133 | 134 | let list : 'a decoder -> 'a list decoder = 135 | fun decoder -> 136 | Decoder.of_decode_fun 137 | @@ fun t -> 138 | match Decodeable.get_list t with 139 | | None -> 140 | (fail "Expected a list").dec t 141 | | Some values -> 142 | values 143 | |> My_list.mapi (fun i x -> 144 | decoder.dec x 145 | |> My_result.map_err (Error.tag (Printf.sprintf "element %i" i)) ) 146 | |> My_result.combine_l 147 | |> My_result.map_err (Error.tag_group "while decoding a list") 148 | 149 | 150 | let list_filter : 'a option decoder -> 'a list decoder = 151 | fun decoder -> 152 | let rec go i = function 153 | | [] -> 154 | Ok [] 155 | | v :: vs -> 156 | My_result.Infix.( 157 | decoder.dec v 158 | |> My_result.map_err (Error.tag (Printf.sprintf "element %i" i)) 159 | >>= (function 160 | | Some x -> 161 | go (i + 1) vs >>= fun xs -> My_result.return (x :: xs) 162 | | None -> 163 | go (i + 1) vs )) 164 | in 165 | Decoder.of_decode_fun 166 | @@ fun t -> 167 | match Decodeable.get_list t with 168 | | None -> 169 | (fail "Expected a list").dec t 170 | | Some values -> 171 | go 0 values |> My_result.map_err (Error.tag "while decoding a list") 172 | 173 | 174 | let list_fold_left : ('a -> 'a decoder) -> 'a -> 'a decoder = 175 | fun decoder_func init -> 176 | Decoder.of_decode_fun 177 | @@ fun t -> 178 | match Decodeable.get_list t with 179 | | None -> 180 | (fail "Expected a list").dec t 181 | | Some values -> 182 | values 183 | |> My_result.Infix.( 184 | My_list.fold_left 185 | (fun (acc, i) el -> 186 | ( ( acc 187 | >>= fun acc -> 188 | (acc |> decoder_func).dec el 189 | |> My_result.map_err 190 | (Error.tag (Printf.sprintf "element %i" i)) ) 191 | , i + 1 ) ) 192 | (Ok init, 0)) 193 | |> fst 194 | |> My_result.map_err (Error.tag "while decoding a list") 195 | 196 | 197 | let array : 'a decoder -> 'a array decoder = 198 | fun decoder -> 199 | Decoder.of_decode_fun 200 | @@ fun t -> 201 | let res = (list decoder).dec t in 202 | match res with 203 | | Ok x -> 204 | Ok (Array.of_list x) 205 | | Error e -> 206 | Error 207 | (Error.map_tag 208 | (function 209 | | "while decoding a list" -> "while decoding an array" | s -> s 210 | ) 211 | e ) 212 | 213 | 214 | let field : string -> 'a decoder -> 'a decoder = 215 | fun key value_decoder -> 216 | Decoder.of_decode_fun 217 | @@ fun t -> 218 | let value = 219 | Decodeable.get_key_value_pairs t 220 | |> My_opt.flat_map 221 | (My_list.find_map (fun (k, v) -> 222 | match Decodeable.get_string k with 223 | | Some s when s = key -> 224 | Some v 225 | | _ -> 226 | None ) ) 227 | in 228 | match value with 229 | | Some value -> 230 | value_decoder.dec value 231 | |> My_result.map_err (Error.tag (Printf.sprintf "in field %S" key)) 232 | | None -> 233 | (fail (Printf.sprintf "Expected an object with an attribute %S" key)) 234 | .dec 235 | t 236 | 237 | 238 | let field_opt : string -> 'a decoder -> 'a option decoder = 239 | fun key value_decoder -> 240 | Decoder.of_decode_fun 241 | @@ fun t -> 242 | let value = 243 | Decodeable.get_key_value_pairs t 244 | |> My_opt.flat_map 245 | (My_list.find_map (fun (k, v) -> 246 | match Decodeable.get_string k with 247 | | Some s when s = key -> 248 | Some v 249 | | _ -> 250 | None ) ) 251 | in 252 | match value with 253 | | Some value -> 254 | value_decoder.dec value 255 | |> My_result.map (fun v -> Some v) 256 | |> My_result.map_err (Error.tag (Printf.sprintf "in field %S" key)) 257 | | None -> 258 | Ok None 259 | 260 | 261 | let field_opt_or : default:'a -> string -> 'a decoder -> 'a decoder = 262 | fun ~default key value_decoder -> 263 | Decoder.of_decode_fun 264 | @@ fun t -> 265 | match (field_opt key value_decoder).dec t with 266 | | Ok (Some x) -> 267 | Ok x 268 | | Ok None -> 269 | Ok default 270 | | Error _ as e -> 271 | e 272 | 273 | 274 | let single_field : (string -> 'a decoder) -> 'a decoder = 275 | fun value_decoder -> 276 | Decoder.of_decode_fun 277 | @@ fun t -> 278 | match Decodeable.get_key_value_pairs t with 279 | | Some [ (key, value) ] -> 280 | ( match Decodeable.get_string key with 281 | | Some key -> 282 | (value_decoder key).dec value 283 | |> My_result.map_err (Error.tag (Printf.sprintf "in field %S" key)) 284 | | None -> 285 | (fail "Expected an object with a string key").dec t ) 286 | | _ -> 287 | (fail "Expected an object with a single attribute").dec t 288 | 289 | 290 | let index : int -> 'a decoder -> 'a decoder = 291 | fun i decoder -> 292 | Decoder.of_decode_fun 293 | @@ fun t -> 294 | match Decodeable.get_list t with 295 | | Some l -> 296 | let item = 297 | try Some (List.nth l i) with 298 | | Failure _ -> 299 | None 300 | | Invalid_argument _ -> 301 | None 302 | in 303 | ( match item with 304 | | None -> 305 | (fail 306 | ("expected a list with at least " ^ string_of_int i ^ " elements") ) 307 | .dec 308 | t 309 | | Some item -> 310 | decoder.dec item ) 311 | | None -> 312 | (fail "Expected a list").dec t 313 | 314 | 315 | let uncons (tail : 'a -> 'b decoder) (head : 'a decoder) : 'b decoder = 316 | Decoder.of_decode_fun 317 | @@ fun value -> 318 | match Decodeable.get_list value with 319 | | Some (x :: rest) -> 320 | My_result.Infix.( 321 | head.dec x 322 | |> My_result.map_err (Error.tag "while consuming a list element") 323 | >>= fun x -> 324 | (tail x).dec (Decodeable.to_list rest) 325 | |> My_result.map_err (Error.tag "after consuming a list element")) 326 | | Some [] -> 327 | (fail "Expected a non-empty list").dec value 328 | | None -> 329 | (fail "Expected a list").dec value 330 | 331 | 332 | let ( >>=:: ) fst rest = uncons rest fst 333 | 334 | let empty_list = 335 | Decoder.of_decode_fun 336 | @@ fun value -> 337 | match Decodeable.get_list value with 338 | | Some [] -> 339 | Ok () 340 | | Some _ -> 341 | (fail "Expected an empty list").dec value 342 | | None -> 343 | (fail "Expected a list").dec value 344 | 345 | 346 | let tuple2 d0 d1 = 347 | d0 >>=:: fun arg0 -> d1 >>=:: fun arg1 -> succeed (arg0, arg1) 348 | 349 | 350 | let tuple3 d0 d1 d2 = 351 | d0 352 | >>=:: fun arg0 -> 353 | d1 >>=:: fun arg1 -> d2 >>=:: fun arg2 -> succeed (arg0, arg1, arg2) 354 | 355 | 356 | let tuple4 d0 d1 d2 d3 = 357 | d0 358 | >>=:: fun arg0 -> 359 | d1 360 | >>=:: fun arg1 -> 361 | d2 >>=:: fun arg2 -> d3 >>=:: fun arg3 -> succeed (arg0, arg1, arg2, arg3) 362 | 363 | 364 | let rec at : string list -> 'a decoder -> 'a decoder = 365 | fun path decoder -> 366 | match path with 367 | | [ key ] -> 368 | field key decoder 369 | | key :: rest -> 370 | field key (at rest decoder) 371 | | [] -> 372 | fail "Must provide at least one key to 'at'" 373 | 374 | 375 | let keys' : 'k decoder -> 'k list decoder = 376 | fun key_decoder -> 377 | Decoder.of_decode_fun 378 | @@ fun value -> 379 | match Decodeable.get_key_value_pairs value with 380 | | Some assoc -> 381 | assoc 382 | |> List.map (fun (key, _) -> key_decoder.dec key) 383 | |> My_result.combine_l 384 | |> My_result.map_err 385 | (Error.tag_group "Failed while decoding the keys of an object") 386 | | None -> 387 | (fail "Expected an object").dec value 388 | 389 | 390 | let keys = keys' string 391 | 392 | let key_value_pairs' : 'k decoder -> 'v decoder -> ('k * 'v) list decoder = 393 | fun key_decoder value_decoder -> 394 | Decoder.of_decode_fun 395 | @@ fun value -> 396 | match Decodeable.get_key_value_pairs value with 397 | | Some assoc -> 398 | assoc 399 | |> List.map 400 | My_result.Infix.( 401 | fun (key_val, value_val) -> 402 | key_decoder.dec key_val 403 | >>= fun key -> 404 | value_decoder.dec value_val >|= fun value -> (key, value)) 405 | |> My_result.combine_l 406 | |> My_result.map_err 407 | (Error.tag_group "Failed while decoding key-value pairs") 408 | | None -> 409 | (fail "Expected an object").dec value 410 | 411 | 412 | let key_value_pairs value_decoder = key_value_pairs' string value_decoder 413 | 414 | let key_value_pairs_seq' : 'k decoder -> ('k -> 'v decoder) -> 'v list decoder 415 | = 416 | fun key_decoder value_decoder -> 417 | Decoder.of_decode_fun 418 | @@ fun value -> 419 | match Decodeable.get_key_value_pairs value with 420 | | Some assoc -> 421 | assoc 422 | |> List.map 423 | My_result.Infix.( 424 | fun (key_val, value_val) -> 425 | key_decoder.dec key_val 426 | >>= fun key -> (value_decoder key).dec value_val) 427 | |> My_result.combine_l 428 | |> My_result.map_err 429 | (Error.tag_group "Failed while decoding key-value pairs") 430 | | None -> 431 | (fail "Expected an object").dec value 432 | 433 | 434 | let key_value_pairs_seq value_decoder = 435 | key_value_pairs_seq' string value_decoder 436 | 437 | 438 | let[@inline] decode_value (decoder : 'a decoder) (input : value) : 439 | ('a, error) result = 440 | decoder.dec input 441 | 442 | 443 | let of_of_string ~msg of_string = 444 | let open Infix in 445 | string 446 | >|= of_string 447 | >>= function Some x -> succeed x | None -> fail ("Expected " ^ msg) 448 | 449 | 450 | let decode_string : 'a decoder -> string -> ('a, error) result = 451 | fun decoder string -> 452 | My_result.Infix.(of_string string >>= decode_value decoder) 453 | 454 | 455 | let decode_file : 'a decoder -> string -> ('a, error) result = 456 | fun decoder file -> My_result.Infix.(of_file file >>= decode_value decoder) 457 | 458 | 459 | module Pipeline = struct 460 | let decode = succeed 461 | 462 | let custom : 'a decoder -> ('a -> 'b) decoder -> 'b decoder = 463 | fun customDecoder next -> apply next customDecoder 464 | 465 | 466 | let required : string -> 'a decoder -> ('a -> 'b) decoder -> 'b decoder = 467 | fun key decoder next -> custom (field key decoder) next 468 | 469 | 470 | let required_at : 471 | string list -> 'a decoder -> ('a -> 'b) decoder -> 'b decoder = 472 | fun path decoder next -> custom (at path decoder) next 473 | 474 | 475 | let optional_decoder : value decoder -> 'a decoder -> 'a -> 'a decoder = 476 | fun path_decoder val_decoder default -> 477 | let null_or decoder = 478 | one_of 479 | [ ("non-null", decoder); ("null", null |> map (fun () -> default)) ] 480 | in 481 | let handle_result : value -> 'a decoder = 482 | fun input -> 483 | match decode_value path_decoder input with 484 | | Ok rawValue -> 485 | (* The field was present. *) 486 | decode_value (null_or val_decoder) rawValue |> from_result 487 | | Error _ -> 488 | (* The field was not present. *) 489 | succeed default 490 | in 491 | value |> and_then handle_result 492 | 493 | 494 | let optional : 495 | string -> 'a decoder -> 'a -> ('a -> 'b) decoder -> 'b decoder = 496 | fun key val_decoder default next -> 497 | custom (optional_decoder (field key value) val_decoder default) next 498 | 499 | 500 | let optional_at : 501 | string list -> 'a decoder -> 'a -> ('a -> 'b) decoder -> 'b decoder = 502 | fun path val_decoder default next -> 503 | custom (optional_decoder (at path value) val_decoder default) next 504 | end 505 | 506 | include Infix 507 | end 508 | -------------------------------------------------------------------------------- /src/decode.mli: -------------------------------------------------------------------------------- 1 | module type S = Sig.S 2 | 3 | (** {2 Creating a Decoder implementation} 4 | 5 | The following is useful only if you are creating a new Decoder implementation. 6 | *) 7 | 8 | (** Signature of things that can be decoded. *) 9 | module type Decodeable = Sig.Decodeable 10 | 11 | (** Derive decoders for a [Decodeable.value]. *) 12 | module Make (M : Decodeable) : 13 | Sig.S with type value = M.value and type 'a decoder = (M.value, 'a) Decoder.t 14 | -------------------------------------------------------------------------------- /src/decoder.ml: -------------------------------------------------------------------------------- 1 | type ('i, 'o) t = { dec : 'i -> ('o, 'i Error.t) result } [@@unboxed] 2 | 3 | let pure x : ('i, 'o) t = { dec = (fun _i -> Ok x) } 4 | 5 | let fail msg : ('i, 'o) t = 6 | { dec = (fun i -> Error (Error.make ~context:i msg)) } 7 | 8 | 9 | let fail_with e : ('i, 'o) t = { dec = (fun _i -> Error e) } 10 | 11 | let of_result res = { dec = (fun _i -> res) } 12 | 13 | let bind (f : 'a -> ('i, 'b) t) (x : ('i, 'a) t) : ('i, 'b) t = 14 | { dec = 15 | (fun i -> match x.dec i with Ok y -> (f y).dec i | Error e -> Error e) 16 | } 17 | 18 | 19 | let map (f : 'a -> 'b) (x : ('i, 'a) t) : ('i, 'b) t = 20 | { dec = (fun i -> match x.dec i with Ok y -> Ok (f y) | Error e -> Error e) 21 | } 22 | 23 | 24 | let map_err (f : 'i Error.t -> 'i Error.t) (x : ('i, 'o) t) : ('i, 'o) t = 25 | { dec = (fun i -> match x.dec i with Ok y -> Ok y | Error e -> Error (f e)) 26 | } 27 | 28 | 29 | let apply (f : ('i, 'a -> 'b) t) (x : ('i, 'a) t) : ('i, 'b) t = 30 | { dec = 31 | (fun i -> 32 | match f.dec i with 33 | | Ok f -> 34 | (match x.dec i with Ok x -> Ok (f x) | Error e -> Error e) 35 | | Error e -> 36 | Error e ) 37 | } 38 | 39 | 40 | module Infix = struct 41 | let[@inline] ( >>= ) x f = bind f x 42 | 43 | let[@inline] ( >|= ) x f = map f x 44 | 45 | let[@inline] ( <*> ) f x = apply f x 46 | 47 | include Shims_let_ops_.Make (struct 48 | type nonrec ('i, 'o) t = ('i, 'o) t 49 | 50 | let ( >>= ) = ( >>= ) 51 | 52 | let ( >|= ) = ( >|= ) 53 | 54 | let[@inline] monoid_product a b = map (fun x y -> (x, y)) a <*> b 55 | end) 56 | end 57 | 58 | let fix (f : ('i, 'a) t -> ('i, 'a) t) : ('i, 'a) t = 59 | let rec p () = f r 60 | and r = { dec = (fun value -> (p ()).dec value) } in 61 | r 62 | 63 | 64 | let value : ('i, 'i) t = { dec = (fun i -> Ok i) } 65 | 66 | let maybe (x : ('i, 'a) t) : ('i, 'a option) t = 67 | { dec = 68 | (fun i -> match x.dec i with Ok x -> Ok (Some x) | Error _ -> Ok None) 69 | } 70 | 71 | 72 | let one_of (xs : ('i, 'o) t list) : ('i, 'o) t = 73 | { dec = 74 | (fun i -> 75 | let rec aux errors = function 76 | | x :: xs -> 77 | (match x.dec i with Ok o -> Ok o | Error e -> aux (e :: errors) xs) 78 | | [] -> 79 | Error (Error.group (List.rev errors)) 80 | in 81 | aux [] xs ) 82 | } 83 | 84 | 85 | let pick : ('i, ('i, 'o) t) t list -> ('i, 'o) t = 86 | fun decoders -> 87 | { dec = 88 | (fun input -> 89 | let rec go errors = function 90 | | decoder :: rest -> 91 | ( match decoder.dec input with 92 | | Ok dec -> 93 | (* use [dec] and drop errors *) 94 | (match dec.dec input with Ok _ as x -> x | Error e -> Error e) 95 | | Error error -> 96 | go (error :: errors) rest ) 97 | | [] -> 98 | Error (Error.group errors) 99 | in 100 | go [] decoders ) 101 | } 102 | 103 | 104 | let of_to_opt (to_opt : 'i -> 'o option) fail : ('i, 'o) t = 105 | { dec = (fun i -> match to_opt i with Some o -> Ok o | None -> fail i) } 106 | 107 | 108 | let decode_sub v dec = of_result (dec.dec v) 109 | 110 | let[@inline] of_decode_fun dec = { dec } 111 | -------------------------------------------------------------------------------- /src/decoder.mli: -------------------------------------------------------------------------------- 1 | (** An [('i, 'o) t] is a decoder that 2 | 3 | - consumes a value of type ['i] 4 | - produces a value of type ['o] or an error of type ['i Error.t] 5 | *) 6 | type ('i, 'o) t = { dec : 'i -> ('o, 'i Error.t) result } [@@unboxed] 7 | 8 | val pure : 'o -> ('i, 'o) t 9 | (** [pure x] always succeeds with [x] *) 10 | 11 | val fail : string -> ('i, 'o) t 12 | (** [fail msg] always fails with [msg], capturing the error context from 'i *) 13 | 14 | val fail_with : 'i Error.t -> ('i, 'o) t 15 | (** [fail_with e] always fails with [e] *) 16 | 17 | val of_result : ('o, 'i Error.t) Util.My_result.t -> ('i, 'o) t 18 | 19 | val bind : ('a -> ('i, 'b) t) -> ('i, 'a) t -> ('i, 'b) t 20 | 21 | val map : ('a -> 'b) -> ('i, 'a) t -> ('i, 'b) t 22 | 23 | val map_err : ('i Error.t -> 'i Error.t) -> ('i, 'o) t -> ('i, 'o) t 24 | 25 | val apply : ('i, 'a -> 'b) t -> ('i, 'a) t -> ('i, 'b) t 26 | 27 | module Infix : sig 28 | val ( >>= ) : ('i, 'a) t -> ('a -> ('i, 'b) t) -> ('i, 'b) t 29 | 30 | val ( >|= ) : ('i, 'a) t -> ('a -> 'b) -> ('i, 'b) t 31 | 32 | val ( <*> ) : ('i, 'a -> 'b) t -> ('i, 'a) t -> ('i, 'b) t 33 | 34 | include Shims_let_ops_.S with type ('i, 'o) t_let := ('i, 'o) t 35 | end 36 | 37 | val fix : (('i, 'a) t -> ('i, 'a) t) -> ('i, 'a) t 38 | 39 | val value : ('i, 'i) t 40 | 41 | val maybe : ('i, 'a) t -> ('i, 'a option) t 42 | 43 | val one_of : ('i, 'o) t list -> ('i, 'o) t 44 | 45 | val pick : ('i, ('i, 'o) t) t list -> ('i, 'o) t 46 | 47 | val of_to_opt : 48 | ('i -> 'o option) -> ('i -> ('o, 'i Error.t) result) -> ('i, 'o) t 49 | 50 | val decode_sub : 'a -> ('a, 'b) t -> ('a, 'b) t 51 | 52 | val of_decode_fun : ('i -> ('o, 'i Error.t) result) -> ('i, 'o) t 53 | -------------------------------------------------------------------------------- /src/decoders.ml: -------------------------------------------------------------------------------- 1 | module Decode = Decode 2 | module Decoder = Decoder 3 | module Encode = Encode 4 | module Error = Error 5 | module Util = Util 6 | module Xml = Xml 7 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name decoders) 3 | (flags :standard -warn-error -a+8) 4 | (public_name decoders)) 5 | 6 | (rule 7 | (targets shims_let_ops_.ml) 8 | (action 9 | (with-stdout-to 10 | %{targets} 11 | (run ./gen/mkshims.exe)))) 12 | -------------------------------------------------------------------------------- /src/encode.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | 3 | module type S = sig 4 | type value 5 | 6 | type 'a encoder = 'a -> value 7 | 8 | val string : string encoder 9 | 10 | val int : int encoder 11 | 12 | val float : float encoder 13 | 14 | val bool : bool encoder 15 | 16 | val null : value 17 | 18 | val nullable : 'a encoder -> 'a option encoder 19 | 20 | val option : 'a encoder -> 'a option encoder 21 | [@@ocaml.deprecated "Use nullable instead."] 22 | 23 | val list : 'a encoder -> 'a list encoder 24 | 25 | val array : 'a encoder -> 'a array encoder 26 | 27 | val key_value_pairs' : 'k encoder -> 'v encoder -> ('k * 'v) list encoder 28 | 29 | val key_value_pairs : 'v encoder -> (string * 'v) list encoder 30 | 31 | val obj : (string * value) list encoder 32 | 33 | val obj' : (value * value) list encoder 34 | 35 | val value : value encoder 36 | 37 | val of_to_string : ('a -> string) -> 'a encoder 38 | 39 | val encode_value : 'a encoder -> 'a -> value 40 | 41 | val encode_string : 'a encoder -> 'a -> string 42 | end 43 | 44 | module type Encodeable = sig 45 | type value 46 | 47 | val to_string : value -> string 48 | 49 | val of_string : string -> value 50 | 51 | val of_int : int -> value 52 | 53 | val of_float : float -> value 54 | 55 | val of_bool : bool -> value 56 | 57 | val null : value 58 | 59 | val of_list : value list -> value 60 | 61 | val of_key_value_pairs : (value * value) list -> value 62 | end 63 | 64 | module Make (E : Encodeable) : S with type value = E.value = struct 65 | type value = E.value 66 | 67 | type 'a encoder = 'a -> value 68 | 69 | let string x = E.of_string x 70 | 71 | let int x = E.of_int x 72 | 73 | let float x = E.of_float x 74 | 75 | let bool x = E.of_bool x 76 | 77 | let null = E.null 78 | 79 | let nullable encoder = function None -> E.null | Some x -> encoder x 80 | 81 | let option = nullable 82 | 83 | let list encoder xs = xs |> My_list.map (fun x -> encoder x) |> E.of_list 84 | 85 | let array encoder xs = 86 | xs |> Array.to_list |> My_list.map (fun x -> encoder x) |> E.of_list 87 | 88 | 89 | let obj' xs = E.of_key_value_pairs xs 90 | 91 | let key_value_pairs' : 'k encoder -> 'v encoder -> ('k * 'v) list encoder = 92 | fun key_encoder value_encoder xs -> 93 | xs |> List.map (fun (k, v) -> (key_encoder k, value_encoder v)) |> obj' 94 | 95 | 96 | let obj xs = key_value_pairs' string (fun x -> x) xs 97 | 98 | let key_value_pairs value_encoder xs = 99 | key_value_pairs' string value_encoder xs 100 | 101 | 102 | let value x = x 103 | 104 | let of_to_string to_string x = string (to_string x) 105 | 106 | let encode_value encoder x = encoder x 107 | 108 | let encode_string encoder x = encoder x |> E.to_string 109 | end 110 | -------------------------------------------------------------------------------- /src/encode.mli: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | type value 3 | 4 | type 'a encoder = 'a -> value 5 | 6 | val string : string encoder 7 | 8 | val int : int encoder 9 | 10 | val float : float encoder 11 | 12 | val bool : bool encoder 13 | 14 | val null : value 15 | 16 | val nullable : 'a encoder -> 'a option encoder 17 | 18 | val option : 'a encoder -> 'a option encoder 19 | [@@ocaml.deprecated "Use nullable instead."] 20 | 21 | val list : 'a encoder -> 'a list encoder 22 | 23 | val array : 'a encoder -> 'a array encoder 24 | 25 | val key_value_pairs' : 'k encoder -> 'v encoder -> ('k * 'v) list encoder 26 | 27 | val key_value_pairs : 'v encoder -> (string * 'v) list encoder 28 | 29 | val obj : (string * value) list encoder 30 | 31 | val obj' : (value * value) list encoder 32 | 33 | val value : value encoder 34 | 35 | val of_to_string : ('a -> string) -> 'a encoder 36 | 37 | val encode_value : 'a encoder -> 'a -> value 38 | 39 | val encode_string : 'a encoder -> 'a -> string 40 | end 41 | 42 | module type Encodeable = sig 43 | type value 44 | 45 | val to_string : value -> string 46 | 47 | val of_string : string -> value 48 | 49 | val of_int : int -> value 50 | 51 | val of_float : float -> value 52 | 53 | val of_bool : bool -> value 54 | 55 | val null : value 56 | 57 | val of_list : value list -> value 58 | 59 | val of_key_value_pairs : (value * value) list -> value 60 | end 61 | 62 | module Make (E : Encodeable) : S with type value = E.value 63 | -------------------------------------------------------------------------------- /src/error.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | 3 | type 'a t = 4 | | E of 5 | { msg : string 6 | ; context : 'a option 7 | } 8 | | Tag of string * 'a t 9 | | Group of 'a t list 10 | 11 | let make ?context msg = E { msg; context } 12 | 13 | let tag msg e = Tag (msg, e) 14 | 15 | let group es = Group es 16 | 17 | let tag_group msg es = tag msg (group es) 18 | 19 | let rec pp pp_context fmt = 20 | let open Format in 21 | function 22 | | E { msg; context = None } -> 23 | fprintf fmt "@[%s@]" msg 24 | | E { msg; context = Some context } -> 25 | fprintf fmt "@[%s, but got@ @[%a@]@]" msg pp_context context 26 | | Tag (msg, e) -> 27 | fprintf fmt "@[<2>%s:@ %a@]" msg (pp pp_context) e 28 | | Group es -> 29 | let max_errors = 5 in 30 | let es_trunc = My_list.take max_errors es in 31 | let not_shown = List.length es - max_errors in 32 | fprintf 33 | fmt 34 | "@[%a %s@]" 35 | (Format.pp_print_list ~pp_sep:Format.pp_print_space (pp pp_context)) 36 | es_trunc 37 | ( if not_shown > 0 38 | then Printf.sprintf "(...%d errors not shown...)" not_shown 39 | else "" ) 40 | 41 | 42 | let to_string pp_context t = Format.asprintf "@[<2>%a@?@]" (pp pp_context) t 43 | 44 | let map_tag f = function Tag (s, e) -> Tag (f s, e) | e -> e 45 | 46 | let rec map_context f = function 47 | | E { msg; context } -> 48 | E { msg; context = My_opt.map f context } 49 | | Tag (s, e) -> 50 | Tag (s, map_context f e) 51 | | Group es -> 52 | Group (My_list.map (map_context f) es) 53 | -------------------------------------------------------------------------------- /src/error.mli: -------------------------------------------------------------------------------- 1 | (** An ['a t] is an error with a contextual value of type ['a] *) 2 | type 'a t 3 | 4 | val make : ?context:'a -> string -> 'a t 5 | 6 | val tag : string -> 'a t -> 'a t 7 | 8 | val group : 'a t list -> 'a t 9 | 10 | val tag_group : string -> 'a t list -> 'a t 11 | 12 | val pp : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit 13 | 14 | val to_string : (Format.formatter -> 'a -> unit) -> 'a t -> string 15 | 16 | val map_tag : (string -> string) -> 'a t -> 'a t 17 | 18 | val map_context : ('a -> 'b) -> 'a t -> 'b t 19 | -------------------------------------------------------------------------------- /src/gen/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name mkshims) 3 | (modes native)) 4 | -------------------------------------------------------------------------------- /src/gen/mkshims.ml: -------------------------------------------------------------------------------- 1 | (* Note: also copied to src-bs/shims_let_ops_.ml *) 2 | 3 | let shims_all = 4 | {| 5 | module type I = sig 6 | type ('i, 'a) t 7 | val (>|=) : ('i, 'a) t -> ('a -> 'b) -> ('i, 'b) t 8 | val monoid_product : ('i, 'a) t -> ('i, 'b) t -> ('i, ('a * 'b)) t 9 | val (>>=) : ('i, 'a) t -> ('a -> ('i, 'b) t) -> ('i, 'b) t 10 | end 11 | |} 12 | 13 | 14 | let shims_let_op_pre_408 = 15 | {| 16 | module type S = sig type ('i, 'o) t_let end 17 | module Make(X : I) : S with type ('i, 'o) t_let = ('i, 'o) X.t = 18 | struct 19 | type ('i, 'o) t_let = ('i, 'o) X.t 20 | end 21 | |} 22 | 23 | 24 | let shims_let_op_post_408 = 25 | {| 26 | module type S = sig 27 | type ('i, 'o) t_let 28 | val ( let+ ) : ('i, 'a) t_let -> ('a -> 'b) -> ('i, 'b) t_let 29 | val ( and+ ) : ('i, 'a) t_let -> ('i, 'b) t_let -> ('i, 'a * 'b) t_let 30 | val ( let* ) : ('i, 'a) t_let -> ('a -> ('i, 'b) t_let) -> ('i, 'b) t_let 31 | val ( and* ) : ('i, 'a) t_let -> ('i, 'b) t_let -> ('i, 'a * 'b) t_let 32 | end 33 | 34 | module Make(X : I) : S with type ('i, 'o) t_let = ('i, 'o) X.t = 35 | struct 36 | type ('i, 'o) t_let = ('i, 'o) X.t 37 | let (let+) = X.(>|=) 38 | let (and+) = X.monoid_product 39 | let (let*) = X.(>>=) 40 | let (and*) = X.monoid_product 41 | end[@@inline] 42 | |} 43 | 44 | 45 | let () = 46 | let version = Sys.ocaml_version in 47 | let major, minor = Scanf.sscanf version "%u.%u" (fun maj min -> (maj, min)) in 48 | print_endline shims_all ; 49 | print_endline 50 | ( if (major, minor) >= (4, 8) 51 | then shims_let_op_post_408 52 | else shims_let_op_pre_408 ) ; 53 | () 54 | -------------------------------------------------------------------------------- /src/sig.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | 3 | type ('good, 'bad) result = ('good, 'bad) My_result.t = 4 | | Ok of 'good 5 | | Error of 'bad 6 | 7 | (** User-facing Decoder interface. *) 8 | module type S = sig 9 | (** The type of values to be decoded (e.g. JSON or Yaml). *) 10 | type value 11 | 12 | type error = value Error.t 13 | 14 | val pp_error : Format.formatter -> error -> unit 15 | 16 | val string_of_error : error -> string 17 | 18 | val of_string : string -> (value, error) result 19 | 20 | val of_file : string -> (value, error) result 21 | 22 | (** The type of decoders. 23 | 24 | Use the functions below to construct decoders for your data types. 25 | 26 | To run a decoder, pass it to {!val:decode_value}. 27 | *) 28 | type 'a decoder = (value, 'a) Decoder.t 29 | 30 | (** {2 Primitives} *) 31 | 32 | val string : string decoder 33 | (** Decode a [string]. *) 34 | 35 | val int : int decoder 36 | (** Decode an [int]. *) 37 | 38 | val float : float decoder 39 | (** Decode a [float]. *) 40 | 41 | val bool : bool decoder 42 | (** Decode a [bool]. *) 43 | 44 | val null : unit decoder 45 | (** Decode a [null]. *) 46 | 47 | val value : value decoder 48 | (** Decode a literal [value]. *) 49 | 50 | (** {2 Lists} *) 51 | 52 | val list : 'a decoder -> 'a list decoder 53 | (** Decode a collection into an OCaml list. *) 54 | 55 | val list_filter : 'a option decoder -> 'a list decoder 56 | (** Decode a collection into an OCaml list, skipping elements for which the 57 | decoder returns None. 58 | *) 59 | 60 | val list_fold_left : ('a -> 'a decoder) -> 'a -> 'a decoder 61 | (** Decode a collection with an accumulator. 62 | 63 | If we consider that an ['a decoder] is basically a type alias for 64 | [json -> ('a, error) result], the signature of this function is comparable 65 | to that of [List.fold_left]: 66 | 67 | {[ 68 | val List.fold_left : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a 69 | val list_fold_left : ('a -> json -> ('a, error) result) -> 'a -> json -> ('a, error) result 70 | val list_fold_left : ('a -> 'a decoder) -> 'a -> 'a decoder 71 | ]} 72 | *) 73 | 74 | val array : 'a decoder -> 'a array decoder 75 | (** Decode a collection into an OCaml array. *) 76 | 77 | val index : int -> 'a decoder -> 'a decoder 78 | (** Decode a collection, requiring a particular index. *) 79 | 80 | val uncons : ('a -> 'b decoder) -> 'a decoder -> 'b decoder 81 | (** [fst |> uncons rest] decodes the first element of a list using [fst], then 82 | decodes the remainder of the list using [rest]. 83 | 84 | For example, to decode this s-expression: 85 | 86 | {[ 87 | (library 88 | (name decoders)) 89 | ]} 90 | 91 | we can use this decoder: 92 | 93 | {[ 94 | string |> uncons (function 95 | | "library" -> field "name" string 96 | | _ -> fail "Expected a library stanza") 97 | ]} 98 | 99 | As another example, say you have a JSON array that starts with a string, 100 | then a bool, then a list of integers: 101 | 102 | {[ 103 | ["hello", true, 1, 2, 3, 4] 104 | ]} 105 | 106 | We could decode it like this: 107 | 108 | {[ 109 | let (>>=::) fst rest = uncons rest fst 110 | 111 | let decoder : (string * bool * int list) decoder = 112 | string >>=:: fun the_string -> 113 | bool >>=:: fun the_bool -> 114 | list int >>= fun the_ints -> 115 | succeed (the_string, the_bool, the_ints) 116 | ]} 117 | 118 | (If you squint, the uncons operator [>>=::] kind of looks like the cons 119 | operator [::].) 120 | *) 121 | 122 | val empty_list : unit decoder 123 | 124 | val tuple2 : 'a decoder -> 'b decoder -> ('a * 'b) decoder 125 | (** Decode a collection into an OCaml 2-tuple. 126 | 127 | For example, to decode this json: 128 | 129 | {[ 130 | [true, "string"] 131 | ]} 132 | 133 | we can use this decoder: 134 | 135 | {[ 136 | tuple2 bool string 137 | ]} 138 | *) 139 | 140 | val tuple3 : 'a decoder -> 'b decoder -> 'c decoder -> ('a * 'b * 'c) decoder 141 | (** Decode a collection into an OCaml 3-tuple. *) 142 | 143 | val tuple4 : 144 | 'a decoder 145 | -> 'b decoder 146 | -> 'c decoder 147 | -> 'd decoder 148 | -> ('a * 'b * 'c * 'd) decoder 149 | (** Decode a collection into an OCaml 4-tuple. *) 150 | 151 | (** {1 Object primitives} *) 152 | 153 | val field : string -> 'a decoder -> 'a decoder 154 | (** Decode an object, requiring a particular field. *) 155 | 156 | val field_opt : string -> 'a decoder -> 'a option decoder 157 | (** Decode an object, where a particular field may or may not be present. 158 | 159 | For example, [(field_opt "hello" int)]: 160 | 161 | - when run on [{"hello": 123}], will succeed with [Some 123] 162 | - when run on [{"hello": null}], will fail 163 | - when run on [{"world": 123}], will succeed with [None] 164 | - when run on [["a", "list", "of", "strings"]], will fail 165 | *) 166 | 167 | val field_opt_or : default:'a -> string -> 'a decoder -> 'a decoder 168 | (** Similar to {!field_opt} but with a default value. 169 | @since 0.7 *) 170 | 171 | val single_field : (string -> 'a decoder) -> 'a decoder 172 | (** Decode an object, requiring exactly one field. *) 173 | 174 | val at : string list -> 'a decoder -> 'a decoder 175 | (** Decode a nested object, requiring certain fields. *) 176 | 177 | (** {2 Inconsistent structure} *) 178 | 179 | val maybe : 'a decoder -> 'a option decoder 180 | (** [maybe d] is a decoder that always succeeds. If [d] succeeds with [x], 181 | then [maybe d] succeeds with [Some x], otherwise if [d] fails, then [maybe d] 182 | succeeds with [None]. 183 | 184 | For example, [maybe (field "hello" int)]: 185 | 186 | - when run on [{"hello": 123}], will succeed with [Some 123] 187 | - when run on [{"hello": null}], will succeed with [None] 188 | - when run on [{"world": 123}], will succeed with [None] 189 | - when run on [["a", "list", "of", "strings"]], will succeed with [None] 190 | 191 | *) 192 | 193 | val nullable : 'a decoder -> 'a option decoder 194 | (** [nullable d] will succeed with [None] if the JSON value is [null]. If the 195 | JSON value is non-[null], it wraps the result of running [x] in a [Some]. 196 | 197 | For example, [field "hello" (nullable int)]: 198 | 199 | - when run on [{"hello": 123}], will succeed with [Some 123] 200 | - when run on [{"hello": null}], will succeed with [None] 201 | - when run on [{"world": 123}], will fail 202 | - when run on [["a", "list", "of", "strings"]], will fail 203 | 204 | *) 205 | 206 | val one_of : (string * 'a decoder) list -> 'a decoder 207 | (** Try a sequence of different decoders. *) 208 | 209 | val pick : (string * 'a decoder decoder) list -> 'a decoder 210 | (** [pick choices] picks a single choice, like {!one_of}. 211 | However, each element of [choices] can look at the value, decide if 212 | it applies (e.g. based on the value of a single field, like a "kind" 213 | or "type" field), and if it does, returns a decoder for the rest of 214 | the value. 215 | 216 | If a choice is made, even if the returned sub-decoder fails, the 217 | error message will totally ignore the rest of the choices and only be 218 | about the choice that was initially made. 219 | 220 | @since 0.7 *) 221 | 222 | val decode_sub : value -> 'a decoder -> 'a decoder 223 | (** [decode_sub value sub_dec] uses [sub_dec] to decode [value]. 224 | This is useful when one has a value on hand. 225 | @since 0.7 *) 226 | 227 | (** {2 Mapping} *) 228 | 229 | val map : ('a -> 'b) -> 'a decoder -> 'b decoder 230 | (** Map over the result of a decoder. *) 231 | 232 | val apply : ('a -> 'b) decoder -> 'a decoder -> 'b decoder 233 | (** Try two decoders and then combine the result. We can use this to decode 234 | objects with many fields (but it's preferable to use [Infix.(>>=)] - see the README). 235 | *) 236 | 237 | (** {2 Working with object keys} *) 238 | 239 | val keys : string list decoder 240 | (** Decode all of the keys of an object to a list of strings. *) 241 | 242 | val key_value_pairs : 'v decoder -> (string * 'v) list decoder 243 | (** Decode an object into a list of key-value pairs. *) 244 | 245 | val key_value_pairs_seq : (string -> 'v decoder) -> 'v list decoder 246 | (** Decode an object into a list of values, where the value 247 | decoder depends on the key. *) 248 | 249 | val keys' : 'k decoder -> 'k list decoder 250 | (** [keys'] is for when your keys might not be strings - probably only likely for Yaml. *) 251 | 252 | val key_value_pairs' : 'k decoder -> 'v decoder -> ('k * 'v) list decoder 253 | 254 | val key_value_pairs_seq' : 'k decoder -> ('k -> 'v decoder) -> 'v list decoder 255 | 256 | (** {2 Fancy decoding} *) 257 | 258 | val succeed : 'a -> 'a decoder 259 | (** A decoder that always succeeds with the argument, ignoring the input. *) 260 | 261 | val fail : string -> 'a decoder 262 | (** A decoder that always fails with the given message, ignoring the input. *) 263 | 264 | val fail_with : error -> 'a decoder 265 | 266 | val from_result : ('a, error) result -> 'a decoder 267 | 268 | val and_then : ('a -> 'b decoder) -> 'a decoder -> 'b decoder 269 | (** Create decoders that depend on previous results. *) 270 | 271 | val fix : ('a decoder -> 'a decoder) -> 'a decoder 272 | (** Recursive decoders. 273 | 274 | [let my_decoder = fix (fun my_decoder -> ...)] allows you to define 275 | [my_decoder] in terms of itself. 276 | *) 277 | 278 | val of_of_string : msg:string -> (string -> 'a option) -> 'a decoder 279 | (** Create a decoder from a function [of_string : string -> 'a option] *) 280 | 281 | module Infix : sig 282 | include module type of Decoder.Infix 283 | 284 | val ( <$> ) : ('a -> 'b) -> 'a decoder -> 'b decoder 285 | end 286 | 287 | include module type of Infix 288 | 289 | (** {2 Running decoders} *) 290 | 291 | val decode_value : 'a decoder -> value -> ('a, error) result 292 | (** Run a decoder on some input. *) 293 | 294 | val decode_string : 'a decoder -> string -> ('a, error) result 295 | (** Run a decoder on a string. *) 296 | 297 | val decode_file : 'a decoder -> string -> ('a, error) result 298 | (** Run a decoder on a file. *) 299 | 300 | (** {2 Pipeline Decoders} *) 301 | module Pipeline : sig 302 | (** 303 | Pipeline decoders present an alternative to the [mapN] style. They read 304 | more naturally, but can lead to harder-to-understand type errors. 305 | {[ 306 | let person_decoder : person decoder = 307 | decode as_person 308 | |> required "name" string 309 | |> required "age" int 310 | ]} 311 | *) 312 | 313 | val decode : 'a -> 'a decoder 314 | 315 | val required : string -> 'a decoder -> ('a -> 'b) decoder -> 'b decoder 316 | 317 | val required_at : 318 | string list -> 'a decoder -> ('a -> 'b) decoder -> 'b decoder 319 | 320 | val optional : 321 | string -> 'a decoder -> 'a -> ('a -> 'b) decoder -> 'b decoder 322 | 323 | val optional_at : 324 | string list -> 'a decoder -> 'a -> ('a -> 'b) decoder -> 'b decoder 325 | 326 | val custom : 'a decoder -> ('a -> 'b) decoder -> 'b decoder 327 | end 328 | end 329 | 330 | (** Signature of things that can be decoded. *) 331 | module type Decodeable = sig 332 | type value 333 | 334 | val pp : Format.formatter -> value -> unit 335 | 336 | val of_string : string -> (value, string) result 337 | 338 | val of_file : string -> (value, string) result 339 | 340 | val get_string : value -> string option 341 | 342 | val get_int : value -> int option 343 | 344 | val get_float : value -> float option 345 | 346 | val get_bool : value -> bool option 347 | 348 | val get_null : value -> unit option 349 | 350 | val get_list : value -> value list option 351 | 352 | val get_key_value_pairs : value -> (value * value) list option 353 | 354 | val to_list : value list -> value 355 | end 356 | -------------------------------------------------------------------------------- /src/util.ml: -------------------------------------------------------------------------------- 1 | (** Util module used for native builds (excluded in bs-config.json) *) 2 | module My_result = struct 3 | type ('good, 'bad) t = ('good, 'bad) result = 4 | | Ok of 'good 5 | | Error of 'bad 6 | 7 | let return x = Ok x 8 | 9 | let map f e = match e with Ok x -> Ok (f x) | Error s -> Error s 10 | 11 | let map_err f e = match e with Ok _ as res -> res | Error y -> Error (f y) 12 | 13 | let flat_map f e = match e with Ok x -> f x | Error s -> Error s 14 | 15 | let combine_l (results : ('a, 'e) result list) : ('a list, 'e list) result = 16 | let rec aux combined = function 17 | | [] -> 18 | ( match combined with 19 | | Ok xs -> 20 | Ok (List.rev xs) 21 | | Error es -> 22 | Error (List.rev es) ) 23 | | result :: rest -> 24 | let combined = 25 | match (result, combined) with 26 | | Ok x, Ok xs -> 27 | Ok (x :: xs) 28 | | Error e, Error es -> 29 | Error (e :: es) 30 | | Error e, Ok _ -> 31 | Error [ e ] 32 | | Ok _, Error es -> 33 | Error es 34 | in 35 | aux combined rest 36 | in 37 | aux (Ok []) results 38 | 39 | 40 | module Infix = struct 41 | let ( >|= ) e f = map f e 42 | 43 | let ( >>= ) e f = flat_map f e 44 | end 45 | end 46 | 47 | module My_opt = struct 48 | let return x = Some x 49 | 50 | let map f = function None -> None | Some x -> Some (f x) 51 | 52 | let flat_map f o = match o with None -> None | Some x -> f x 53 | end 54 | 55 | module My_list = struct 56 | let take n l = 57 | let rec direct i n l = 58 | match l with 59 | | [] -> 60 | [] 61 | | _ when i = 0 -> 62 | safe n [] l 63 | | x :: l' -> 64 | if n > 0 then x :: direct (i - 1) (n - 1) l' else [] 65 | and safe n acc l = 66 | match l with 67 | | [] -> 68 | List.rev acc 69 | | _ when n = 0 -> 70 | List.rev acc 71 | | x :: l' -> 72 | safe (n - 1) (x :: acc) l' 73 | in 74 | direct 500 n l 75 | 76 | 77 | let map f l = 78 | let rec direct f i l = 79 | match l with 80 | | [] -> 81 | [] 82 | | [ x ] -> 83 | [ f x ] 84 | | [ x1; x2 ] -> 85 | let y1 = f x1 in 86 | [ y1; f x2 ] 87 | | [ x1; x2; x3 ] -> 88 | let y1 = f x1 in 89 | let y2 = f x2 in 90 | [ y1; y2; f x3 ] 91 | | _ when i = 0 -> 92 | List.rev (List.rev_map f l) 93 | | x1 :: x2 :: x3 :: x4 :: l' -> 94 | let y1 = f x1 in 95 | let y2 = f x2 in 96 | let y3 = f x3 in 97 | let y4 = f x4 in 98 | y1 :: y2 :: y3 :: y4 :: direct f (i - 1) l' 99 | in 100 | direct f 500 l 101 | 102 | 103 | let all_some l = 104 | try Some (map (function Some x -> x | None -> raise Exit) l) with 105 | | Exit -> 106 | None 107 | 108 | 109 | let mapi f l = 110 | let r = ref 0 in 111 | map 112 | (fun x -> 113 | let y = f !r x in 114 | incr r ; 115 | y ) 116 | l 117 | 118 | 119 | let find_map f l = 120 | let rec aux f = function 121 | | [] -> 122 | None 123 | | x :: l' -> 124 | (match f x with Some _ as res -> res | None -> aux f l') 125 | in 126 | aux f l 127 | 128 | 129 | let filter_mapi f l = 130 | let rec recurse (acc, i) l = 131 | match l with 132 | | [] -> 133 | List.rev acc 134 | | x :: l' -> 135 | let acc' = match f i x with None -> acc | Some y -> y :: acc in 136 | recurse (acc', i + 1) l' 137 | in 138 | recurse ([], 0) l 139 | 140 | 141 | let filter_map f l = filter_mapi (fun _i x -> f x) l 142 | 143 | let fold_left = List.fold_left 144 | 145 | let direct_depth_append_ = 10_000 146 | 147 | let append l1 l2 = 148 | let rec direct i l1 l2 = 149 | match l1 with 150 | | [] -> 151 | l2 152 | | _ when i = 0 -> 153 | safe l1 l2 154 | | x :: l1' -> 155 | x :: direct (i - 1) l1' l2 156 | and safe l1 l2 = List.rev_append (List.rev l1) l2 in 157 | match l1 with 158 | | [] -> 159 | l2 160 | | [ x ] -> 161 | x :: l2 162 | | [ x; y ] -> 163 | x :: y :: l2 164 | | _ -> 165 | direct direct_depth_append_ l1 l2 166 | 167 | 168 | let ( @ ) = append 169 | 170 | let flat_map f l = 171 | let rec aux f l kont = 172 | match l with 173 | | [] -> 174 | kont [] 175 | | x :: l' -> 176 | let y = f x in 177 | let kont' tail = 178 | match y with 179 | | [] -> 180 | kont tail 181 | | [ x ] -> 182 | kont (x :: tail) 183 | | [ x; y ] -> 184 | kont (x :: y :: tail) 185 | | l -> 186 | kont (append l tail) 187 | in 188 | aux f l' kont' 189 | in 190 | aux f l (fun l -> l) 191 | end 192 | 193 | let with_file_in file f = 194 | let ic = open_in file in 195 | try 196 | let res = f ic in 197 | close_in ic ; 198 | res 199 | with 200 | | e -> 201 | close_in_noerr ic ; 202 | raise e 203 | 204 | 205 | let read_all ic : string = 206 | let buf = ref (Bytes.create 2048) in 207 | let len = ref 0 in 208 | try 209 | while true do 210 | (* resize *) 211 | if !len = Bytes.length !buf then buf := Bytes.extend !buf 0 !len ; 212 | assert (Bytes.length !buf > !len) ; 213 | let n = input ic !buf !len (Bytes.length !buf - !len) in 214 | len := !len + n ; 215 | if n = 0 then raise Exit 216 | (* exhausted *) 217 | done ; 218 | assert false (* never reached*) 219 | with 220 | | Exit -> 221 | Bytes.sub_string !buf 0 !len 222 | -------------------------------------------------------------------------------- /src/util.mli: -------------------------------------------------------------------------------- 1 | (** Util module used for native builds (excluded in bs-config.json) *) 2 | module My_result : sig 3 | type ('good, 'bad) t = ('good, 'bad) result = 4 | | Ok of 'good 5 | | Error of 'bad 6 | 7 | val return : 'good -> ('good, 'bad) t 8 | 9 | val map : ('a -> 'b) -> ('a, 'err) t -> ('b, 'err) t 10 | 11 | val map_err : ('err1 -> 'err2) -> ('a, 'err1) t -> ('a, 'err2) t 12 | 13 | val combine_l : ('a, 'e) result list -> ('a list, 'e list) result 14 | 15 | module Infix : sig 16 | val ( >|= ) : ('a, 'err) t -> ('a -> 'b) -> ('b, 'err) t 17 | 18 | val ( >>= ) : ('a, 'err) t -> ('a -> ('b, 'err) t) -> ('b, 'err) t 19 | end 20 | end 21 | 22 | module My_opt : sig 23 | val return : 'a -> 'a option 24 | 25 | val map : ('a -> 'b) -> 'a option -> 'b option 26 | 27 | val flat_map : ('a -> 'b option) -> 'a option -> 'b option 28 | end 29 | 30 | module My_list : sig 31 | val take : int -> 'a list -> 'a list 32 | 33 | val all_some : 'a option list -> 'a list option 34 | 35 | val map : ('a -> 'b) -> 'a list -> 'b list 36 | 37 | val mapi : (int -> 'a -> 'b) -> 'a list -> 'b list 38 | 39 | val filter_map : ('a -> 'b option) -> 'a list -> 'b list 40 | 41 | val filter_mapi : (int -> 'a -> 'b option) -> 'a list -> 'b list 42 | 43 | val find_map : ('a -> 'b option) -> 'a list -> 'b option 44 | 45 | val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a 46 | 47 | val append : 'a list -> 'a list -> 'a list 48 | 49 | val ( @ ) : 'a list -> 'a list -> 'a list 50 | 51 | val flat_map : ('a -> 'b list) -> 'a list -> 'b list 52 | end 53 | 54 | val with_file_in : string -> (in_channel -> 'a) -> 'a 55 | 56 | val read_all : in_channel -> string 57 | -------------------------------------------------------------------------------- /src/xml.ml: -------------------------------------------------------------------------------- 1 | (** Interface for decoding XML *) 2 | module type Decode = sig 3 | (** The type of XML values. *) 4 | type value 5 | 6 | type error = value Error.t 7 | 8 | val pp_error : Format.formatter -> error -> unit 9 | 10 | val string_of_error : error -> string 11 | 12 | val of_string : string -> (value, error) result 13 | 14 | val of_file : string -> (value, error) result 15 | 16 | (** The type of decoders. 17 | 18 | Use the functions below to construct decoders for your data types. 19 | 20 | To run a decoder, pass it to {!val:decode_value}. 21 | *) 22 | type 'a decoder = (value, 'a) Decoder.t 23 | 24 | (** {2 Decoding values} *) 25 | 26 | val data : string decoder 27 | (** Decode a [string]. *) 28 | 29 | val float : float decoder 30 | (** Decode a [float] in a data node after stripping whitespace. The advantage of using [float_decoder] is that it automatically takes care of trimming whitespace, 31 | which is useful since a float is not whitespace sensitive. *) 32 | 33 | val int : int decoder 34 | (** Decode an [int] in a data node after stripping whitespace. *) 35 | 36 | val bool : bool decoder 37 | (** Decode a [bool] in a data node after stripping whitespace. *) 38 | 39 | val tag : string -> unit decoder 40 | (** Assert the name of the current tag. *) 41 | 42 | val any_tag : string decoder 43 | (** Retrieve the name of the current tag. *) 44 | 45 | val attr : string -> string decoder 46 | (** [attr name] decodes the attribute named [name]. *) 47 | 48 | val attr_opt : string -> string option decoder 49 | (** [attr_opt name] decodes the attribute named [name], if present. *) 50 | 51 | val attrs : (string * string) list decoder 52 | (** [attrs] decodes the attributes as an assoc list. *) 53 | 54 | (** {3 Children} *) 55 | 56 | val children : 'a decoder -> 'a list decoder 57 | (** [children dec] Decodes all the children of the current tag using [dec]. *) 58 | 59 | val pick_children : 'a decoder decoder -> 'a list decoder 60 | (** [pick_children outer_decoder] Decodes the children of the current tag. 61 | 62 | If [outer_decoder] fails, the child is skipped and the error is ignored. 63 | 64 | If [outer_decoder] succeeds with [inner_decoder], [inner_decoder] is used 65 | to decode the child. 66 | 67 | For example, to decode only children like []: 68 | 69 | {[pick_children (tag "Child" >>= fun () -> succeed decode_child)]} 70 | 71 | To decode only child elements, skipping data nodes (often useful when 72 | there are data nodes introduced by whitespace between elements in the 73 | XML): 74 | 75 | {[pick_children (any_tag >>= fun tag_name -> succeed (decode_child_tag tag_name))]} 76 | *) 77 | 78 | (** {2 Inconsistent structure} *) 79 | 80 | val value : value decoder 81 | (** Decode a literal [value]. *) 82 | 83 | val maybe : 'a decoder -> 'a option decoder 84 | (** [maybe d] is a decoder that always succeeds. If [d] succeeds with [x], 85 | then [maybe d] succeeds with [Some x], otherwise if [d] fails, then [maybe d] 86 | succeeds with [None]. 87 | *) 88 | 89 | val one_of : 'a decoder list -> 'a decoder 90 | (** Try a sequence of different decoders. *) 91 | 92 | val pick : 'a decoder decoder list -> 'a decoder 93 | (** [pick choices] picks a single choice, like {!one_of}. 94 | However, each element of [choices] can look at the value, decide if 95 | it applies (e.g. based on the value of a single field, like a "kind" 96 | or "type" field), and if it does, returns a decoder for the rest of 97 | the value. 98 | 99 | If a choice is made, even if the returned sub-decoder fails, the 100 | error message will totally ignore the rest of the choices and only be 101 | about the choice that was initially made. 102 | *) 103 | 104 | val decode_sub : value -> 'a decoder -> 'a decoder 105 | (** [decode_sub value sub_dec] uses [sub_dec] to decode [value]. 106 | This is useful when one has a value on hand. 107 | *) 108 | 109 | (** {2 Mapping} *) 110 | 111 | val map : ('a -> 'b) -> 'a decoder -> 'b decoder 112 | (** Map over the result of a decoder. *) 113 | 114 | val apply : ('a -> 'b) decoder -> 'a decoder -> 'b decoder 115 | (** Try two decoders and then combine the result. We can use this to decode 116 | objects with many fields (but it's preferable to use [Infix.(>>=)] - see the README). 117 | *) 118 | 119 | (** {2 Fancy decoding} *) 120 | 121 | val pure : 'a -> 'a decoder 122 | (** A decoder that always succeeds with the argument, ignoring the input. *) 123 | 124 | val succeed : 'a -> 'a decoder 125 | (** Alias for [pure]. *) 126 | 127 | val fail : string -> 'a decoder 128 | (** A decoder that always fails with the given message, ignoring the input. *) 129 | 130 | val fail_with : error -> 'a decoder 131 | (** A decoder that always fails with the given error, ignoring the input. *) 132 | 133 | val from_result : ('a, error) result -> 'a decoder 134 | 135 | val and_then : ('a -> 'b decoder) -> 'a decoder -> 'b decoder 136 | (** Create decoders that depend on previous results. *) 137 | 138 | val fix : ('a decoder -> 'a decoder) -> 'a decoder 139 | (** Recursive decoders. 140 | 141 | [let my_decoder = fix (fun my_decoder -> ...)] allows you to define 142 | [my_decoder] in terms of itself. 143 | *) 144 | 145 | module Infix : module type of Decoder.Infix 146 | 147 | include module type of Infix 148 | 149 | (** {2 Running decoders} *) 150 | 151 | val decode_value : 'a decoder -> value -> ('a, error) result 152 | (** Run a decoder on some input. *) 153 | 154 | val decode_string : 'a decoder -> string -> ('a, error) result 155 | (** Run a decoder on a string. *) 156 | 157 | val decode_file : 'a decoder -> string -> ('a, error) result 158 | (** Run a decoder on a file. *) 159 | end 160 | 161 | module type Encode = sig 162 | type value 163 | 164 | type 'a encoder = 'a -> value 165 | 166 | val tag : string -> ?attrs:(string * string) list -> value list -> value 167 | 168 | val data : string encoder 169 | 170 | val value : value encoder 171 | 172 | val encode_string : 'a encoder -> 'a -> string 173 | end 174 | -------------------------------------------------------------------------------- /test-bencode/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name main) 3 | (package decoders-bencode) 4 | (libraries decoders-bencode containers ounit2)) 5 | -------------------------------------------------------------------------------- /test-bencode/main.ml: -------------------------------------------------------------------------------- 1 | open OUnit2 2 | 3 | let encode_s = Bencode.encode_to_string 4 | 5 | let decoders_suite = 6 | let open Decoders_bencode.Decode in 7 | let decoder_test ~decoder ~input ~expected _test_ctxt = 8 | match decode_string decoder input with 9 | | Ok value -> 10 | assert_equal value expected 11 | | Error error -> 12 | assert_string (Format.asprintf "%a" pp_error error) 13 | in 14 | 15 | "decoders" 16 | >::: [ "list string" 17 | >:: decoder_test 18 | ~decoder:(list string) 19 | ~input: 20 | (encode_s 21 | (Bencode.List 22 | [ Bencode.String "hello"; Bencode.String "world" ] ) ) 23 | ~expected:[ "hello"; "world" ] 24 | ; "field_opt present" 25 | >:: decoder_test 26 | ~decoder:(field_opt "optional" string) 27 | ~input: 28 | (encode_s 29 | (Bencode.Dict [ ("optional", Bencode.String "hello") ]) ) 30 | ~expected:(Some "hello") 31 | ; "field_opt missing" 32 | >:: decoder_test 33 | ~decoder:(field_opt "optional" string) 34 | ~input: 35 | (encode_s 36 | (Bencode.Dict [ ("missing", Bencode.String "hello") ]) ) 37 | ~expected:None 38 | ; ( "field_opt decode error" 39 | >:: fun _ -> 40 | match 41 | decode_string 42 | (field_opt "optional" string) 43 | (encode_s (Bencode.Dict [ ("optional", Bencode.Integer 123L) ])) 44 | with 45 | | Ok _ -> 46 | assert_string "expected decode error" 47 | | Error e -> 48 | assert_equal 49 | ~printer:CCFun.id 50 | {|in field "optional": Expected a string, but got 123|} 51 | (Format.asprintf "%a" pp_error e) ) 52 | ] 53 | 54 | 55 | let encoders_suite = 56 | let open Decoders_bencode.Encode in 57 | "encoders" 58 | >::: [ ( "list string" 59 | >:: fun _ctxt -> 60 | assert_equal 61 | ~printer:CCFun.id 62 | (encode_s 63 | (Bencode.List [ Bencode.String "hello"; Bencode.String "world" ]) ) 64 | (encode_string (list string) [ "hello"; "world" ]) ) 65 | ; ( "string" 66 | >:: fun _ctxt -> 67 | assert_equal 68 | ~printer:CCFun.id 69 | (encode_s (Bencode.String "hello")) 70 | (encode_string string "hello") ) 71 | ] 72 | 73 | 74 | let () = "Bencode" >::: [ decoders_suite; encoders_suite ] |> run_test_tt_main 75 | -------------------------------------------------------------------------------- /test-cbor/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name main) 3 | (package decoders-cbor) 4 | (libraries decoders-cbor containers ounit2)) 5 | -------------------------------------------------------------------------------- /test-cbor/main.ml: -------------------------------------------------------------------------------- 1 | open OUnit2 2 | 3 | let decoders_suite = 4 | let open Decoders_cbor.Decode in 5 | let decoder_test ~decoder ~input ~expected _test_ctxt = 6 | match decode_string decoder input with 7 | | Ok value -> 8 | assert_equal value expected 9 | | Error error -> 10 | assert_string (Format.asprintf "%a" pp_error error) 11 | in 12 | 13 | "decoders" 14 | >::: [ "list string" 15 | >:: decoder_test 16 | ~decoder:(list string) 17 | ~input: 18 | (CBOR.Simple.encode (`Array [ `Text "hello"; `Text "world" ])) 19 | ~expected:[ "hello"; "world" ] 20 | ; "field_opt present" 21 | >:: decoder_test 22 | ~decoder:(field_opt "optional" string) 23 | ~input: 24 | (CBOR.Simple.encode 25 | (`Map [ (`Text "optional", `Text "hello") ]) ) 26 | ~expected:(Some "hello") 27 | ; "field_opt missing" 28 | >:: decoder_test 29 | ~decoder:(field_opt "optional" string) 30 | ~input: 31 | (CBOR.Simple.encode 32 | (`Map [ (`Text "missing", `Text "hello") ]) ) 33 | ~expected:None 34 | ; ( "field_opt decode error" 35 | >:: fun _ -> 36 | match 37 | decode_string 38 | (field_opt "optional" string) 39 | (CBOR.Simple.encode (`Map [ (`Text "optional", `Int 123) ])) 40 | with 41 | | Ok _ -> 42 | assert_string "expected decode error" 43 | | Error e -> 44 | assert_equal 45 | ~printer:CCFun.id 46 | {|in field "optional": Expected a string, but got 123|} 47 | (Format.asprintf "%a" pp_error e) ) 48 | ] 49 | 50 | 51 | let encoders_suite = 52 | let open Decoders_cbor.Encode in 53 | "encoders" 54 | >::: [ ( "list string" 55 | >:: fun _ctxt -> 56 | assert_equal 57 | ~printer:CCFun.id 58 | (CBOR.Simple.encode (`Array [ `Text "hello"; `Text "world" ])) 59 | (encode_string (list string) [ "hello"; "world" ]) ) 60 | ; ( "string" 61 | >:: fun _ctxt -> 62 | assert_equal 63 | ~printer:CCFun.id 64 | (CBOR.Simple.encode (`Text "hello")) 65 | (encode_string string "hello") ) 66 | ] 67 | 68 | 69 | let () = "CBOR" >::: [ decoders_suite; encoders_suite ] |> run_test_tt_main 70 | -------------------------------------------------------------------------------- /test-ezjsonm/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name main) 3 | (package decoders-ezjsonm) 4 | (libraries decoders-ezjsonm containers ounit2)) 5 | -------------------------------------------------------------------------------- /test-ezjsonm/main.ml: -------------------------------------------------------------------------------- 1 | open OUnit2 2 | 3 | let ezjsonm_suite = 4 | let open Decoders_ezjsonm.Decode in 5 | let decoder_test ~decoder ~input ~expected _test_ctxt = 6 | match decode_string decoder input with 7 | | Ok value -> 8 | assert_equal value expected 9 | | Error error -> 10 | assert_string (Format.asprintf "%a" pp_error error) 11 | in 12 | 13 | "Ezjsonm" 14 | >::: [ "list string" 15 | >:: decoder_test 16 | ~decoder:(list string) 17 | ~input:{|["hello", "world"]|} 18 | ~expected:[ "hello"; "world" ] 19 | ; "field_opt present" 20 | >:: decoder_test 21 | ~decoder:(field_opt "optional" string) 22 | ~input:{|{"optional": "hello"}|} 23 | ~expected:(Some "hello") 24 | ; "field_opt missing" 25 | >:: decoder_test 26 | ~decoder:(field_opt "optional" string) 27 | ~input:{|{"missing": "hello"}|} 28 | ~expected:None 29 | ; ( "field_opt decode error" 30 | >:: fun _ -> 31 | match 32 | decode_string (field_opt "optional" string) {|{"optional": 123}|} 33 | with 34 | | Ok _ -> 35 | assert_string "expected decode error" 36 | | Error e -> 37 | assert_equal 38 | ~printer:CCFun.id 39 | {|in field "optional": Expected a string, but got 123.|} 40 | (Format.asprintf "%a" pp_error e) ) 41 | ] 42 | 43 | 44 | let ezjsonm_encoders_suite = 45 | let open Decoders_ezjsonm.Encode in 46 | "Ezjsonm encoders" 47 | >::: [ ( "list string" 48 | >:: fun _ctxt -> 49 | assert_equal 50 | ~printer:CCFun.id 51 | {|["hello","world"]|} 52 | (encode_string (list string) [ "hello"; "world" ]) ) 53 | ; ( "string" 54 | >:: fun _ctxt -> 55 | assert_equal 56 | ~printer:CCFun.id 57 | {|"hello"|} 58 | (encode_string string "hello") ) 59 | ] 60 | 61 | 62 | let () = 63 | "decoders" >::: [ ezjsonm_suite; ezjsonm_encoders_suite ] |> run_test_tt_main 64 | -------------------------------------------------------------------------------- /test-ezxmlm/dune: -------------------------------------------------------------------------------- 1 | (tests 2 | (names test_ezxmlm_decode) 3 | (package decoders-ezxmlm) 4 | (libraries decoders-ezxmlm containers)) 5 | -------------------------------------------------------------------------------- /test-ezxmlm/test_ezxmlm_decode.expected: -------------------------------------------------------------------------------- 1 | Decode a tree: 2 | (:main "MainTree" 3 | :trees ((:MainTree (:sequence ((:action "SayA") (:subtree "GraspObject")))) 4 | (:GraspObject (:sequence 5 | ((:action "Open") (:action "Approach") 6 | (:action "Close") (:subtree "DestroyObject")))) 7 | (:DestroyObject (:sequence ((:action "Booom")))))) 8 | 9 | Comments are skipped: 10 | " Some data " 11 | 12 | Comments are skipped: 13 | " Some data in nested node " 14 | 15 | Comments are skipped: 16 | 17 | 18 | More data, even more data 19 | 20 | 0.750000 -------------------------------------------------------------------------------- /test-ezxmlm/test_ezxmlm_decode.ml: -------------------------------------------------------------------------------- 1 | open CCFormat 2 | 3 | (* Example 1*) 4 | let xml_str = 5 | {| 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | |} 28 | 29 | 30 | type root = 31 | { main : string 32 | ; trees : (string * node) list 33 | } 34 | 35 | and node = 36 | | Action of 37 | { id : string 38 | ; attrs : (string * string) list 39 | } 40 | | Sequence of node list 41 | | Subtree of { id : string } 42 | 43 | let rec pp_root fmt root = 44 | fprintf 45 | fmt 46 | "@[<1>(:main %S@ :trees @[<1>(%a)@])@]" 47 | root.main 48 | (list ~sep:(return "@ ") pp_tree) 49 | root.trees 50 | 51 | 52 | and pp_tree fmt (name, node) = fprintf fmt "@[<1>(:%s %a)@]" name pp_node node 53 | 54 | and pp_node fmt = function 55 | | Action { id; attrs = _ } -> 56 | fprintf fmt "@[<1>(:action %S)@]" id 57 | | Sequence nodes -> 58 | fprintf 59 | fmt 60 | "@[<1>(:sequence@ @[<1>(%a)@])@]" 61 | (list ~sep:(return "@ ") pp_node) 62 | nodes 63 | | Subtree { id } -> 64 | fprintf fmt "@[<1>(:subtree %S)@]" id 65 | 66 | 67 | open Decoders_ezxmlm.Decode 68 | 69 | let rec node node_ty : node decoder = 70 | match node_ty with 71 | | "Action" -> 72 | attr "ID" >>= fun id -> succeed (Action { id; attrs = [] }) 73 | | "Sequence" -> 74 | pick_children (any_tag >>= fun node_ty -> pure (node node_ty)) 75 | >>= fun nodes -> succeed (Sequence nodes) 76 | | "Subtree" -> 77 | attr "ID" >>= fun id -> succeed (Subtree { id }) 78 | | _ -> 79 | fail "Unknown node type" 80 | 81 | 82 | let tree : (string * node) decoder = 83 | attr "ID" 84 | >>= fun id -> 85 | pick_children (any_tag >>= fun node_ty -> pure (node node_ty)) 86 | >>= function 87 | | [ node ] -> succeed (id, node) | _ -> fail "Expected a single child" 88 | 89 | 90 | let root : root decoder = 91 | tag "root" 92 | >>= fun () -> 93 | attr "main_tree_to_execute" 94 | >>= fun main -> 95 | pick_children (tag "BehaviorTree" >>= fun () -> pure tree) 96 | >>= fun trees -> succeed { main; trees } 97 | 98 | 99 | let pp_print_result ~ok ~error fmt = function 100 | | Ok x -> 101 | ok fmt x 102 | | Error e -> 103 | error fmt e 104 | 105 | 106 | let () = 107 | printf 108 | "@[Decode a tree:@ %a@]@.@." 109 | (pp_print_result ~ok:pp_root ~error:pp_error) 110 | (decode_string root xml_str) 111 | 112 | 113 | (* Example 2*) 114 | let () = 115 | let xml_str = {| Some data |} in 116 | let decoder = tag "root" >>= fun () -> children data in 117 | printf 118 | "@[Comments are skipped:@ %a@]@.@." 119 | (pp_print_result ~ok:(list string_quoted) ~error:pp_error) 120 | (decode_string decoder xml_str) 121 | 122 | 123 | (* Example 3 : using pick_children to select data in a grandchild of root. *) 124 | let () = 125 | let xml_str = 126 | {| Some data in nested node |} 127 | in 128 | let decoder : string list list decoder = 129 | (* To begin, the decoder is "focussed" on the top level element, in this case . *) 130 | (* [tag "root"] asserts that the "focussed" element is the tag "root"; it will fail otherwise. *) 131 | tag "root" 132 | >>= fun () -> 133 | (* Now we want to descend into the children of . *) 134 | (* [pick_children d] selects all the children for which the decoder [d] succeeds. 135 | If [d] fails, the child will be skipped. 136 | If [d] succeeds, it should return *another* decoder which will be 137 | used to decode the child. 138 | *) 139 | pick_children 140 | ( (* [tag "node"] asserts that the current element is the tag . This 141 | will fail for other children of (e.g. the whitespace data), so 142 | everything else will be skipped. *) 143 | tag "node" 144 | >>= fun () -> 145 | (* Now we are "focussed" on the children, we want do return all 146 | the text data children of those nodes. 147 | 148 | We use [children] here and not [pick_children], so anything that 149 | fails to decode as [data] will fail the whole decoder. 150 | *) 151 | pure (children data) ) 152 | in 153 | printf 154 | "@[Comments are skipped:@ %a@]@.@." 155 | (pp_print_result ~ok:(list (list string_quoted)) ~error:pp_error) 156 | (decode_string decoder xml_str) 157 | 158 | 159 | (* Example 3 : using pick_children to select data in a grandchild of root. *) 160 | let () = 161 | let xml_str = 162 | {| Some data More data |} 163 | in 164 | let decoder : string list list decoder = 165 | (* To begin, the decoder is "focussed" on the top level element, in this case . *) 166 | (* [tag "root"] asserts that the "focussed" element is the tag "root"; it will fail otherwise. *) 167 | tag "root" 168 | >>= fun () -> 169 | (* Now we want to descend into the children of . *) 170 | (* [pick_children d] selects all the children for which the decoder [d] succeeds. 171 | If [d] fails, the child will be skipped. 172 | If [d] succeeds, it should return *another* decoder which will be 173 | used to decode the child. 174 | *) 175 | pick_children 176 | ( (* [tag "node"] asserts that the current element is the tag . This 177 | will fail for other children of (e.g. the whitespace data), so 178 | everything else will be skipped. *) 179 | tag "node" 180 | >>= fun () -> 181 | (* Now we are "focussed" on the children, we want do return all 182 | the text data children of those nodes. 183 | 184 | We use [children] here and not [pick_children], so anything that 185 | fails to decode as [data] will fail the whole decoder. 186 | *) 187 | pure (children data) ) 188 | in 189 | printf 190 | "@[Comments are skipped:@ %a@]@.@." 191 | (pp_print_result ~ok:(list (list string_quoted)) ~error:pp_error) 192 | (decode_string decoder xml_str) 193 | 194 | 195 | (* Example 4 *) 196 | 197 | let root_decoder = 198 | let open Decoders_ezxmlm.Decode in 199 | let node2_decoder = 200 | pick_children (any_tag >>= fun _ -> succeed @@ children data) 201 | >|= List.concat 202 | in 203 | tag "root" 204 | >>= fun () -> 205 | pick_children 206 | ( any_tag 207 | >>= fun nm -> 208 | match nm with 209 | | "node2" -> 210 | tag "node2" >>= fun () -> succeed @@ node2_decoder 211 | | _ -> 212 | fail "invalid node" ) 213 | >|= List.concat 214 | 215 | 216 | let () = 217 | let open Decoders_ezxmlm.Decode in 218 | let xml_str = 219 | {| Some data More data even more data |} 220 | in 221 | let ret = decode_string root_decoder xml_str in 222 | match ret with 223 | | Ok fld -> 224 | printf "%a@.@." CCFormat.(list ~sep:(return ",") string) fld 225 | (* this prints "More data, even more data" *) 226 | | Error e -> 227 | failwith @@ string_of_error e 228 | 229 | 230 | (* Example 5 *) 231 | 232 | let () = 233 | let open Decoders_ezxmlm.Decode in 234 | let xml_str = {| 235 | 236 | 237 | 238 | 239 | 0.75 240 | 241 | 242 | 243 | |} in 244 | let root_decoder : float list decoder = 245 | tag "root" 246 | >>= fun () -> 247 | pick_children (tag "node" >>= fun () -> pure @@ children float) 248 | >|= List.concat 249 | in 250 | let ret = decode_string root_decoder xml_str in 251 | match ret with 252 | | Ok [ fld ] -> 253 | printf "%f" fld 254 | | Error e -> 255 | failwith @@ string_of_error e 256 | | _ -> 257 | failwith "failed!" 258 | -------------------------------------------------------------------------------- /test-jsonaf/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name main) 3 | (package decoders-jsonaf) 4 | (libraries decoders-jsonaf ounit2)) 5 | -------------------------------------------------------------------------------- /test-jsonaf/main.ml: -------------------------------------------------------------------------------- 1 | open OUnit2 2 | 3 | type tree = 4 | | Leaf of int 5 | | Node of tree * tree 6 | 7 | let jsonaf_decode_suite = 8 | let open Decoders_jsonaf.Decode in 9 | let decoder_test ~decoder ~input ~expected ?printer _test_ctxt = 10 | match decode_string decoder input with 11 | | Ok value -> 12 | assert_equal value expected ?printer 13 | | Error error -> 14 | assert_string (Format.asprintf "%a" pp_error error) 15 | in 16 | 17 | let list_string_test = 18 | "list string" 19 | >:: decoder_test 20 | ~decoder:(list string) 21 | ~input:"[\"Hello world\"]" 22 | ~expected:[ "Hello world" ] 23 | in 24 | 25 | let array_string_test = 26 | "array string" 27 | >:: decoder_test 28 | ~decoder:(array string) 29 | ~input:"[\"Hello world\"]" 30 | ~expected:[| "Hello world" |] 31 | in 32 | 33 | let fix_one_of_test = 34 | "fix one_of" 35 | >:: fun _ -> 36 | let tree_decoder = 37 | fix (fun tree_decoder -> 38 | let leaf_decoder = int |> map (fun i -> Leaf i) in 39 | let node_decoder = 40 | Pipeline.( 41 | decode (fun left right -> Node (left, right)) 42 | |> required "left" tree_decoder 43 | |> required "right" tree_decoder) 44 | in 45 | one_of [ ("leaf", leaf_decoder); ("node", node_decoder) ] ) 46 | in 47 | decoder_test 48 | ~decoder:tree_decoder 49 | ~input:"{\"left\":1, \"right\":{\"left\":2,\"right\":3}}" 50 | ~expected:(Node (Leaf 1, Node (Leaf 2, Leaf 3))) 51 | () 52 | in 53 | 54 | let mut_rec_test = 55 | "mutual recursion" 56 | >:: fun _ -> 57 | let module M = struct 58 | type t1 = 59 | | T1_end 60 | | T1_more of t2 61 | 62 | and t2 = 63 | | T2_end 64 | | T2_more of t1 65 | 66 | let rec t1_to_string = function 67 | | T1_end -> 68 | "T1_end" 69 | | T1_more t2 -> 70 | Printf.sprintf "(T1_more %s)" (t2_to_string t2) 71 | 72 | 73 | and t2_to_string = function 74 | | T2_end -> 75 | "T2_end" 76 | | T2_more t1 -> 77 | Printf.sprintf "(T2_more %s)" (t1_to_string t1) 78 | end in 79 | let open M in 80 | let t1_decoder = 81 | fix (fun t1_decoder -> 82 | let t2 = 83 | nullable (field "t1" t1_decoder) 84 | |> map (function None -> T2_end | Some t1 -> T2_more t1) 85 | in 86 | let t1 = 87 | nullable (field "t2" t2) 88 | |> map (function None -> T1_end | Some t2 -> T1_more t2) 89 | in 90 | t1 ) 91 | in 92 | decoder_test 93 | () 94 | ~decoder:t1_decoder 95 | ~input:{| 96 | { "t2": { "t1": { "t2": null } } } 97 | |} 98 | ~expected:(T1_more (T2_more (T1_more T2_end))) 99 | ~printer:t1_to_string 100 | in 101 | 102 | let string_or_floatlit_test = 103 | "string or floatlit" 104 | >:: fun _ -> 105 | let empty_string = 106 | string 107 | |> and_then (function 108 | | "" -> 109 | succeed () 110 | | _ -> 111 | fail "Expected an empty string" ) 112 | in 113 | decoder_test 114 | ~decoder:(one_of [ ("empty", empty_string |> map (fun () -> None)) ]) 115 | ~input:"\"\"" 116 | ~expected:None 117 | () 118 | in 119 | 120 | let grouping_errors_test = 121 | "grouping errors" 122 | >:: fun _test_ctxt -> 123 | let decoder = 124 | Pipeline.( 125 | decode (fun x y z -> (x, y, z)) 126 | |> required 127 | "records" 128 | (list 129 | ( decode (fun x y z -> (x, y, z)) 130 | |> required "x" (list string) 131 | |> required "y" int 132 | |> required "z" bool ) ) 133 | |> required "hello" int 134 | |> required "another" int) 135 | in 136 | let input = 137 | {| 138 | {"records": [true, {"x": [1, "c", 3], "y": "hello"}], "hello": "world", "another": "error"} 139 | |} 140 | in 141 | let expected_error = 142 | let open Decoders in 143 | Error.tag 144 | {|in field "records"|} 145 | (Error.tag_group 146 | "while decoding a list" 147 | [ Error.tag 148 | "element 0" 149 | (Error.make 150 | {|Expected an object with an attribute "x"|} 151 | ~context:`True ) 152 | ; Error.tag 153 | "element 1" 154 | (Error.tag 155 | {|in field "x"|} 156 | (Error.tag_group 157 | "while decoding a list" 158 | [ Error.tag 159 | "element 0" 160 | (Error.make "Expected a string" ~context:(`Number "1")) 161 | ; Error.tag 162 | "element 2" 163 | (Error.make "Expected a string" ~context:(`Number "3")) 164 | ] ) ) 165 | ] ) 166 | in 167 | match decode_string decoder input with 168 | | Ok _ -> 169 | assert_string "Expected an error" 170 | | Error error -> 171 | assert_equal expected_error error ~printer:(fun e -> 172 | Format.asprintf "@,@[%a@]" pp_error e ) 173 | in 174 | 175 | "Jsonaf" 176 | >::: [ list_string_test 177 | ; array_string_test 178 | ; fix_one_of_test 179 | ; mut_rec_test 180 | ; string_or_floatlit_test 181 | ; grouping_errors_test 182 | ] 183 | 184 | 185 | let jsonaf_encode_suite = 186 | let open Decoders_jsonaf.Encode in 187 | let encoder_test ~encoder ~input ~expected ?printer _test_ctxt = 188 | assert_equal (encode_string encoder input) expected ?printer 189 | in 190 | 191 | let float_test_0 = 192 | "float test 0" >:: encoder_test ~encoder:float ~input:123. ~expected:"123" 193 | in 194 | let float_test_1 = 195 | "float test 1" 196 | >:: encoder_test ~encoder:float ~input:123.456 ~expected:"123.456" 197 | in 198 | "Jsonaf" >::: [ float_test_0; float_test_1 ] 199 | 200 | 201 | let () = 202 | "decoders" 203 | >::: [ jsonaf_decode_suite; jsonaf_encode_suite ] 204 | |> run_test_tt_main 205 | -------------------------------------------------------------------------------- /test-jsonm/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name main) 3 | (package decoders-jsonm) 4 | (libraries decoders-jsonm containers ounit2)) 5 | -------------------------------------------------------------------------------- /test-jsonm/main.ml: -------------------------------------------------------------------------------- 1 | open OUnit2 2 | 3 | let jsonm_suite = 4 | let open Decoders_jsonm.Encode in 5 | let test _test_ctxt = 6 | let encoder () = 7 | array_start >> int 0 >> int 1 >> string "hello" >> array_end 8 | in 9 | let s = encode_string encoder () in 10 | assert_equal ~printer:CCFun.id {|[0,1,"hello"]|} s 11 | in 12 | 13 | "Jsonm" >::: [ "encoding a list" >:: test ] 14 | 15 | 16 | let () = "encoders" >::: [ jsonm_suite ] |> run_test_tt_main 17 | -------------------------------------------------------------------------------- /test-msgpck/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name main) 3 | (package decoders-msgpck) 4 | (libraries decoders-msgpck containers ounit2)) 5 | -------------------------------------------------------------------------------- /test-msgpck/main.ml: -------------------------------------------------------------------------------- 1 | open OUnit2 2 | module M = Msgpck 3 | 4 | let m_to_str m = M.StringBuf.to_string m |> Buffer.contents 5 | 6 | let decoders_suite = 7 | let open Decoders_msgpck.Decode in 8 | let decoder_test ~decoder ~input ~expected _test_ctxt = 9 | match decode_string decoder input with 10 | | Ok value -> 11 | assert_equal value expected 12 | | Error error -> 13 | assert_string (Format.asprintf "%a" pp_error error) 14 | in 15 | 16 | "decoders" 17 | >::: [ "list string" 18 | >:: decoder_test 19 | ~decoder:(list string) 20 | ~input:(m_to_str (M.List [ M.String "hello"; M.String "world" ])) 21 | ~expected:[ "hello"; "world" ] 22 | ; "field_opt present" 23 | >:: decoder_test 24 | ~decoder:(field_opt "optional" string) 25 | ~input: 26 | (m_to_str (M.Map [ (M.String "optional", M.String "hello") ])) 27 | ~expected:(Some "hello") 28 | ; "field_opt missing" 29 | >:: decoder_test 30 | ~decoder:(field_opt "optional" string) 31 | ~input: 32 | (m_to_str (M.Map [ (M.String "missing", M.String "hello") ])) 33 | ~expected:None 34 | ; ( "field_opt decode error" 35 | >:: fun _ -> 36 | match 37 | decode_string 38 | (field_opt "optional" string) 39 | (m_to_str (M.Map [ (M.String "optional", M.Int 123) ])) 40 | with 41 | | Ok _ -> 42 | assert_string "expected decode error" 43 | | Error e -> 44 | assert_equal 45 | ~printer:CCFun.id 46 | {|in field "optional": Expected a string, but got 123|} 47 | (Format.asprintf "%a" pp_error e) ) 48 | ; "int32 conversion" 49 | >:: decoder_test 50 | ~decoder:int 51 | ~input:(m_to_str (M.Int32 32l)) 52 | ~expected:32 53 | ; "int64 conversion" 54 | >:: decoder_test 55 | ~decoder:int 56 | ~input:(m_to_str (M.Int64 525252L)) 57 | ~expected:525252 58 | ; "int64 helper" 59 | >:: decoder_test 60 | ~decoder:int64 61 | ~input:(m_to_str (M.Int64 Int64.max_int)) 62 | ~expected:Int64.max_int 63 | ; ( "int64 overflow" 64 | >:: fun _ -> 65 | match decode_string int (m_to_str (M.Int64 Int64.max_int)) with 66 | | Ok v -> 67 | assert_string (Printf.sprintf "expected decode error, got %d" v) 68 | | Error _e -> 69 | () ) 70 | ; "pick1" 71 | >:: decoder_test 72 | ~decoder: 73 | (pick 74 | [ ( "case_x" 75 | , let* _x = field "x" null in 76 | succeed 77 | (let+ v = field "val" int in 78 | `Int v ) ) 79 | ; ( "case_y" 80 | , let* _y = field "y" null in 81 | succeed 82 | (let+ v = field "val" float in 83 | `Float v ) ) 84 | ] ) 85 | ~input: 86 | (m_to_str 87 | (M.Map [ (M.String "x", M.Nil); (M.String "val", M.Int 42) ]) ) 88 | ~expected:(`Int 42) 89 | ; "pick2" 90 | >:: decoder_test 91 | ~decoder: 92 | (pick 93 | [ ( "case_x" 94 | , let* _x = field "x" null in 95 | succeed 96 | (let+ v = field "val" int in 97 | `Int v ) ) 98 | ; ( "case_y" 99 | , let* _y = field "y" null in 100 | succeed 101 | (let+ v = field "val" float in 102 | `Float v ) ) 103 | ] ) 104 | ~input: 105 | (m_to_str 106 | (M.Map 107 | [ (M.String "y", M.Nil); (M.String "val", M.Float 1.1) ] 108 | ) ) 109 | ~expected:(`Float 1.1) 110 | ] 111 | 112 | 113 | let encoders_suite = 114 | let open Decoders_msgpck.Encode in 115 | "encoders" 116 | >::: [ ( "list string" 117 | >:: fun _ctxt -> 118 | assert_equal 119 | ~printer:CCFun.id 120 | (m_to_str (M.List [ M.String "hello"; M.String "world" ])) 121 | (encode_string (list string) [ "hello"; "world" ]) ) 122 | ; ( "string" 123 | >:: fun _ctxt -> 124 | assert_equal 125 | ~printer:CCFun.id 126 | (m_to_str (M.String "hello")) 127 | (encode_string string "hello") ) 128 | ; ( "int64" 129 | >:: fun _ctxt -> 130 | assert_equal 131 | ~printer:CCFun.id 132 | (m_to_str (M.Int64 Int64.max_int)) 133 | (encode_string int64 Int64.max_int) ) 134 | ] 135 | 136 | 137 | let () = "msgpck" >::: [ decoders_suite; encoders_suite ] |> run_test_tt_main 138 | -------------------------------------------------------------------------------- /test-otoml/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name main) 3 | (package decoders-otoml) 4 | (libraries decoders-otoml containers ounit2)) 5 | -------------------------------------------------------------------------------- /test-otoml/main.ml: -------------------------------------------------------------------------------- 1 | open OUnit2 2 | 3 | let otoml_suite = 4 | let open Decoders_otoml.Decode in 5 | let decoder_test ~decoder ~input ~expected _test_ctxt = 6 | match decode_string decoder input with 7 | | Ok value -> 8 | assert_equal value expected 9 | | Error error -> 10 | assert_string (Format.asprintf "%a" pp_error error) 11 | in 12 | 13 | "otoml" 14 | >::: [ "basic" 15 | >:: decoder_test 16 | ~decoder: 17 | (let+ a = field "a" int 18 | and+ b = field "b" float in 19 | (a, b) ) 20 | ~input:"a=1\nb=42.5" 21 | ~expected:(1, 42.5) 22 | ; "table" 23 | >:: decoder_test 24 | ~decoder:(field "sub" (field_opt "a" int)) 25 | ~input:"[sub]\na = 42" 26 | ~expected:(Some 42) 27 | ; "table (field absent)" 28 | >:: decoder_test 29 | ~decoder:(field "sub" (field_opt "a" int)) 30 | ~input:"[sub]\nb = false" 31 | ~expected:None 32 | ] 33 | 34 | 35 | let () = "decoders" >::: [ otoml_suite ] |> run_test_tt_main 36 | -------------------------------------------------------------------------------- /test-sexplib/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name main) 3 | (package decoders-sexplib) 4 | (libraries decoders-sexplib containers ounit2)) 5 | -------------------------------------------------------------------------------- /test-sexplib/main.ml: -------------------------------------------------------------------------------- 1 | open OUnit2 2 | 3 | let sexplib_suite = 4 | let open Decoders_sexplib.Decode in 5 | let decoder_test ~decoder ~input ~expected _test_ctxt = 6 | match decode_string decoder input with 7 | | Ok value -> 8 | assert_equal value expected 9 | | Error error -> 10 | assert_string (Format.asprintf "%a" pp_error error) 11 | in 12 | 13 | "Sexplib" 14 | >::: [ "list string" 15 | >:: decoder_test 16 | ~decoder:(list string) 17 | ~input:"(hello world)" 18 | ~expected:[ "hello"; "world" ] 19 | ; "list string (one element)" 20 | >:: decoder_test 21 | ~decoder:(list string) 22 | ~input:"(hello)" 23 | ~expected:[ "hello" ] 24 | ; "field_opt present" 25 | >:: decoder_test 26 | ~decoder:(field_opt "optional" string) 27 | ~input:"((optional hello))" 28 | ~expected:(Some "hello") 29 | ; "field_opt missing" 30 | >:: decoder_test 31 | ~decoder:(field_opt "optional" string) 32 | ~input:"()" 33 | ~expected:None 34 | ; ( "uncons" 35 | >:: 36 | let ( >>=:: ) head tail = uncons tail head in 37 | decoder_test 38 | ~input: 39 | "(library (name decoders-sexplib) (libraries decoders sexplib0))" 40 | ~decoder: 41 | ( string 42 | >>=:: function 43 | | "library" -> 44 | field "name" string 45 | >>= fun name -> 46 | field 47 | "libraries" 48 | (one_of 49 | [ ("list", list string) 50 | ; ("string", string >|= fun s -> [ s ]) 51 | ] ) 52 | >>= fun libs -> succeed (name, libs) 53 | | _ -> 54 | fail "Expected 'library'" ) 55 | ~expected:("decoders-sexplib", [ "decoders"; "sexplib0" ]) ) 56 | ] 57 | 58 | 59 | let () = "decoders" >::: [ sexplib_suite ] |> run_test_tt_main 60 | -------------------------------------------------------------------------------- /test-yojson/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name main) 3 | (package decoders-yojson) 4 | (libraries decoders-yojson ounit2)) 5 | -------------------------------------------------------------------------------- /test-yojson/main.ml: -------------------------------------------------------------------------------- 1 | open OUnit2 2 | 3 | type tree = 4 | | Leaf of int 5 | | Node of tree * tree 6 | 7 | let yojson_basic_suite = 8 | let open Decoders_yojson.Basic.Decode in 9 | let decoder_test ~decoder ~input ~expected ?printer _test_ctxt = 10 | match decode_string decoder input with 11 | | Ok value -> 12 | assert_equal value expected ?printer 13 | | Error error -> 14 | assert_string (Format.asprintf "%a" pp_error error) 15 | in 16 | 17 | let list_string_test = 18 | "list string" 19 | >:: decoder_test 20 | ~decoder:(list string) 21 | ~input:"[\"Hello world\"]" 22 | ~expected:[ "Hello world" ] 23 | in 24 | 25 | let array_string_test = 26 | "array string" 27 | >:: decoder_test 28 | ~decoder:(array string) 29 | ~input:"[\"Hello world\"]" 30 | ~expected:[| "Hello world" |] 31 | in 32 | 33 | let fix_one_of_test = 34 | "fix one_of" 35 | >:: fun _ -> 36 | let tree_decoder = 37 | fix (fun tree_decoder -> 38 | let leaf_decoder = int |> map (fun i -> Leaf i) in 39 | let node_decoder = 40 | Pipeline.( 41 | decode (fun left right -> Node (left, right)) 42 | |> required "left" tree_decoder 43 | |> required "right" tree_decoder) 44 | in 45 | one_of [ ("leaf", leaf_decoder); ("node", node_decoder) ] ) 46 | in 47 | decoder_test 48 | ~decoder:tree_decoder 49 | ~input:"{\"left\":1, \"right\":{\"left\":2,\"right\":3}}" 50 | ~expected:(Node (Leaf 1, Node (Leaf 2, Leaf 3))) 51 | () 52 | in 53 | 54 | let mut_rec_test = 55 | "mutual recursion" 56 | >:: fun _ -> 57 | let module M = struct 58 | type t1 = 59 | | T1_end 60 | | T1_more of t2 61 | 62 | and t2 = 63 | | T2_end 64 | | T2_more of t1 65 | 66 | let rec t1_to_string = function 67 | | T1_end -> 68 | "T1_end" 69 | | T1_more t2 -> 70 | Printf.sprintf "(T1_more %s)" (t2_to_string t2) 71 | 72 | 73 | and t2_to_string = function 74 | | T2_end -> 75 | "T2_end" 76 | | T2_more t1 -> 77 | Printf.sprintf "(T2_more %s)" (t1_to_string t1) 78 | end in 79 | let open M in 80 | let t1_decoder = 81 | fix (fun t1_decoder -> 82 | let t2 = 83 | nullable (field "t1" t1_decoder) 84 | |> map (function None -> T2_end | Some t1 -> T2_more t1) 85 | in 86 | let t1 = 87 | nullable (field "t2" t2) 88 | |> map (function None -> T1_end | Some t2 -> T1_more t2) 89 | in 90 | t1 ) 91 | in 92 | decoder_test 93 | () 94 | ~decoder:t1_decoder 95 | ~input:{| 96 | { "t2": { "t1": { "t2": null } } } 97 | |} 98 | ~expected:(T1_more (T2_more (T1_more T2_end))) 99 | ~printer:t1_to_string 100 | in 101 | 102 | let string_or_floatlit_test = 103 | "string or floatlit" 104 | >:: fun _ -> 105 | let empty_string = 106 | string 107 | |> and_then (function 108 | | "" -> 109 | succeed () 110 | | _ -> 111 | fail "Expected an empty string" ) 112 | in 113 | decoder_test 114 | ~decoder:(one_of [ ("empty", empty_string |> map (fun () -> None)) ]) 115 | ~input:"\"\"" 116 | ~expected:None 117 | () 118 | in 119 | 120 | let grouping_errors_test = 121 | "grouping errors" 122 | >:: fun _test_ctxt -> 123 | let decoder = 124 | Pipeline.( 125 | decode (fun x y z -> (x, y, z)) 126 | |> required 127 | "records" 128 | (list 129 | ( decode (fun x y z -> (x, y, z)) 130 | |> required "x" (list string) 131 | |> required "y" int 132 | |> required "z" bool ) ) 133 | |> required "hello" int 134 | |> required "another" int) 135 | in 136 | let input = 137 | {| 138 | {"records": [true, {"x": [1, "c", 3], "y": "hello"}], "hello": "world", "another": "error"} 139 | |} 140 | in 141 | let expected_error = 142 | let open Decoders in 143 | Error.tag 144 | {|in field "records"|} 145 | (Error.tag_group 146 | "while decoding a list" 147 | [ Error.tag 148 | "element 0" 149 | (Error.make 150 | {|Expected an object with an attribute "x"|} 151 | ~context:(`Bool true) ) 152 | ; Error.tag 153 | "element 1" 154 | (Error.tag 155 | {|in field "x"|} 156 | (Error.tag_group 157 | "while decoding a list" 158 | [ Error.tag 159 | "element 0" 160 | (Error.make "Expected a string" ~context:(`Int 1)) 161 | ; Error.tag 162 | "element 2" 163 | (Error.make "Expected a string" ~context:(`Int 3)) 164 | ] ) ) 165 | ] ) 166 | in 167 | match decode_string decoder input with 168 | | Ok _ -> 169 | assert_string "Expected an error" 170 | | Error error -> 171 | assert_equal expected_error error ~printer:(fun e -> 172 | Format.asprintf "@,@[%a@]" pp_error e ) 173 | in 174 | 175 | let tupleN_test = 176 | "TupleN" 177 | >:: fun _ -> 178 | let module M = struct 179 | type t2 = int * string 180 | 181 | let t2_to_string ((i, s) : t2) = Printf.sprintf "(%i, %s)" i s 182 | end in 183 | let open M in 184 | decoder_test 185 | () 186 | ~decoder:(tuple2 int string) 187 | ~input:{|[149, "my string"]|} 188 | ~expected:(149, "my string") 189 | ~printer:t2_to_string 190 | in 191 | let empty_list_test = 192 | "empty_list" 193 | >:: fun _ -> 194 | decoder_test 195 | () 196 | ~decoder:empty_list 197 | ~input:{|[]|} 198 | ~expected:() 199 | ~printer:(fun () -> Printf.sprintf "()") 200 | in 201 | let empty_list_nonempty_test = 202 | "empty_list_enforced" 203 | >:: fun _ -> 204 | let input = {|[1, 2]|} in 205 | let expected_error = 206 | let open Decoders in 207 | Error.make ~context:(`List [ `Int 1; `Int 2 ]) "Expected an empty list" 208 | in 209 | match decode_string empty_list input with 210 | | Ok _ -> 211 | assert_string "Expected an error" 212 | | Error error -> 213 | assert_equal expected_error error ~printer:(fun e -> 214 | Format.asprintf "@,@[%a@]" pp_error e ) 215 | in 216 | 217 | "Yojson.Basic" 218 | >::: [ list_string_test 219 | ; array_string_test 220 | ; fix_one_of_test 221 | ; mut_rec_test 222 | ; string_or_floatlit_test 223 | ; grouping_errors_test 224 | ; tupleN_test 225 | ; empty_list_test 226 | ; empty_list_nonempty_test 227 | ] 228 | 229 | 230 | let yojson_raw_suite = 231 | let open Decoders_yojson.Raw.Decode in 232 | let decoder_test ~decoder ~input ~expected _test_ctxt = 233 | match decode_string decoder input with 234 | | Ok value -> 235 | assert_equal value expected 236 | | Error error -> 237 | assert_string (Format.asprintf "%a" pp_error error) 238 | in 239 | 240 | "Yojson.Raw" 241 | >::: [ "list string" 242 | >:: decoder_test 243 | ~decoder:(list string) 244 | ~input:"[\"Hello world\"]" 245 | ~expected:[ "Hello world" ] 246 | ; ( "fix one_of" 247 | >:: fun _ -> 248 | let tree_decoder = 249 | fix (fun tree_decoder -> 250 | let leaf_decoder = int |> map (fun i -> Leaf i) in 251 | let node_decoder = 252 | Pipeline.( 253 | decode (fun left right -> Node (left, right)) 254 | |> required "left" tree_decoder 255 | |> required "right" tree_decoder) 256 | in 257 | one_of [ ("leaf", leaf_decoder); ("node", node_decoder) ] ) 258 | in 259 | decoder_test 260 | ~decoder:tree_decoder 261 | ~input:"{\"left\":1, \"right\":{\"left\":2,\"right\":3}}" 262 | ~expected:(Node (Leaf 1, Node (Leaf 2, Leaf 3))) 263 | () ) 264 | ; ( "string or floatlit" 265 | >:: 266 | let empty_string = 267 | string 268 | |> and_then (function 269 | | "" -> 270 | succeed None 271 | | _ -> 272 | fail "Expected an empty string" ) 273 | in 274 | decoder_test 275 | ~decoder: 276 | (list 277 | (one_of 278 | [ ("empty", empty_string) 279 | ; ("floatlit", floatlit |> map (fun x -> Some x)) 280 | ] ) ) 281 | ~input:{|["", 123, 123.45]|} 282 | ~expected:[ None; Some "123"; Some "123.45" ] ) 283 | ] 284 | 285 | 286 | let () = 287 | "decoders" >::: [ yojson_basic_suite; yojson_raw_suite ] |> run_test_tt_main 288 | --------------------------------------------------------------------------------