├── .gitignore ├── .ocamlformat ├── CHANGES.md ├── CONTRIBUTING.md ├── LICENSE.md ├── Makefile ├── README.org ├── accessor.opam ├── applicative_without_return ├── README.org └── src │ ├── applicative_without_return.ml │ ├── applicative_without_return.mli │ ├── applicative_without_return_intf.ml │ ├── dune │ └── import.ml ├── doc ├── accessor_subtyping_diagram.ml ├── accessor_subtyping_diagram.mli ├── design.org ├── dune └── tutorial.mdx ├── dune-project ├── src ├── accessor.ml ├── accessor.mli ├── applicative_signatures_intf.ml ├── custom_mappings_intf.ml ├── dictionary.ml ├── dictionary.mli ├── dune ├── ident.ml ├── ident.mli ├── import.ml ├── index.ml ├── index.mli ├── many.ml ├── many.mli ├── many_getter.ml ├── many_getter.mli ├── mapping.ml ├── mapping.mli ├── nonempty.ml ├── nonempty.mli ├── nonempty_getter.ml ├── nonempty_getter.mli ├── subtyping.ml ├── subtyping.mli └── subtyping_intf.ml ├── test ├── accessor_tests.ml ├── accessor_tests.mli ├── dune └── import.ml └── test_helpers ├── accessor_test_helpers.ml ├── accessor_test_helpers.mli ├── dune └── import.ml /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | *.install 3 | *.merlin 4 | _opam 5 | 6 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | profile=janestreet 2 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | ## Release v0.17.0 2 | 3 | - `Accessor.add_to_index` 4 | * Adds a value to the index without altering the value 5 | 6 | ## Release v0.16.0 7 | 8 | - `Accessor.dummy` 9 | * Represents a value that is never present 10 | * `get_option dummy` always returns `None` 11 | * `map dummy` is always a no-op 12 | 13 | - `Accessor.disjoint_field_product` 14 | * Combines two `field` accessors into one accessing both inner values at once 15 | * Requires input accessors to access disjoint parts of the outer structure 16 | 17 | - `Accessor.disjoint_merge` 18 | * Combines two `many` accessors into one accessing each inner value accessed by each accessor 19 | * Requires input accessors to access disjoint parts of the outer structure 20 | 21 | - Add hash derivation to the definition of `'a Accessor.Index.t` 22 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | This repository contains open source software that is developed and 2 | maintained by [Jane Street][js]. 3 | 4 | Contributions to this project are welcome and should be submitted via 5 | GitHub pull requests. 6 | 7 | Signing contributions 8 | --------------------- 9 | 10 | We require that you sign your contributions. Your signature certifies 11 | that you wrote the patch or otherwise have the right to pass it on as 12 | an open-source patch. The rules are pretty simple: if you can certify 13 | the below (from [developercertificate.org][dco]): 14 | 15 | ``` 16 | Developer Certificate of Origin 17 | Version 1.1 18 | 19 | Copyright (C) 2004, 2006 The Linux Foundation and its contributors. 20 | 1 Letterman Drive 21 | Suite D4700 22 | San Francisco, CA, 94129 23 | 24 | Everyone is permitted to copy and distribute verbatim copies of this 25 | license document, but changing it is not allowed. 26 | 27 | 28 | Developer's Certificate of Origin 1.1 29 | 30 | By making a contribution to this project, I certify that: 31 | 32 | (a) The contribution was created in whole or in part by me and I 33 | have the right to submit it under the open source license 34 | indicated in the file; or 35 | 36 | (b) The contribution is based upon previous work that, to the best 37 | of my knowledge, is covered under an appropriate open source 38 | license and I have the right under that license to submit that 39 | work with modifications, whether created in whole or in part 40 | by me, under the same open source license (unless I am 41 | permitted to submit under a different license), as indicated 42 | in the file; or 43 | 44 | (c) The contribution was provided directly to me by some other 45 | person who certified (a), (b) or (c) and I have not modified 46 | it. 47 | 48 | (d) I understand and agree that this project and the contribution 49 | are public and that a record of the contribution (including all 50 | personal information I submit with it, including my sign-off) is 51 | maintained indefinitely and may be redistributed consistent with 52 | this project or the open source license(s) involved. 53 | ``` 54 | 55 | Then you just add a line to every git commit message: 56 | 57 | ``` 58 | Signed-off-by: Joe Smith 59 | ``` 60 | 61 | Use your real name (sorry, no pseudonyms or anonymous contributions.) 62 | 63 | If you set your `user.name` and `user.email` git configs, you can sign 64 | your commit automatically with git commit -s. 65 | 66 | [dco]: http://developercertificate.org/ 67 | [js]: https://opensource.janestreet.com/ 68 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | The MIT License 2 | 3 | Copyright (c) 2020--2025 Jane Street Group, LLC 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | INSTALL_ARGS := $(if $(PREFIX),--prefix $(PREFIX),) 2 | 3 | default: 4 | dune build 5 | 6 | install: 7 | dune install $(INSTALL_ARGS) 8 | 9 | uninstall: 10 | dune uninstall $(INSTALL_ARGS) 11 | 12 | reinstall: uninstall install 13 | 14 | clean: 15 | dune clean 16 | 17 | .PHONY: default install uninstall reinstall clean 18 | -------------------------------------------------------------------------------- /README.org: -------------------------------------------------------------------------------- 1 | 2 | The ~Accessor~ library makes it nicer to work with nested functional data 3 | structures. 4 | 5 | An accessor is a value that understands how to reach data within a 6 | larger data structure, independently from what you intend to do with 7 | it. Accessors allow you to read and write data and perform 8 | possibly-monadic traversals. By composing accessors, you can work with 9 | increasingly complex data structures. 10 | 11 | In case you have ever heard of "lenses", this is an OCaml 12 | implementation of that idea. 13 | 14 | See the [[./doc/tutorial.mdx][tutorial]] for more information. 15 | -------------------------------------------------------------------------------- /accessor.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Jane Street developers" 3 | authors: ["Jane Street Group, LLC"] 4 | homepage: "https://github.com/janestreet/accessor" 5 | bug-reports: "https://github.com/janestreet/accessor/issues" 6 | dev-repo: "git+https://github.com/janestreet/accessor.git" 7 | doc: "https://ocaml.janestreet.com/ocaml-core/latest/doc/accessor/index.html" 8 | license: "MIT" 9 | build: [ 10 | ["dune" "build" "-p" name "-j" jobs] 11 | ] 12 | depends: [ 13 | "ocaml" {>= "5.1.0"} 14 | "base" 15 | "higher_kinded" 16 | "ppx_jane" 17 | "dune" {>= "3.17.0"} 18 | ] 19 | available: arch != "arm32" & arch != "x86_32" 20 | synopsis: "A library that makes it nicer to work with nested functional data structures" 21 | description: " 22 | An accessor is a value that understands how to reach data within a larger data structure, 23 | independently from what you intend to do with it. Accessors allow you to read and write 24 | data and perform possibly-monadic traversals. By composing accessors, you can work with 25 | increasingly complex data structures. 26 | 27 | In case you have ever heard of \"lenses\", this is an OCaml implementation of that idea. 28 | " 29 | -------------------------------------------------------------------------------- /applicative_without_return/README.org: -------------------------------------------------------------------------------- 1 | 2 | A library with a version of ~Base.Applicative~ which lacks ~return~. 3 | -------------------------------------------------------------------------------- /applicative_without_return/src/applicative_without_return.ml: -------------------------------------------------------------------------------- 1 | open! Base 2 | open! Import 3 | include Applicative_without_return_intf 4 | 5 | module Make3 (X : Basic3) : S3 with type ('a, 'd, 'e) t := ('a, 'd, 'e) X.t = struct 6 | include X 7 | 8 | let ( <*> ) = apply 9 | let ( >>| ) t f = map t ~f 10 | let map2 ta tb ~f = map ~f ta <*> tb 11 | let map3 ta tb tc ~f = map ~f ta <*> tb <*> tc 12 | let both ta tb = map2 ta tb ~f:(fun a b -> a, b) 13 | 14 | module Applicative_infix = struct 15 | let ( <*> ) = ( <*> ) 16 | let ( >>| ) = ( >>| ) 17 | end 18 | 19 | module Let_syntax = struct 20 | include Applicative_infix 21 | 22 | module Let_syntax = struct 23 | let map = map 24 | let both = both 25 | 26 | module Open_on_rhs = struct end 27 | end 28 | end 29 | end 30 | 31 | module Make2 (X : Basic2) : S2 with type ('a, 'e) t := ('a, 'e) X.t = Make3 (struct 32 | type ('a, _, 'e) t = ('a, 'e) X.t 33 | 34 | include (X : module type of X with type ('a, 'e) t := ('a, 'e) X.t) 35 | end) 36 | 37 | module Make (X : Basic) : S with type 'a t := 'a X.t = Make2 (struct 38 | type ('a, _) t = 'a X.t 39 | 40 | include (X : module type of X with type 'a t := 'a X.t) 41 | end) 42 | -------------------------------------------------------------------------------- /applicative_without_return/src/applicative_without_return.mli: -------------------------------------------------------------------------------- 1 | include Applicative_without_return_intf.Applicative_without_return 2 | -------------------------------------------------------------------------------- /applicative_without_return/src/applicative_without_return_intf.ml: -------------------------------------------------------------------------------- 1 | open! Base 2 | open! Import 3 | 4 | module type Basic3 = sig 5 | type ('a, 'd, 'e) t 6 | 7 | val apply : ('a -> 'b, 'd, 'e) t -> ('a, 'd, 'e) t -> ('b, 'd, 'e) t 8 | val map : ('a, 'd, 'e) t -> f:('a -> 'b) -> ('b, 'd, 'e) t 9 | end 10 | 11 | module type Basic2 = sig 12 | type ('a, 'e) t 13 | 14 | include Basic3 with type ('a, _, 'e) t := ('a, 'e) t 15 | end 16 | 17 | module type Basic = sig 18 | type 'a t 19 | 20 | include Basic2 with type ('a, _) t := 'a t 21 | end 22 | 23 | module type S3_without_let_syntax = sig 24 | type ('a, 'd, 'e) t 25 | 26 | val apply : ('a -> 'b, 'd, 'e) t -> ('a, 'd, 'e) t -> ('b, 'd, 'e) t 27 | val map : ('a, 'd, 'e) t -> f:('a -> 'b) -> ('b, 'd, 'e) t 28 | val map2 : ('a, 'd, 'e) t -> ('b, 'd, 'e) t -> f:('a -> 'b -> 'c) -> ('c, 'd, 'e) t 29 | 30 | val map3 31 | : ('a, 'd, 'e) t 32 | -> ('b, 'd, 'e) t 33 | -> ('c, 'd, 'e) t 34 | -> f:('a -> 'b -> 'c -> 'f) 35 | -> ('f, 'd, 'e) t 36 | 37 | val both : ('a, 'd, 'e) t -> ('b, 'd, 'e) t -> ('a * 'b, 'd, 'e) t 38 | 39 | module Applicative_infix : sig 40 | val ( <*> ) : ('a -> 'b, 'd, 'e) t -> ('a, 'd, 'e) t -> ('b, 'd, 'e) t 41 | val ( >>| ) : ('a, 'd, 'e) t -> ('a -> 'b) -> ('b, 'd, 'e) t 42 | end 43 | 44 | include module type of Applicative_infix 45 | end 46 | 47 | module type S2_without_let_syntax = sig 48 | type ('a, 'e) t 49 | 50 | include S3_without_let_syntax with type ('a, _, 'e) t := ('a, 'e) t 51 | end 52 | 53 | module type S_without_let_syntax = sig 54 | type 'a t 55 | 56 | include S2_without_let_syntax with type ('a, _) t := 'a t 57 | end 58 | 59 | module type S3 = sig 60 | include S3_without_let_syntax 61 | 62 | module Let_syntax : sig 63 | include module type of Applicative_infix 64 | 65 | module Let_syntax : sig 66 | val map : ('a, 'd, 'e) t -> f:('a -> 'b) -> ('b, 'd, 'e) t 67 | val both : ('a, 'd, 'e) t -> ('b, 'd, 'e) t -> ('a * 'b, 'd, 'e) t 68 | 69 | module Open_on_rhs : sig end 70 | end 71 | end 72 | end 73 | 74 | module type S2 = sig 75 | type ('a, 'e) t 76 | 77 | include S3 with type ('a, _, 'e) t := ('a, 'e) t 78 | end 79 | 80 | module type S = sig 81 | type 'a t 82 | 83 | include S2 with type ('a, _) t := 'a t 84 | end 85 | 86 | module type Applicative_without_return = sig 87 | module type Basic = Basic 88 | module type Basic2 = Basic2 89 | module type Basic3 = Basic3 90 | module type S_without_let_syntax = S_without_let_syntax 91 | module type S2_without_let_syntax = S2_without_let_syntax 92 | module type S3_without_let_syntax = S3_without_let_syntax 93 | module type S = S 94 | module type S2 = S2 95 | module type S3 = S3 96 | 97 | module Make (B : Basic) : S with type 'a t := 'a B.t 98 | module Make2 (B : Basic2) : S2 with type ('a, 'e) t := ('a, 'e) B.t 99 | module Make3 (B : Basic3) : S3 with type ('a, 'd, 'e) t := ('a, 'd, 'e) B.t 100 | end 101 | -------------------------------------------------------------------------------- /applicative_without_return/src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name applicative_without_return) 3 | (public_name accessor.applicative_without_return) 4 | (libraries base) 5 | (preprocess 6 | (pps ppx_jane))) 7 | -------------------------------------------------------------------------------- /applicative_without_return/src/import.ml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/janestreet/accessor/f8be09f84db0ccde2a5b1c7b1dc4b9965838408f/applicative_without_return/src/import.ml -------------------------------------------------------------------------------- /doc/accessor_subtyping_diagram.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | 3 | module Color = struct 4 | module T = struct 5 | type t = 6 | | Red 7 | | Orange 8 | | Gold 9 | | Green 10 | | Blue 11 | | Indigo 12 | [@@deriving compare, sexp_of] 13 | end 14 | 15 | include T 16 | include Comparable.Make_plain (T) 17 | 18 | let to_string t = String.lowercase (Sexp.to_string [%sexp (t : t)]) 19 | end 20 | 21 | module Feature = struct 22 | module T = struct 23 | type t = 24 | [ `at_least_one 25 | | `at_most_one 26 | | `coerce 27 | | `construct 28 | | `get 29 | | `map 30 | ] 31 | [@@deriving compare, enumerate, sexp_of] 32 | end 33 | 34 | include T 35 | include Comparable.Make_plain (T) 36 | 37 | let color : t -> Color.t = function 38 | | `at_least_one -> Red 39 | | `at_most_one -> Orange 40 | | `coerce -> Gold 41 | | `construct -> Green 42 | | `get -> Blue 43 | | `map -> Indigo 44 | ;; 45 | 46 | let color_set ts = Core.Set.map (module Color) ts ~f:color 47 | 48 | let to_string t = 49 | String.substr_replace_all (Sexp.to_string ([%sexp_of: t] t)) ~pattern:"_" ~with_:" " 50 | ;; 51 | 52 | let legend = 53 | let label = 54 | List.map all ~f:(fun t -> 55 | String.concat 56 | [ {||} 59 | ; to_string t 60 | ; {|
|} 61 | ]) 62 | |> String.concat 63 | in 64 | String.concat 65 | [ {| 66 | subgraph cluster_01 { 67 | node [shape=plaintext] 68 | label = "Legend"; 69 | legend [label=<|} 70 | ; label 71 | ; {|>] 72 | }|} 73 | ] 74 | ;; 75 | end 76 | 77 | module Feature_set = struct 78 | module T = Feature.Set 79 | include T 80 | include Comparable.Make_plain (T) 81 | end 82 | 83 | module Subtyping = struct 84 | type constructor = [ `construct ] [@@deriving enumerate] 85 | 86 | let constructor_features = Feature.Set.of_list (all_of_constructor :> Feature.t list) 87 | 88 | type equality = 89 | [ `get 90 | | `map 91 | | `at_most_one 92 | | `at_least_one 93 | | `construct 94 | | `coerce 95 | ] 96 | [@@deriving enumerate] 97 | 98 | let equality_features = Feature.Set.of_list (all_of_equality :> Feature.t list) 99 | 100 | type field = 101 | [ `get 102 | | `map 103 | | `at_most_one 104 | | `at_least_one 105 | ] 106 | [@@deriving enumerate] 107 | 108 | let field_features = Feature.Set.of_list (all_of_field :> Feature.t list) 109 | 110 | type getter = 111 | [ `get 112 | | `at_least_one 113 | | `at_most_one 114 | ] 115 | [@@deriving enumerate] 116 | 117 | let getter_features = Feature.Set.of_list (all_of_getter :> Feature.t list) 118 | 119 | type isomorphism = 120 | [ `get 121 | | `map 122 | | `at_most_one 123 | | `at_least_one 124 | | `construct 125 | ] 126 | [@@deriving enumerate] 127 | 128 | let isomorphism_features = Feature.Set.of_list (all_of_isomorphism :> Feature.t list) 129 | 130 | type many = 131 | [ `get 132 | | `map 133 | ] 134 | [@@deriving enumerate] 135 | 136 | let many_features = Feature.Set.of_list (all_of_many :> Feature.t list) 137 | 138 | type many_getter = [ `get ] [@@deriving enumerate] 139 | 140 | let many_getter_features = Feature.Set.of_list (all_of_many_getter :> Feature.t list) 141 | 142 | type mapper = [ `map ] [@@deriving enumerate] 143 | 144 | let mapper_features = Feature.Set.of_list (all_of_mapper :> Feature.t list) 145 | 146 | type nonempty = 147 | [ `get 148 | | `map 149 | | `at_least_one 150 | ] 151 | [@@deriving enumerate] 152 | 153 | let nonempty_features = Feature.Set.of_list (all_of_nonempty :> Feature.t list) 154 | 155 | type nonempty_getter = 156 | [ `get 157 | | `at_least_one 158 | ] 159 | [@@deriving enumerate] 160 | 161 | let nonempty_getter_features = 162 | Feature.Set.of_list (all_of_nonempty_getter :> Feature.t list) 163 | ;; 164 | 165 | type optional = 166 | [ `get 167 | | `map 168 | | `at_most_one 169 | ] 170 | [@@deriving enumerate] 171 | 172 | let optional_features = Feature.Set.of_list (all_of_optional :> Feature.t list) 173 | 174 | type optional_getter = 175 | [ `get 176 | | `at_most_one 177 | ] 178 | [@@deriving enumerate] 179 | 180 | let optional_getter_features = 181 | Feature.Set.of_list (all_of_optional_getter :> Feature.t list) 182 | ;; 183 | 184 | type variant = 185 | [ `get 186 | | `map 187 | | `at_most_one 188 | | `construct 189 | ] 190 | [@@deriving enumerate] 191 | 192 | let variant_features = Feature.Set.of_list (all_of_variant :> Feature.t list) 193 | end 194 | 195 | open ( 196 | struct 197 | module _ : module type of Accessor.Subtyping = Subtyping 198 | end : 199 | sig end) 200 | 201 | module Named_kind = struct 202 | type t = 203 | | Constructor 204 | | Equality 205 | | Field 206 | | Getter 207 | | Isomorphism 208 | | Many 209 | | Many_getter 210 | | Mapper 211 | | Nonempty 212 | | Nonempty_getter 213 | | Optional 214 | | Optional_getter 215 | | Variant 216 | [@@deriving enumerate, sexp_of] 217 | 218 | let name t = String.lowercase (Sexp.to_string [%sexp (t : t)]) 219 | 220 | let features = 221 | let open Subtyping in 222 | function 223 | | Constructor -> constructor_features 224 | | Equality -> equality_features 225 | | Field -> field_features 226 | | Getter -> getter_features 227 | | Isomorphism -> isomorphism_features 228 | | Many -> many_features 229 | | Many_getter -> many_getter_features 230 | | Mapper -> mapper_features 231 | | Nonempty -> nonempty_features 232 | | Nonempty_getter -> nonempty_getter_features 233 | | Optional -> optional_features 234 | | Optional_getter -> optional_getter_features 235 | | Variant -> variant_features 236 | ;; 237 | 238 | let functions : t -> string list = function 239 | | Constructor -> [ "construct" ] 240 | | Equality -> [ "identical" ] 241 | | Field -> [] 242 | | Getter -> [ "get" ] 243 | | Isomorphism -> [ "invert" ] 244 | | Many -> [ "Applicative.map" ] 245 | | Many_getter -> 246 | [ "fold"; "iter"; "to_list"; "map_reduce"; "Applicative.fold"; "Applicative.iter" ] 247 | | Mapper -> [ "map"; "set" ] 248 | | Nonempty -> [] 249 | | Nonempty_getter -> [ "map_reduce_nonempty" ] 250 | | Optional -> [ "match_" ] 251 | | Optional_getter -> [ "get_option" ] 252 | | Variant -> [] 253 | ;; 254 | 255 | let label t = 256 | let format string ~size = 257 | String.concat [ ""; string; "" ] 258 | in 259 | let name = format (name t) ~size:14 in 260 | match functions t with 261 | | [] -> name 262 | | functions -> 263 | String.concat 264 | ([ name; "|" ] 265 | @ List.map functions ~f:(fun f -> format f ~size:10 ^ "
")) 266 | ;; 267 | 268 | let node kind = 269 | printf 270 | "%s [shape=Mrecord, fontname=\"Monospace\", label=<{%s}>]\n" 271 | (name kind) 272 | (label kind) 273 | ;; 274 | end 275 | 276 | module Kind = struct 277 | type t = 278 | | Named of Named_kind.t 279 | | Unnamed of Feature.Set.t 280 | 281 | let unnamed_node_name ~features = 282 | String.concat [ "\""; Sexp.to_string_mach [%sexp (features : Feature.Set.t)]; "\"" ] 283 | ;; 284 | 285 | let name = function 286 | | Named kind -> Named_kind.name kind 287 | | Unnamed features -> unnamed_node_name ~features 288 | ;; 289 | 290 | let features = function 291 | | Named kind -> Named_kind.features kind 292 | | Unnamed features -> features 293 | ;; 294 | 295 | let colors t = Feature.color_set (features t) 296 | let is_subtype t ~of_ = Set.is_subset (features t) ~of_:(features of_) 297 | 298 | let node = function 299 | | Named kind -> Named_kind.node kind 300 | | Unnamed features -> print_endline (unnamed_node_name ~features ^ " [label=\"?\"]") 301 | ;; 302 | 303 | let all = 304 | let named = List.map Named_kind.all ~f:(fun kind -> Named kind) in 305 | let unnamed = 306 | let unnamed_feature_sets = 307 | let open List.Let_syntax in 308 | let named_feature_sets = 309 | List.map Named_kind.all ~f:Named_kind.features |> Feature_set.Set.of_list 310 | in 311 | let%bind a = Named_kind.all 312 | and b = Named_kind.all in 313 | let candidate = Set.inter (Named_kind.features a) (Named_kind.features b) in 314 | if Set.mem named_feature_sets candidate then [] else return candidate 315 | in 316 | unnamed_feature_sets 317 | |> List.filter ~f:(fun features -> not (Set.is_empty features)) 318 | |> List.dedup_and_sort ~compare:Feature_set.compare 319 | |> List.map ~f:(fun features -> Unnamed features) 320 | in 321 | named @ unnamed 322 | ;; 323 | end 324 | 325 | module Edge = struct 326 | type t = 327 | { source : Kind.t 328 | ; target : Kind.t 329 | } 330 | 331 | let to_string { source; target } = 332 | sprintf 333 | "%s -> %s [color=\"%s\", arrowhead=none, penwidth=2]" 334 | (Kind.name source) 335 | (Kind.name target) 336 | (Set.diff (Kind.colors source) (Kind.colors target) 337 | |> Set.to_list 338 | |> List.map ~f:Color.to_string 339 | |> String.concat ~sep:":invis:") 340 | ;; 341 | end 342 | 343 | let edges = 344 | let open List.Let_syntax in 345 | let%bind source = Kind.all 346 | and target = Kind.all in 347 | let%map () = if Kind.is_subtype target ~of_:source then return () else [] in 348 | { Edge.source; target } 349 | ;; 350 | 351 | let () = 352 | print_endline "digraph G {"; 353 | List.iter Kind.all ~f:Kind.node; 354 | List.iter edges ~f:(fun edge -> print_endline (Edge.to_string edge)); 355 | print_endline Feature.legend; 356 | print_endline "}" 357 | ;; 358 | -------------------------------------------------------------------------------- /doc/accessor_subtyping_diagram.mli: -------------------------------------------------------------------------------- 1 | (*_ This signature is deliberately empty. *) 2 | -------------------------------------------------------------------------------- /doc/design.org: -------------------------------------------------------------------------------- 1 | 2 | This document aims to bring a developer up to speed for understanding the 3 | /implementation/ of ~Accessor~. If you are just trying to understand how to use 4 | it, try the [[./tutorial.mdx][tutorial]] instead. 5 | 6 | If you intend to read this document but haven't read the [[./tutorial.mdx][tutorial]] yet, you 7 | should read it first. 8 | 9 | * History 10 | 11 | ~Accessors~ is inspired by a long history of developments on "lenses", mostly 12 | in the Haskell world. There are many other relevant developments by many other 13 | people that are omitted here. This is only trying to trace the most direct 14 | lineage of the idea as experienced by me. 15 | 16 | ** 2006: The Essence of the Iterator Pattern 17 | 18 | In "The Essence of the Iterator Pattern," Gibbons and Oliveira highlight that 19 | the ~Traversable~ type class that was relatively recently introduced in 20 | Haskell is a functional version of the Iterator pattern (as in the Gang of 21 | Four design pattern by the same name). I see this as early recognition and 22 | embracing of the idea that it's about "accessing" data. 23 | 24 | [[http://www.cs.ox.ac.uk/jeremy.gibbons/publications/iterator.pdf][The Essence of the Iterator Pattern]] 25 | 26 | Here is a simplified definition of the ~Traversable~ type class, along with 27 | the type classes it depends on. 28 | 29 | #+BEGIN_SRC haskell 30 | class Semigroup a where 31 | (<>) :: a -> a -> a 32 | 33 | class Semigroup a => Monoid a where 34 | mempty :: a 35 | 36 | class Functor f where 37 | fmap :: (a -> b) -> f a -> f b 38 | 39 | class Functor f => Applicative f where 40 | pure :: a -> f a 41 | (<*>) :: f (a -> b) -> f a -> f b 42 | 43 | class Foldable t where 44 | foldMap :: Monoid m => (a -> m) -> t a -> m 45 | 46 | class (Functor t, Foldable t) => Traversable t where 47 | traverse :: Applicative f => (a -> f b) -> t a -> f (t b) 48 | #+END_SRC 49 | 50 | One well-known (at Jane Street) example of a ~traverse~-like function in 51 | OCaml is ~Deferred.List.map~. The corresponding ~Traversable~ instance would 52 | instantiate ~t~ as ~list~, and the call site of ~traverse~ would instantiate 53 | the applicative ~f~ as ~Deferred.t~. ~traverse~ happens to be much more 54 | polymorphic, but the basic idea is the same. 55 | 56 | ** 2007: Making Haskell nicer for game programming, Haskell State Accessors 57 | 58 | In a series of blog posts, Luke Palmer invents an abstraction 59 | called an "accessor". 60 | 61 | - [[http://web.archive.org/web/20080515203207/http://luqui.org/blog/archives/2007/07/26/making-haskell-nicer-for-game-programming/][Making Haskell Nicer for Game Programming]] 62 | - [[http://web.archive.org/web/20071023064034/http://luqui.org/blog/archives/2007/08/05/haskell-state-accessors-second-attempt-composability/][Haskell State Accessors (second attempt: Composability)]] 63 | 64 | In the first post, an accessor is represented something like this: 65 | 66 | #+BEGIN_SRC haskell 67 | data Accessor s a 68 | = Accessor 69 | { readVal :: State s a 70 | , writeVal :: a -> State s () 71 | } 72 | #+END_SRC 73 | 74 | Here, ~State~ is a monad for performing transformations on some purely 75 | functional state: 76 | 77 | #+BEGIN_SRC haskell 78 | newtype State s a = State (s -> (a, s)) 79 | #+END_SRC 80 | 81 | Palmer constructs several operations for working with accessors in the rest 82 | of the first post. The second blog post covers making them compose, changing 83 | the representation to this: 84 | 85 | #+BEGIN_SRC haskell 86 | data Accessor s a 87 | = Accessor 88 | { getVal :: s -> a 89 | , setVal :: a -> s -> s 90 | } 91 | #+END_SRC 92 | 93 | and defining composition like this: 94 | 95 | #+BEGIN_SRC haskell 96 | (@.) :: Accessor a b -> Accessor b c -> Accessor a c 97 | f @. g = 98 | Accessor 99 | { getVal = getVal g . getVal f 100 | , setVal = c a -> setVal f (setVal g c (getVal f a)) a 101 | } 102 | #+END_SRC 103 | 104 | There is also a notable mention of /laws/ that must hold in order for an 105 | ~Accessor~ to behave as an actual accessor. 106 | 107 | #+BEGIN_SRC haskell 108 | getVal accessor (setVal accessor a s) == a 109 | setVal accessor (getVal accessor s) s == s 110 | #+END_SRC 111 | 112 | In our OCaml implementation, accessors that behave the way Palmer's did are 113 | called "field" accessors, and there is a third law in addition to the above 114 | two. 115 | 116 | ** 2008: Semantic Editor Combinators 117 | 118 | Conal Elliott blogs about an idea he calls "semantic editor combinators". 119 | 120 | [[http://conal.net/blog/posts/semantic-editor-combinators][Semantic Editor Combinators]] 121 | 122 | An editor combinator is essentially a function transformer. The observation 123 | is that you can compose simple function transformers to create more complex 124 | ones in a way that results in quite readable code, so you can conveniently 125 | reach into complex data structures to make modifications. ~fmap~ is the most 126 | common editor combinator in his post. He doesn't highlight this, but the 127 | ~traverse~ function described earlier is also a good editor combinator. 128 | 129 | ** 2009: CPS based functional references 130 | 131 | Twan van Laarhoven blogs about a novel way of representing "functional 132 | references". 133 | 134 | [[https://www.twanvl.nl/blog/haskell/cps-functional-references][CPS based functional references]] 135 | 136 | #+BEGIN_SRC haskell 137 | type RefF a b = forall f. Functor f => (b -> f b) -> (a -> f a) 138 | #+END_SRC 139 | 140 | At first glance it seems to have absolutely nothing to do with the ~Accessor~ 141 | type Palmer defined, but it turns out that they are exactly isomorphic. The 142 | following code witnesses the isomorphism (though it doesn't come from the 143 | blog post): 144 | 145 | #+BEGIN_SRC haskell 146 | create :: (s -> a) -> (a -> s -> s) -> RefF s a 147 | create get set f s = fmap (\a -> set a s) (f (get s)) 148 | 149 | accessorToRefF :: Accessor s a -> RefF s a 150 | accessorToRefF (Accessor get set) = create get set 151 | 152 | refFToAccessor :: RefF s a -> Accessor s a 153 | refFToAccessor refF = Accessor get set 154 | where 155 | get s = getConst (refF Const s) 156 | set a s = runIdentity (refF (Identity . const a) s) 157 | #+END_SRC 158 | 159 | where the following types come from the standard library: 160 | 161 | #+BEGIN_SRC haskell 162 | newtype Identity a = Identity { runIdentity :: a } 163 | 164 | newtype Const a b = Const { getConst :: a } 165 | #+END_SRC 166 | 167 | with the following ~Functor~ instances: 168 | 169 | #+BEGIN_SRC haskell 170 | instance Functor Identity where 171 | fmap f (Identity a) = Identity (f a) 172 | 173 | instance Functor (Const a) where 174 | fmap f (Const a) = Const a 175 | #+END_SRC 176 | 177 | Like Palmer's accessors, van Laarhoven's functional references are 178 | composable. However, unlike the former, van Laarhoven's version is composable 179 | using plain old function composition, the same way Conal's semantic editor 180 | combinators compose. 181 | 182 | My guess is that the way he came up with this is by seeing what 183 | happened when replacing the ~Applicative~ constraint in the type of 184 | ~traverse~ with ~Functor~. 185 | 186 | This style eventually became known as "van Laarhoven lenses". 187 | 188 | ** 2012: Polymorphic Update with van Laarhoven Lenses 189 | 190 | Russell O'Connor approaches the problem of "polymorphic update". 191 | 192 | [[http://r6.ca/blog/20120623T104901Z.html][Polymorphic Update with van Laarhoven Lenses]] 193 | 194 | Suppose we have a lens that accesses the first component of a tuple: 195 | 196 | #+BEGIN_SRC haskell 197 | fstLens :: RefF (a, b) a 198 | fstLens = create fst (\a (_, b) -> (a, b)) 199 | #+END_SRC 200 | 201 | This lens allows you to modify the value of the first component of any tuple, 202 | regardless of its type, so in that sense it is polymorphic. However, it does 203 | not allow you to change the type of the first component of a tuple. 204 | 205 | O'Connor noticed that if you simply omit the type signature for the 206 | above-defined ~create~ function, you get a more general type: 207 | 208 | #+BEGIN_SRC haskell 209 | let create get set f s = fmap (\a -> set a s) (f (get s)) 210 | :t create 211 | #+END_SRC 212 | 213 | #+RESULTS: 214 | : create 215 | : :: Functor f => 216 | : (t1 -> t) -> (a -> t1 -> b) -> (t -> f a) -> t1 -> f b 217 | 218 | Rearranging and renaming a bit, we get something that a bit more closely 219 | resembles the original type signature: 220 | 221 | #+BEGIN_SRC haskell 222 | (s -> a) -> (b -> s -> t) -> (forall f. Functor f => (a -> f b) -> (s -> f t)) 223 | #+END_SRC 224 | 225 | Defining ~fstLens~ with this function is also more general: 226 | 227 | #+BEGIN_SRC haskell 228 | fstLens :: Functor f => (a -> f b) -> (a, c) -> f (b, c) 229 | fstLens = create fst (\a (_, b) -> (a, b)) 230 | #+END_SRC 231 | 232 | It turns out that van Laarhoven lenses already supported polymorphism if only 233 | they hadn't been type constrained by hand. 234 | 235 | ** 2012: Mirrored Lenses 236 | 237 | The very next day, Ed Kmett publishes a blog post about how such polymorphic 238 | lenses, which at the point he is calling "lens families", are still perfectly 239 | reasonable to impose the "lens laws" on, and that the lens laws just imply 240 | that the polymorphism isn't quite as unconstrained as it appears. 241 | 242 | [[http://comonad.com/reader/2012/mirrored-lenses/][Mirrored Lenses]] 243 | 244 | He also starts exploring using specializations of ~Functor~ to define more 245 | specialized lenses. 246 | 247 | ** 2012: The lens Haskell library 248 | 249 | The day after publishing his Mirrored Lenses post, Ed Kmett releases the 250 | first version of the lens library to Hackage. Within just a few days, several 251 | versions were released, including some that started toying around with the 252 | representation to make more things representable, like isomorphisms. Here was 253 | original type definition for isomorphisms: 254 | 255 | #+BEGIN_SRC haskell 256 | type Iso a b c d = forall k f. (Isomorphic k, Functor f) => k (c -> f d) (a -> f b) 257 | #+END_SRC 258 | 259 | It used the following, rather ad hoc in my opinion, type class (don't study 260 | it too hard, as we won't be using it beyond this section): 261 | 262 | #+BEGIN_SRC haskell 263 | class Category k => Isomorphic k where 264 | isomorphic :: (a -> b) -> (b -> a) -> k a b 265 | isomap :: ((a -> b) -> c -> d) -> ((b -> a) -> d -> c) -> k a b -> k c d 266 | #+END_SRC 267 | 268 | This was instantiated by two types. One was just for isomorphisms: 269 | 270 | #+BEGIN_SRC haskell 271 | data Isomorphism a b = Isomorphism (a -> b) (b -> a) 272 | #+END_SRC 273 | 274 | The other instance was for plain Haskell functions. This was the magical 275 | part. It meant that isomorphisms could be composed with other isomorphisms, 276 | leaving them as isomorphisms, but they could also be composed with lenses, 277 | forcing that ~k~ type to become ~(->)~, resulting in just plain lenses! 278 | 279 | A few months later, v1.8 is published. This version is noteworthy only 280 | because it is the first version to include a diagram on its project page 281 | showing the subtyping hierarchy of various lenses. 282 | 283 | By December, a version was released that included ~Prism~ (which in our 284 | ~Accessor~ library is called a ~variant~ accessor). It followed a similar 285 | template to ~Iso~. 286 | 287 | January of 2013 saw the introduction of profunctors in the lens library, 288 | overhauling how ~Iso~ and ~Prism~ are represented. Here is the new definition 289 | for ~Iso~, and how it remains today: 290 | 291 | #+BEGIN_SRC haskell 292 | type Iso s t a b = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t) 293 | #+END_SRC 294 | 295 | Here is the ~Profunctor~ type class: 296 | 297 | #+BEGIN_SRC haskell 298 | class Profunctor p where 299 | dimap :: (a -> b) -> (c -> d) -> p b c -> p a d 300 | #+END_SRC 301 | 302 | From here, there were numerous discoveries leading to a fairly coherent 303 | theory of lenses based solely on various specializations of ~Profunctor~, 304 | without the ~Functor~ type. That is, as far as I am aware, the evolution from 305 | van Laarhoven lenses to so-called "profunctor optics" went like this: 306 | 307 | #+BEGIN_SRC haskell 308 | type Optic c s t a b = forall f. c f => (a -> f b) -> (s -> f t) 309 | 310 | type Optic cp cf s t a b = forall p f. (cp p, cf f) => p a (f b) -> p s (f t) 311 | 312 | type Optic c s t a b = forall p. c p => p a b -> p s t 313 | #+END_SRC 314 | 315 | The Haskell lens library never transitioned fully to the profunctor-only 316 | representation because van Laarhoven lenses happen to fit very well with 317 | existing Haskell functions such that you can simply use those existing 318 | functions /as/ optics, such as ~fmap~ and ~traverse~, but most newer optics 319 | libraries are based on profunctors. 320 | 321 | ** 2016: Profunctor Optics: Modular Data Accessors 322 | 323 | Profunctor optics continued to evolve fairly organically on the Internet 324 | without much involvement from academia. Eventually, Pickering, Gibbons, and 325 | Wu published a pretty great paper documenting the idea. 326 | 327 | [[https://arxiv.org/pdf/1703.10857.pdf][Profunctor Optics: Modular Data Accessors]] 328 | 329 | There isn't much new in there, but it's worth mentioning here just because it 330 | collects a lot of information in one place. 331 | 332 | * Our Implementation 333 | 334 | ~Accessor~ has a profunctor optics inspired representation. For reference, 335 | here is the Haskell-style representation of a generic profunctor optic, again: 336 | 337 | #+BEGIN_SRC haskell 338 | type Optic c s t a b = forall p. c p => p a b -> p s t 339 | #+END_SRC 340 | 341 | ** Just getting it working 342 | 343 | There have been attempts to implement lenses in OCaml before, both van 344 | Laarhoven style and profunctor style, but the combination of features used in 345 | the Haskell encoding are difficult to emulate: 346 | 347 | - higher rank types (universal quantification) without boxing 348 | - no value restriction 349 | - higher kinded types (polymorphic type constructors) 350 | - type classes 351 | 352 | *** Higher rank types 353 | 354 | In OCaml, the only way to define a higher rank type is by making it a record 355 | field or put it in a first class module. In some terrible syntax resembling 356 | OCaml with higher kinded types and type classes, that turns the above Haskell 357 | type into something like this: 358 | 359 | #+BEGIN_SRC ocaml 360 | type ('c, 's, 't, 'a, 'b) optic = { f : 'p. 'p 'c => ('a, 'b) 'p -> ('s, 't) 'p } 361 | #+END_SRC 362 | 363 | What does this cost us? In Haskell, normal function composition, which is 364 | conveniently just ~(.)~, can be used to compose lenses. With the record 365 | wrapper, this is no longer true. This doesn't seem like a significant loss at 366 | all. 367 | 368 | We also gained something by boxing it up this way. Types and type errors are 369 | significantly easier to read. This difficulty just happens to force us into a 370 | good decision. 371 | 372 | *** Living with the value restriction 373 | 374 | Haskell, lacking uncontrolled mutation, has no need for the value 375 | restriction, so you can freely define polymorphic functions as expressions. 376 | In OCaml, though, composing polymorphic values can be trickier. Accessors 377 | are meant to be composed all over the place, so this is bound to be a 378 | problem at least occasionally. The value restriction would hurt accessors 379 | /very/ badly due to subtyping, which is discussed more later. 380 | 381 | It turns out that most usages of accessors are inlined into some larger 382 | expression, where the right thing is almost always for them to be 383 | monomorphized anyway. We only have issues with the value restriction when 384 | let binding accessors to be reused multiple times. This is still common 385 | enough to be worth addressing. The solution implemented for ~Accessor~ is a 386 | ppx that knows how to unwrap and rewrap the containing record. 387 | 388 | Here's an example. Suppose we are defining the following accessor: 389 | 390 | #+BEGIN_SRC ocaml 391 | let a = b @> c 392 | #+END_SRC 393 | 394 | This would be hit by the value restriction. To fix it, we need to "eta 395 | expand" it. Here I'm assuming we're using the impossible representation from 396 | above, using type classes and higher kinded types: 397 | 398 | #+BEGIN_SRC ocaml 399 | let a = { f = fun abp -> (b @> c).f abp } 400 | #+END_SRC 401 | 402 | This is annoying and confusing to write, so =ppx_accessor= supports the 403 | following syntax instead: 404 | 405 | #+BEGIN_SRC ocaml 406 | let a = [%accessor b @> c] 407 | #+END_SRC 408 | 409 | *** Higher kinded types 410 | 411 | We've already created a "solution" to the lack of higher kinded types, in 412 | the form of the ~Higher_kinded~ library. It's not perfect, though, and it 413 | adds a lot of boilerplate. The upshot is that we can start turning the 414 | invalid OCaml type into real OCaml like this: 415 | 416 | #+BEGIN_SRC ocaml 417 | type ('c, 's, 't, 'a, 'b) optic = 418 | { f 419 | : 'p 420 | . 'p 'c 421 | => ('a, 'b, 'p) Higher_kinded.t2 422 | -> ('s, 't, 'p) Higher_kinded.t2 423 | } 424 | #+END_SRC 425 | 426 | Now all that's left to make this valid OCaml is type classes. 427 | 428 | *** Type classes 429 | 430 | Type classes have a fundamental role in the Haskell implementation, in 431 | particular for the subtyping. They are used for two things: ad hoc 432 | polymorphism and subtyping. 433 | 434 | **** Dictionary passing 435 | 436 | A common way that type classes are implemented in Haskell compilers is by 437 | giving them a runtime representation. GHC represents them as "dictionaries", 438 | that is, records of functions. For example, the ~Profunctor~ type class 439 | might, in Haskell syntax, be represented as a value of the following type: 440 | 441 | #+BEGIN_SRC haskell 442 | data ProfunctorDict p = 443 | ProfunctorDict { dimap :: forall a b c d. (b -> a) -> (c -> d) -> p a c -> p b d } 444 | #+END_SRC 445 | 446 | For subclasses, the dictionary might contain a reference to the dictionary 447 | of the type's superclass instance: 448 | 449 | #+BEGIN_SRC haskell 450 | data CartesianDict p = 451 | CartesianDict 452 | { profunctorDict :: ProfunctorDict p 453 | , first :: p a b -> p (a, c) (b, c) 454 | , second :: p a b -> p (c, a) (c, b) 455 | } 456 | #+END_SRC 457 | 458 | For monomorphic call sites, the compiler would figure out the correct 459 | dictionary to pass from the type. For polymorphic call sites, the compiler 460 | would expect some dictionary to have been passed in from elsewhere. 461 | 462 | We can use the same implementation technique to emulate type classes in 463 | OCaml: 464 | 465 | #+BEGIN_SRC ocaml 466 | type 'p profunctor = 467 | { dimap 468 | : 'a 'b 'c 'd 469 | . ('a, 'c, 'p) Higher_kinded.t2 470 | -> contra_map:('b -> 'a) 471 | -> map:('c -> 'd) 472 | -> ('b, 'd, 'p) Higher_kinded.t2 473 | } 474 | 475 | type 'p cartesian = 476 | { profunctor : 'p profunctor 477 | ; first 478 | : 'a 'b 'c 479 | . ('a, 'b, 'p) Higher_kinded.t2 480 | -> ('a * 'c, 'b * 'c, 'p) Higher_kinded.t2 481 | ; second 482 | : 'a 'b 'c 483 | . ('a, 'b, 'p) Higher_kinded.t2 484 | -> ('c * 'a, 'c * 'b, 'p) Higher_kinded.t2 485 | } 486 | #+END_SRC 487 | 488 | We just have to be explicit about which dictionary to use at call sites, 489 | because the compiler won't infer it. 490 | 491 | This is enough for us to represent something like the basic profunctor 492 | encoding of lenses: 493 | 494 | #+BEGIN_SRC ocaml 495 | type ('a, 'b, 's, 't) lens = 496 | { f 497 | : 'p 498 | . 'p cartesian 499 | -> ('a, 'b, 'p) Higher_kinded.t2 500 | -> ('s, 't, 'p) Higher_kinded.t2 501 | } 502 | #+END_SRC 503 | 504 | **** Subtyping 505 | 506 | The above definition of ~lens~ works fine on its own, but it's limited to 507 | field-like accessors. We can support other kinds of optics by exchanging 508 | the dictionary type for others. For example, if we exchange ~cartesian~ 509 | with ~cocartesian~, we can define a ~prism~: 510 | 511 | #+BEGIN_SRC ocaml 512 | type 'p cocartesian = 513 | { profunctor : 'p profunctor 514 | ; first 515 | : 'a 'b 'c 516 | . ('a, 'b, 'p) Higher_kinded.t2 517 | -> (('a, 'c) Either.t, ('b, 'c) Either.t, 'p) Higher_kinded.t2 518 | ; second 519 | : 'a 'b 'c 520 | . ('a, 'b, 'p) Higher_kinded.t2 521 | -> (('c, 'a) Either.t, ('c, 'b) Either.t, 'p) Higher_kinded.t2 522 | } 523 | 524 | type ('a, 'b, 's, 't) prism = 525 | { f 526 | : 'p 527 | . 'p cocartesian 528 | -> ('a, 'b, 'p) Higher_kinded.t2 529 | -> ('s, 't, 'p) Higher_kinded.t2 530 | } 531 | #+END_SRC 532 | 533 | But sadly the ~lens~ and ~prism~ types have nothing to do with each other! 534 | We would like to define one type for all optics, regardless of what kind of 535 | optic it is, relating them all. 536 | 537 | The most obvious way is probably to make the dictionary type an additional 538 | type parameter. We need to use ~Higher_kinded~ for this: 539 | 540 | #+BEGIN_SRC ocaml 541 | type ('a, 'b, 's, 't, 'k) optic = 542 | { f 543 | : 'p 544 | . ('p, 'k) Higher_kinded.t2 545 | -> ('a, 'b, 'p) Higher_kinded.t2 546 | -> ('s, 't, 'p) Higher_kinded.t2 547 | } 548 | #+END_SRC 549 | 550 | But now we're just going to end up with a series of types like this: 551 | 552 | #+BEGIN_SRC ocaml 553 | type ('a, 'b, 's, 't) iso = ('a, 'b, 's, 't, Profunctor.witness) optic 554 | type ('a, 'b, 's, 't) lens = ('a, 'b, 's, 't, Cartesian.witness) optic 555 | type ('a, 'b, 's, 't) prism = ('a, 'b, 's, 't, Cocartesian.witness) optic 556 | #+END_SRC 557 | 558 | These types still can't compose with each other to do anything interesting. 559 | What we really want is for the witnesses themselves to be in some subtyping 560 | relationship with each other. We can achieve this using a GADT, instead of 561 | ~Higher_kinded~, and in place of the witness type parameter we come up with 562 | some appropriate polymorphic variant encoding of all the different accessor 563 | kinds and how they relate, somewhat like the ~Perms.t~ encoding in ~Core~. 564 | 565 | Each constructor of the GADT corresponds to some dictionary. For example, 566 | here is a GADT encoding the ~profunctor~, ~cartesian~, and ~cocartesian~ 567 | dictionaries: 568 | 569 | #+BEGIN_SRC ocaml 570 | type ('p, 'k) dictionary = 571 | | Profunctor : 'p profunctor -> ('p, [< `profunctor ]) t 572 | | Cartesian : 'p cartesian -> ('p, [< `profunctor | `cartesian ]) t 573 | | Cocartesian : 'p cocartesian -> ('p, [< `profunctor | `cocartesian ]) t 574 | #+END_SRC 575 | 576 | Our optic type can now be defined like this: 577 | 578 | #+BEGIN_SRC ocaml 579 | type ('a, 'b, 's, 't, 'k) optic = 580 | { f 581 | : 'p 582 | . ('p, 'k) dictionary 583 | -> ('a, 'b, 'p) Higher_kinded.t2 584 | -> ('s, 't, 'p) Higher_kinded.t2 585 | } 586 | #+END_SRC 587 | 588 | And different kinds of optics can now compose! 589 | 590 | ** Extending accessors with indices 591 | 592 | Left out of the history written earlier in this document is the evolution of 593 | so-called "indexed" optics. The problem to be solved is that of supplying the 594 | user of an optic with some sort of "breadcrumb" indicating where they are in 595 | the data structure they are accessing. For example, ~List.mapi~ gives its 596 | function argument access to the index of each element in the list, along with 597 | the element itself. 598 | 599 | The ~lens~ library has, in my opinion, a somewhat unsatisfying story for 600 | indices. Indexed optics in ~lens~ have distinct types from unindexed ones, 601 | with totally different implementations. They compose fine with unindexed 602 | optics, but when you compose them with each other it drops one of the 603 | indices. If you want to keep both, you have to use a special compose 604 | function. Depending on which function you use, it either builds up an 605 | annoying to use tuple or requires you to explicitly tell it how to combine 606 | indices. Indexed optics in ~lens~ also involve even crazier looking types 607 | than unindexed ones, such as this monstrous type class: 608 | 609 | #+BEGIN_SRC haskell 610 | class 611 | ( Choice p 612 | , Corepresentable p 613 | , Comonad (Corep p) 614 | , Traversable (Corep p) 615 | , Strong p 616 | , Representable p 617 | , Monad (Rep p) 618 | , MonadFix (Rep p) 619 | , Distributive (Rep p) 620 | , Costrong p 621 | , ArrowLoop p 622 | , ArrowApply p 623 | , ArrowChoice p 624 | , Closed p 625 | ) => Conjoined p 626 | where 627 | distrib :: Functor f => p a b -> p (f a) (f b) 628 | conjoined :: (p ~ (->) => q (a -> b) r) -> q (p a b) r -> q (p a b) r 629 | #+END_SRC 630 | 631 | For a long time, it also wasn't very clear how to make indexed 632 | pure-profunctor optics even as "nice" as the indexed 633 | hybrid-van-Laarhoven-profunctor optics in ~lens~. In 2016, Oleg Grenrus 634 | responded to a challenge from Ed Kmett by [[http://oleg.fi/gists/posts/2017-04-26-indexed-poptics.html][solving it]]. As far as I know, 635 | ~Accessor~ is the first library to use his technique. 636 | 637 | It requires adding two more type arguments to our ~optic~ type: 638 | 639 | #+BEGIN_SRC ocaml 640 | type ('i, 'a, 'b, 'j, 's, 't, 'k) indexed_optic = 641 | { f 642 | : 'p 643 | . ('p, 'k) dictionary 644 | -> ('i * 'a, 'b, 'p) Higher_kinded.t2 645 | -> ('j * 's, 't, 'p) Higher_kinded.t2 646 | } 647 | #+END_SRC 648 | 649 | The trick is to treat the indices not as single indices but as a /stack/ of 650 | indices, where the stack gets deeper as you reach more deeply into a data 651 | structure. The ~j~ type parameter above is the "input" stack, coming in from 652 | the outside of the data structure, and the ~i~ type parameter is the "output" 653 | stack, being read from the inside of the data structure. 654 | 655 | ** Niceties 656 | 657 | *** Names 658 | 659 | Instead of using various words for optical devices, we try to use 660 | terminology more familiar to an OCaml programmer, like ~field~, ~variant~, 661 | etc. The main type is called an "accessor". Generally, the hope is that the 662 | names describe what things are fairly well. 663 | 664 | The subtyping schema described in the previous section used names like 665 | ~profunctor~, ~cartesian~, and ~cocartesian~. Since these words will 666 | actually appear in type errors, etc., it seems worth rethinking this. It 667 | turns out that the public subtyping schema we use doesn't actually have to 668 | line up with the type classes at all, as long as the same relationships 669 | between accessor kinds are implied. The scheme we actually use inverts the 670 | arrows and uses polymorphic variants to encode what sets of "features" are 671 | supported by each kind of accessor. That is, if ~A~ is a subtype of ~B~, 672 | that means ~A~ has more features than ~B~. The features are selected to try 673 | to have intuitive meanings, to make type errors easier to grok. The details 674 | are in =subtyping_intf.ml=. 675 | 676 | *** Type classes 677 | 678 | The type classes we actually use in ~Accessor~ have little to do with the 679 | type class hierarchy used in most other implementations. The observation is 680 | that every kind of accessor can be represented with exactly one type class 681 | with exactly one method that knows how to convert from a concrete accessor 682 | representation to a transformation between mappings. Let's take the 683 | ~profunctor~ type class as an example: 684 | 685 | #+BEGIN_SRC ocaml 686 | type 'p profunctor = 687 | { dimap 688 | : 'a 'b 'c 'd 689 | . ('a, 'c, 'p) Higher_kinded.t2 690 | -> contra_map:('b -> 'a) 691 | -> map:('c -> 'd) 692 | -> ('b, 'd, 'p) Higher_kinded.t2 693 | } 694 | #+END_SRC 695 | 696 | This type class happens to characterize isomorphisms. How do we construct an 697 | isomorphism? 698 | 699 | #+BEGIN_SRC ocaml 700 | val isomorphism 701 | : get:('s -> 'a) 702 | -> construct:('b -> 't) 703 | -> ('a, 'b, 's, 't, [< isomorphism]) accessor 704 | #+END_SRC 705 | 706 | In the implementation, the ~get~ and ~construct~ functions happen to be 707 | supplied as the ~contra_map~ and ~map~ arguments to ~dimap~. With some 708 | renaming, we can present ~profunctor~ as a type class just for isomorphisms: 709 | 710 | #+BEGIN_SRC ocaml 711 | type 'p isomorphism = 712 | { f 713 | : 'a 'b 's 't 714 | . get:('s -> 'a) 715 | -> construct:('b -> 't) 716 | -> ('a, 'b, 'p) Higher_kinded.t2 717 | -> ('s, 't, 'p) Higher_kinded.t2 718 | } 719 | #+END_SRC 720 | 721 | This works out for every kind of accessor. For example, ~field~ accessors 722 | can be characterized with the following type class: 723 | 724 | #+BEGIN_SRC ocaml 725 | type 'p field = 726 | { f 727 | : 'a 'b 's 't 728 | . get:('s -> 'a) 729 | -> set:('s -> 'b -> 't) 730 | -> ('a, 'b, 'p) Higher_kinded.t2 731 | -> ('s, 't, 'p) Higher_kinded.t2 732 | } 733 | #+END_SRC 734 | 735 | Even though ~field~ is supposed to be a subclass of ~isomorphism~, it no 736 | longer needs to include an implementation of ~isomorphism~ in its own 737 | representation. The one function it contains is sufficient to create an 738 | ~isomorphism~ dictionary from a ~field~ dictionary: 739 | 740 | #+BEGIN_SRC ocaml 741 | let field_to_isomorphism ({ f } : _ field) : _ isomorphism = 742 | { f = fun ~get ~construct -> f ~get ~set:(fun _ b -> construct b) } 743 | #+END_SRC 744 | 745 | The type class definitions all live in =dictionary.ml=, along with the GADT 746 | we use to relate them with subtyping. Its interface provides functions for 747 | constructing and observing dictionaries respecting subtyping, automatically 748 | converting the dictionary as needed. 749 | 750 | *** Indices 751 | 752 | The ~Index~ module defines a list-like type that we use as our stack of 753 | indices. It overloads the ~list~ constructors to make pattern matching 754 | convenient. 755 | 756 | To avoid the need to convert back and forth between indexed and unindexed 757 | accessors, /all/ accessors are indexed. So-called "unindexed" accessors are 758 | just indexed accessors that pass the index stack through without adding 759 | anything on top of it. 760 | 761 | *** Type parameters 762 | 763 | The accessor type up to now has seven type parameters. That's a bit much. We 764 | address this in two ways. 765 | 766 | First, we define a "simple" accessor type for unindexed, monomorphic 767 | accessors, having "only" four type parameters: 768 | 769 | #+BEGIN_SRC ocaml 770 | type ('i, 'a, 's, 'k) simple = ('i, 'a, 'a, 'i, 's, 's, 'k) accessor 771 | #+END_SRC 772 | 773 | For the second improvement, well, there's not much we can do to remove the 774 | actual number of type variables, but we can /trick/ the user into seeing it 775 | as a simpler type by artifically reducing the number of parameters using a 776 | GADT resulting a fewer parameters that in practice always have more complex 777 | structure. 778 | 779 | Here's what we're dealing with so far: 780 | 781 | #+BEGIN_SRC ocaml 782 | type ('i, 'a, 'b, 'j, 's, 't, 'k) accessor = 783 | { f 784 | : 'p 785 | . ('p, 'k) dictionary 786 | -> ('i Index.t * 'a, 'b, 'p) Higher_kinded.t2 787 | -> ('j Index.t * 's, 't, 'p) Higher_kinded.t2 788 | } 789 | #+END_SRC 790 | 791 | Note that ~i~, ~a~, and ~b~ are related to each other, in that they all 792 | belong to some "input" value. ~j~, ~s~, and ~t~ are also related to each 793 | other, in that they all belong to an "output" value. We can make a wrapper 794 | around that ~Higher_kinded.t~ to collect the three types into one parameter: 795 | 796 | #+BEGIN_SRC ocaml 797 | type ('m, 'p) mapping = 798 | | T : ('i Index.t * 'a, 'b, 'p) Hk.t2 -> ('i -> 'a -> 'b, 'p) mapping 799 | #+END_SRC 800 | 801 | This type lives in =mapping.ml=. 802 | 803 | For simplifying ~accessor~, this does wonders: 804 | 805 | #+BEGIN_SRC ocaml 806 | type ('inner, 'outer, 'kind) accessor = 807 | { f 808 | : 'p 809 | . ('p, 'kind) dictionary 810 | -> ('inner, 'kind) mapping 811 | -> ('outer, 'kind) mapping 812 | } 813 | #+END_SRC 814 | 815 | This also allows functions like ~Accessor.compose~ to have very easy to read 816 | types. Most accessor functions do put some structure back into those 817 | positions. They appear as function types. For example, ~Accessor.map~ has 818 | this type: 819 | 820 | #+BEGIN_SRC ocaml 821 | val map 822 | : (unit -> 'a -> 'b, unit -> 's -> 't, [> mapper]) accessor 823 | -> 's 824 | -> f:('a -> 'b) 825 | -> 't 826 | #+END_SRC 827 | 828 | Without this trick, ~map~ actually would have a smaller type, but I think 829 | it's harder to understand because it conveys less of the structure: 830 | 831 | #+BEGIN_SRC ocaml 832 | val map 833 | : (unit, 'a, 'b, unit, 's, 't, [> mapper]) accessor 834 | -> 's 835 | -> f:('a -> 'b) 836 | -> 't 837 | #+END_SRC 838 | 839 | Finally, we change the type variable naming scheme from ~a~, ~b~, ~s~, and 840 | ~t~ to ~a~, ~b~, ~at~ and ~bt~. This is an attempt to make the latter two 841 | look more like polymorphic type constructors. This matches up better with 842 | many of the types one might encounter in practice, such as that of 843 | ~Accessor.Option.some~: 844 | 845 | #+BEGIN_SRC ocaml 846 | val some : ('i -> 'a -> 'b, 'i -> 'a option -> 'b option, [< variant ]) accessor 847 | #+END_SRC 848 | 849 | The ~at~ and ~bt~ names match up with ~a~ and ~b~ in a way that suggests 850 | they are being wrapping in some ~t~ type constructor. 851 | 852 | This makes the type of ~map~ actually look something like this: 853 | 854 | #+BEGIN_SRC ocaml 855 | val map 856 | : (unit -> 'a -> 'b, unit -> 'at -> 'bt, [> mapper]) accessor 857 | -> 'at 858 | -> f:('a -> 'b) 859 | -> 'bt 860 | #+END_SRC 861 | 862 | *** Custom type class dictionaries 863 | 864 | It seems desirable to allow advanced users to write their own functions for 865 | consuming accessors by creating their own dictionaries. It's not well 866 | documented yet, but the signature for this is in =custom_mappings_intf.ml=. 867 | (Most people should not need this, which is why it's not inlined into 868 | =accessor.mli=.) This module provides a bunch of functors that allow even 869 | advanced users to do this without ever seeing a ~Higher_kinded.t~. Each 870 | functor in this interface accepts a representative function for the 871 | dictionary, and it provides a function for consuming accessors using that 872 | dictionary. 873 | 874 | *** Helper DSLs for defining multi-accessors 875 | 876 | Earlier versions of the interface required users defining custom 877 | multi-accessors, such as ~many~ accessors, to work with some anonymous 878 | applicative. The best version of this interface I could come up with was to 879 | give them a first class module with a higher kinded version of some 880 | applicative interface so they could open a contained ~Let_syntax~ module and 881 | go. This was pretty clumsy. Defining an accessor that accesses both 882 | components of a tuple looked something like this: 883 | 884 | #+BEGIN_SRC ocaml 885 | let each = 886 | [%accessor 887 | Accessor.nonempty 888 | { f = 889 | (fun 890 | (type w) 891 | (module A : w Accessor.Applicative_without_return.t) 892 | (a, b) 893 | ~f -> 894 | let open A.Let_syntax in 895 | let%map a = f a 896 | and b = f b 897 | in 898 | a, b) 899 | }] 900 | #+END_SRC 901 | 902 | =many.ml= and =nonempty.ml= make this a lot nicer by providing a single 903 | applicative to use from a global scope. The only cost is that you have to 904 | use a special ~access~ function instead of a function argument, which is a 905 | bit less typical but probably not that bad. Here is the above function 906 | written in the new style: 907 | 908 | #+BEGIN_SRC ocaml 909 | let each = 910 | [%accessor 911 | Accessor.nonempty (fun (a, b) -> 912 | let open Accessor.Nonempty.Let_syntax in 913 | let%map_open a = access a 914 | and b = access b 915 | in 916 | a, b)] 917 | #+END_SRC 918 | 919 | The implementation of these monads is a fairly directly translation from the 920 | earlier style. The type itself is a function from an applicative and some 921 | function argument, removing them from view of the user. The type also 922 | handles the quantification over the higher kinded witness. 923 | 924 | There are similar types for creating ~many_getter~ and ~nonempty_getter~ 925 | accessor functions. They are monoidal instead of applicative, and they live 926 | in =many_getter.ml= and =nonempty_getter.ml=, respectively. 927 | 928 | * False starts 929 | 930 | Before attempting a direct translation from the Haskell implementations I was 931 | already familiar with, I thought I could be clever and make the OCaml version 932 | use more concrete representations for accessors. The best attempt in this 933 | direction was to define accessors as a big GADT where each case was some 934 | concrete kind of accessor. Here's a subset of such a definition: 935 | 936 | #+BEGIN_SRC ocaml 937 | type ('a, 'b, 'at, 'bt, 'k) accessor = 938 | | Isomorphism 939 | : { get : 'at -> 'a 940 | ; construct : 'b -> 'bt 941 | } 942 | -> ('a, 'b, 'at, 'bt, [< isomorphism]) t 943 | | Field 944 | : { get : 'at -> 'a 945 | ; set : 'at -> 'b -> 'bt 946 | } 947 | -> ('a, 'b, 'at, 'bt, [< field]) t 948 | #+END_SRC 949 | 950 | There were a few problems with this. 951 | 952 | The first problem I ran into was that the ~compose~ function was extremely 953 | large and complex. It needed to handle every possible pair of accessors kinds, 954 | converting them to their common subtype, and only then could it compose them 955 | in the normal way. This would make it pretty annoying to add new types of 956 | accessors in the future, and it was pretty difficult to figure out what that 957 | function was doing. 958 | 959 | The second problem was related to the first. This would easily lead to very 960 | inefficient computations when composing long chains of accessors, because a 961 | single accessor might be converted to several different accessor kinds along 962 | the way, and then once more to the final accessor type needed by the consuming 963 | function. Some of these conversions were more expensive than others, and this 964 | tended to make the expensive cases happen a lot more frequently. In contrast, 965 | the profunctor encoding we're actually using performs exactly one conversion 966 | to exactly the correct type of accessor at the point we are using it. 967 | 968 | A third, somewhat more minor, problem is the value restriction. It can't 969 | really be stopped without a function representation. The solution to this is 970 | to thunk the representation, making it a function from ~unit~ to the above 971 | type. 972 | 973 | The final, most serious, problem is that I couldn't figure out how to get the 974 | compiler to accept ~compose~. It seems to struggle a lot with type indices 975 | with subtyping as it is, and trying to unify them across two arguments is 976 | probably just impossible as the language current exists. 977 | -------------------------------------------------------------------------------- /doc/dune: -------------------------------------------------------------------------------- 1 | (rule 2 | (targets subtyping.svg) 3 | (deps accessor_subtyping_diagram.exe) 4 | (action 5 | (bash 6 | "%{workspace_root}/lib/accessor/doc/accessor_subtyping_diagram.exe | tred | dot -Tsvg > subtyping.svg"))) 7 | 8 | (executables 9 | (modes byte exe) 10 | (names accessor_subtyping_diagram) 11 | (libraries core accessor) 12 | (preprocess 13 | (pps ppx_jane))) 14 | -------------------------------------------------------------------------------- /doc/tutorial.mdx: -------------------------------------------------------------------------------- 1 | # Accessor tutorial 2 | 3 | Introduction 4 | ============ 5 | 6 | The `Accessor` library makes it nicer to work with functional data 7 | structures. 8 | 9 | To get started with `Accessor`, select which accessor library you 10 | would like to use (e.g. `accessor_base`, `accessor_core`, 11 | `accessor_async`), based on what dependencies you are willing to link 12 | against, and bind it as `Accessor` in your project. It is also 13 | recommended that you open `Accessor.O` to reduce boilerplate. Finally, 14 | make sure to add the library you selected to your jbuild, and if you 15 | will be defining your own accessors, you probably also want to add 16 | `ppx_accessor` to your syntax extensions. 17 | 18 | Here is what we will be using for this tutorial: 19 | 20 | ```ocaml 21 | open! Core 22 | open! Async 23 | module Accessor = Accessor_async 24 | open Accessor.O 25 | let print_s = Core.print_s 26 | ``` 27 | 28 | Motivation 29 | ========== 30 | 31 | The simplest problem solved by `Accessor` is updating nested records. 32 | Let's take the following types as an example: 33 | 34 | ```ocaml 35 | type coordinate = 36 | { row : int 37 | ; col : int 38 | } 39 | [@@deriving accessors, sexp_of] 40 | 41 | type cell = 42 | { contents : string 43 | ; location : coordinate 44 | } 45 | [@@deriving accessors, sexp_of] 46 | ``` 47 | 48 | You probably noticed `[@@deriving accessors]`, but let's not dwell on 49 | that, for now. 50 | 51 | To shift the location of a cell to the right by one in native OCaml, 52 | we might normally write something like this: 53 | 54 | ```ocaml 55 | # let shift_cell_right cell = 56 | let location = cell.location in 57 | let col = location.col in 58 | { cell with location = { location with col = succ col } } 59 | val shift_cell_right : cell -> cell = 60 | ``` 61 | 62 | This style becomes more unwieldly as the level of nesting increases. 63 | `Accessor` solves this problem by allowing you to write this instead: 64 | 65 | ```ocaml 66 | # let shift_cell_right cell = Accessor.map (location @> col) cell ~f:succ 67 | val shift_cell_right : cell -> cell = 68 | ``` 69 | 70 | Here's a small demonstration that it works: 71 | 72 | ```ocaml 73 | # let cell = { contents = "A"; location = { row = 1; col = 2 } } in 74 | shift_cell_right cell 75 | - : cell = {contents = "A"; location = {row = 1; col = 3}} 76 | ``` 77 | 78 | Let's create another type: 79 | 80 | ```ocaml 81 | type shape = { cells : cell list } [@@deriving accessors] 82 | ``` 83 | 84 | It is possible to shift an entire `shape` at once, like this: 85 | 86 | ```ocaml 87 | # let shift_shape_right shape = 88 | Accessor.map (cells @> Accessor.List.each @> location @> col) shape ~f:succ 89 | val shift_shape_right : shape -> shape = 90 | ``` 91 | 92 | Here's a small demonstration that this also works: 93 | 94 | ```ocaml 95 | # let shape = 96 | let cell_a = { contents = "A"; location = { row = 1; col = 2 } } in 97 | let cell_b = { contents = "B"; location = { row = 3; col = 4 } } in 98 | { cells = [ cell_a; cell_b ] } 99 | in 100 | shift_shape_right shape 101 | - : shape = 102 | {cells = 103 | [{contents = "A"; location = {row = 1; col = 3}}; 104 | {contents = "B"; location = {row = 3; col = 5}}]} 105 | ``` 106 | 107 | `field` accessors 108 | ================= 109 | 110 | A `field` is a kind of accessor that knows how to `get` and `set` some 111 | data within a larger data structure. In the previous section, `row`, 112 | `col`, `contents`, `location`, and `cells` were all examples of field 113 | accessors, generated for us automatically by `[@@deriving accessors]`. 114 | We have already seen them used to modify values using `Accessor.map`, 115 | but field accessors can also be used to extract values, using 116 | `Accessor.get`: 117 | 118 | ```ocaml 119 | # let cell = { contents = "A"; location = { row = 1; col = 2 } } in 120 | Accessor.get (location @> col) cell 121 | - : int = 2 122 | ``` 123 | 124 | One can imagine that field accessors could be represented with a 125 | record with functions for "getting" and "setting": 126 | 127 | ```ocaml 128 | type ('inner, 'outer) getter_setter = 129 | { get : 'outer -> 'inner 130 | ; set : 'outer -> 'inner -> 'outer 131 | } 132 | ``` 133 | 134 | This isn't how field accessors are actually represented, but it's 135 | representative enough for teaching purposes. 136 | 137 | The type of a `field` 138 | --------------------- 139 | 140 | Here are the types for a couple fields we have already seen: 141 | 142 | ```ocaml 143 | let location : (_, coordinate, cell, [< field ]) Accessor.t = location 144 | let col : (_, int, coordinate, [< field ]) Accessor.t = col 145 | ``` 146 | 147 | The `location` accessor is a field containing the information needed 148 | to get or set the `location` record field of the `cell` type, which is 149 | a `coordinate`. The `col` accessor is a field containing the 150 | information needed to get or set the `col` record field of the 151 | `coordinate` type, which is an `int`. 152 | 153 | `Accessor.t` is a type alias reducing some of the boilerplate that 154 | often appears when using `Accessor.General.t`, the actual type of 155 | accessors. The first argument of `Accessor.t` is usually left as an 156 | underscore. The second argument is the type of inner values we are 157 | accessing. The third argument is the type of the composite data 158 | structure we are reaching into. The last argument is an indication of 159 | what "kind" of accessor it is, a `field` in these cases. 160 | 161 | Here are less simple versions of these accessors' types: 162 | 163 | ```ocaml 164 | let location 165 | : ( 'i -> coordinate -> coordinate 166 | , 'i -> cell -> cell 167 | , [< field ] 168 | ) Accessor.General.t 169 | = location 170 | 171 | let col 172 | : ( 'i -> int -> int 173 | , 'i -> coordinate -> coordinate 174 | , [< field ] 175 | ) Accessor.General.t 176 | = col 177 | ``` 178 | 179 | The first two type parameters of an `Accessor.General.t` are always 180 | rendered as function types taking two arguments. The first function 181 | type represents an "inner mapping", and the second function type 182 | represents an "outer mapping". Disregarding the first arguments of the 183 | functions (the `'i` in the above examples), one might read the above 184 | type of `location` as a `field` that transforms a mapping from 185 | `coordinate` to `coordinate` into a mapping from `cell` to `cell`. 186 | 187 | We're using the word "mapping" to try to convey that it is more 188 | general than a function. The concrete instantiation of the mappings is 189 | determined by how you are using the accessor. 190 | 191 | `Accessor.map` treats the mappings as literal functions. It's a bit 192 | easier to see this by rearranging its type a bit: 193 | 194 | ```ocaml 195 | let map 196 | : (_ -> 'inner -> 'inner, _ -> 'outer -> 'outer, [> field ]) Accessor.General.t 197 | -> ('inner -> 'inner) -> ('outer -> 'outer) 198 | = fun accessor f outer -> Accessor.map accessor outer ~f 199 | ``` 200 | 201 | `Accessor.set` is just defined in terms of `Accessor.map`: 202 | 203 | ```ocaml 204 | let set accessor outer ~to_:inner = Accessor.map accessor outer ~f:(fun _ -> inner) 205 | ``` 206 | 207 | What about `Accessor.get`? It's a bit harder to see, but it works by 208 | disregarding the apparent return types of the functions and forcing 209 | them to just be the inner type. It's as though this is the mapping 210 | type: 211 | 212 | ```ocaml 213 | type ('input, 'output, 'result) get_mapping = 'input -> 'result 214 | ``` 215 | 216 | Some generous reshuffling of the type of `Accessor.get` hopefully 217 | shows this clearly enough: 218 | 219 | ```ocaml 220 | let get 221 | : ( _ -> 'inner -> 'inner 222 | , _ -> 'outer -> 'outer 223 | , [> field ] 224 | ) Accessor.General.t 225 | -> ('inner, 'inner, 'result) get_mapping 226 | -> ('outer, 'outer, 'result) get_mapping 227 | = fun accessor f outer -> f (Accessor.get accessor outer) 228 | ``` 229 | 230 | You can recover the type of `Accessor.get` from the above definition 231 | by forcing the function argument to be `Fn.id`: 232 | 233 | ```ocaml 234 | let get 235 | : (_ -> 'inner -> 'inner, _ -> 'outer -> 'outer, [> field ]) Accessor.General.t 236 | -> 'outer 237 | -> 'inner 238 | = fun accessor outer -> get accessor Fn.id outer 239 | ``` 240 | 241 | Creating `field` accessors 242 | -------------------------- 243 | 244 | There are two ways to define new field accessors. We have already seen 245 | one, which is to use `[@@deriving accessors]` on a record type 246 | definition. The other way is to define it manually using 247 | `Accessor.field`. For example, here is how to define the `location` 248 | field by hand: 249 | 250 | ```ocaml 251 | let location = 252 | Accessor.field 253 | ~get:(fun cell -> cell.location) 254 | ~set:(fun cell location -> { cell with location }) 255 | ``` 256 | 257 | And here is some evidence that it's working: 258 | 259 | ```ocaml 260 | # let cell = { contents = "A"; location = { row = 1; col = 2 } } in 261 | Accessor.get location cell 262 | - : coordinate = {row = 1; col = 2} 263 | ``` 264 | 265 | Unfortunately, this isn't normally good enough in practice. The 266 | compiler is not able to infer a sufficiently general type given just 267 | the above definition. To see the problem, you have to try using the 268 | accessor two different ways. 269 | 270 | ```ocaml 271 | # let cell_a = { contents = "A"; location = { row = 1; col = 2 } } 272 | and cell_b = { contents = "B"; location = { row = 3; col = 4 } } 273 | in 274 | 275 | let shape = { cells = [ cell_a; cell_b ] } in 276 | 277 | Accessor.map (cells @> Accessor.List.each @> location @> row) shape ~f:succ 278 | Line 7, characters 48-63: 279 | Error: This expression has type 280 | (unit -> int -> int, unit -> cell -> cell, 281 | [< Accessor.field > `at_least_one `at_most_one `get ]) 282 | Accessor.General.t 283 | but an expression was expected of type 284 | (unit -> int -> int, unit -> cell -> cell, 285 | [< Accessor_base__Import.many ]) 286 | Accessor.General.t 287 | Type 288 | [< Accessor.field > `at_least_one `at_most_one `get ] = 289 | [< `at_least_one | `at_most_one | `get | `map 290 | > `at_least_one `at_most_one `get ] 291 | is not compatible with type 292 | [< Accessor_base__Import.many ] = [< `get | `map ] 293 | The second variant type does not allow tag(s) 294 | `at_least_one, `at_most_one 295 | ``` 296 | 297 | That ugly type error is telling us that the compiler is having trouble 298 | figuring out that it's okay for `Accessor.List.each` and `location` to 299 | be composed with each other. `Accessor.List.each` is not a `field` 300 | accessor but a `many` accessor, and all the accessors being composed 301 | have to be of the same kind. Ordinarily, this would work out fine, 302 | because `field` is a *subtype* of `many`, but the value restriction is 303 | preventing the compiler from generalizing the `field` accessor into a 304 | `many` accessor, because we already specialized it to a particular 305 | kind when we used `Accessor.get` earlier. 306 | 307 | In addition to `[@@deriving accessors]`, `ppx_accessor` also provides 308 | an `[%accessor]` syntax to help generalize your hand-written 309 | accessors. Here is how to use it: 310 | 311 | ```ocaml 312 | let location = 313 | [%accessor 314 | Accessor.field 315 | ~get:(fun cell -> cell.location) 316 | ~set:(fun cell location -> { cell with location })] 317 | ``` 318 | 319 | Now we can do all the things we wanted to do before: 320 | 321 | ```ocaml 322 | # let cell = { contents = "A"; location = { row = 1; col = 2 } } in 323 | Accessor.get location cell 324 | - : coordinate = {row = 1; col = 2} 325 | 326 | # let cell_a = { contents = "A"; location = { row = 1; col = 2 } } 327 | and cell_b = { contents = "B"; location = { row = 3; col = 4 } } 328 | in 329 | 330 | let shape = { cells = [ cell_a; cell_b ] } in 331 | 332 | Accessor.map (cells @> Accessor.List.each @> location @> row) shape ~f:succ 333 | - : shape = 334 | {cells = 335 | [{contents = "A"; location = {row = 2; col = 2}}; 336 | {contents = "B"; location = {row = 4; col = 4}}]} 337 | ``` 338 | 339 | Under the hood, accessors are functions. All `[%accessor]` is doing is 340 | eta expanding the definition to avoid the value restriction. 341 | 342 | Combining accessors 343 | =================== 344 | 345 | We've already seen how to compose accessors. You do it using `( @> )`. 346 | An accessor is a function that transforms one mapping into another, so 347 | `( @> )` is function composition. You can think of the type as 348 | something like this: 349 | 350 | ``` 351 | val ( @> ) 352 | : ('b mapping -> 'c mapping) 353 | -> ('a mapping -> 'b mapping) 354 | -> ('a mapping -> 'c mapping) 355 | ``` 356 | 357 | The actual type doesn't even look very different: 358 | 359 | ```ocaml 360 | # #show ( @> ) 361 | val ( @> ) : 362 | ('middle, 'outer, 'kind) Accessor.General.t -> 363 | ('inner, 'middle, 'kind) Accessor.General.t -> 364 | ('inner, 'outer, 'kind) Accessor.General.t 365 | ``` 366 | 367 | Previously, we had defined a new field by composing the `location` and 368 | `col` fields. The resulting field gives us access to the `col` field 369 | of a `cell`: 370 | 371 | ```ocaml 372 | # #show location 373 | val location : 374 | ('a -> coordinate -> coordinate, 'a -> cell -> cell, [< Accessor.field ]) 375 | Accessor.General.t 376 | 377 | # #show col 378 | val col : 379 | ('i -> int -> int, 'i -> coordinate -> coordinate, [< Accessor.field ]) 380 | Accessor.General.t 381 | 382 | # let location_col = [%accessor location @> col] 383 | val location_col : 384 | ('a -> int -> int, 'a -> cell -> cell, [< Accessor.field ]) 385 | Accessor.General.t = {Accessor.General.f = } 386 | ``` 387 | 388 | The resulting accessor is just as useful as the originals and can be 389 | used for getting and setting: 390 | 391 | ```ocaml 392 | # Accessor.get location_col 393 | - : cell -> int = 394 | 395 | # Accessor.set location_col 396 | - : cell -> to_:int -> cell = 397 | 398 | # Accessor.map location_col 399 | - : cell -> f:(int -> int) -> cell = 400 | ``` 401 | 402 | Indexing operators 403 | ================== 404 | 405 | `Accessor` defines a family of convenient indexing operators. You can 406 | use `( .@() )` instead of `Accessor.get`: 407 | 408 | ```ocaml 409 | # let cell = { contents = "A"; location = { row = 1; col = 2 } } in 410 | cell.@(location @> col) 411 | - : int = 2 412 | ``` 413 | 414 | You can use `( .@()<- )` instead of `Accessor.set`: 415 | 416 | ```ocaml 417 | # let cell = { contents = "A"; location = { row = 1; col = 2 } } in 418 | cell.@(location @> col) <- 0 419 | - : cell = {contents = "A"; location = {row = 1; col = 0}} 420 | ``` 421 | 422 | Reusing accessors 423 | ================= 424 | 425 | The fact that fields are values means you are not limited to using 426 | them as a mere language feature. You can store them in data 427 | structures, accept them as inputs to functions, and anything else you 428 | can do with an OCaml value. 429 | 430 | Let's take our shifting functions from earlier as an example: 431 | 432 | ```ocaml 433 | let shift_cell_right cell = Accessor.map (location @> col) cell ~f:succ 434 | 435 | let shift_shape_right shape = 436 | Accessor.map (cells @> Accessor.List.each @> location @> col) shape ~f:succ 437 | ``` 438 | 439 | We don't really need to define separate functions for these. We could 440 | just define one function for shifting the target of any accessor: 441 | 442 | ```ocaml 443 | let shift_right accessor outer = Accessor.map accessor outer ~f:succ 444 | ``` 445 | 446 | And we could separately define accessors for the colums of cells or 447 | shapes: 448 | 449 | ```ocaml 450 | let cell_col = [%accessor location @> col] 451 | let shape_col = [%accessor cells @> Accessor.List.each @> cell_col] 452 | ``` 453 | 454 | Observe that we even reused `cell_col` in the definition of 455 | `shape_col`! 456 | 457 | Now we can write code which reads quite similarly to our original 458 | functions by simply using `shift_right` with these new accessors: 459 | 460 | ```ocaml 461 | # shift_right cell_col 462 | - : cell -> cell = 463 | 464 | # shift_right shape_col 465 | - : shape -> shape = 466 | ``` 467 | 468 | And we also get a bunch of other useful functionality, of which this 469 | is only a taste: 470 | 471 | ```ocaml 472 | # Accessor.set cell_col 473 | - : cell -> to_:int -> cell = 474 | 475 | # Accessor.set shape_col 476 | - : shape -> to_:int -> shape = 477 | 478 | # Accessor.get cell_col 479 | - : cell -> int = 480 | 481 | # Accessor.to_list shape_col 482 | - : shape -> int list = 483 | ``` 484 | 485 | `many` accessors 486 | ================ 487 | 488 | A `many` accessor is like a `field`, but it accesses an arbitrary 489 | number of values. 490 | 491 | Many of the things you can do with a `field` you can also do with a 492 | `many` accessor. `Accessor.map` works out of the box. `Accessor.set` 493 | also works, because it is defined using `Accessor.map`. `Accessor.get` 494 | does not work, but `Accessor.to_list` is a close equivalent. 495 | 496 | The type of a `many` accessor 497 | ----------------------------- 498 | 499 | We've already seen a `many` accessor in examples earlier: 500 | `Accessor.List.each`. Here is (a specialization of) its type: 501 | 502 | ```ocaml 503 | let each : (_, 'a, 'a list, [< many ]) Accessor.t = Accessor.List.each 504 | ``` 505 | 506 | Every `field` accessor is also a valid `many` accessor, which is what 507 | has allowed us to compose a `field` accessor like `location` and a 508 | `many` accessor like `Accessor.List.each` in previous examples. There 509 | is no conversion required; it just works, via subtyping. Here is a 510 | demonstration that `location` and `col` can be typechecked as `many` 511 | accessors without converting explicitly: 512 | 513 | ```ocaml 514 | let location : (_, coordinate, cell, [< many ]) Accessor.t = 515 | (location : (_, coordinate, cell, [< field ]) Accessor.t) 516 | 517 | let col : (_, int, coordinate, [< many ]) Accessor.t = 518 | (col : (_, int, coordinate, [< field ]) Accessor.t) 519 | ``` 520 | 521 | Creating `many` accessors 522 | ------------------------- 523 | 524 | The most common way of defining a `many` accessor is by just using 525 | some other kind of accessor as a `many` accessor. 526 | 527 | In addition to `field` accessors, `[@@deriving accessors]` can 528 | generate a few other kinds of accessors that can be used as `many` 529 | accessors, but we won't be discussing them in this section. 530 | 531 | You can also define a `many` accessor manually, using `Accessor.many`. 532 | To do so requires using an applicative interface, `Accessor.Many`, 533 | specially designed for this purpose. For example, to define an 534 | accessor of the `row` and `col` fields of a `coordinate`, you could 535 | write this: 536 | 537 | ```ocaml 538 | let row_and_col : (_, int, coordinate, [< many ]) Accessor.t = 539 | [%accessor 540 | Accessor.many (fun { row; col } -> 541 | let open Accessor.Many.Let_syntax in 542 | let%map_open row = access row 543 | and col = access col 544 | in 545 | { row; col })] 546 | ``` 547 | 548 | Let's try it out: 549 | 550 | ```ocaml 551 | # let coordinate = { row = 1; col = 2 } in 552 | Accessor.map row_and_col coordinate ~f:succ 553 | - : coordinate = {row = 2; col = 3} 554 | ``` 555 | 556 | Polymorphism 557 | ============ 558 | 559 | Accessors support polymorphic update of data structures. For example, 560 | `Accessor.map Accessor.List.each` can be used to change the type of 561 | the elements of a list: 562 | 563 | ```ocaml 564 | # Accessor.map Accessor.List.each [ "1"; "2" ] ~f:Int.of_string 565 | - : int list = [1; 2] 566 | ``` 567 | 568 | To see how this works, first observe this rearranged type of 569 | `Accessor.map Accessor.List.each`: 570 | 571 | ```ocaml 572 | let list_map : ('a -> 'b) -> 'a list -> 'b list = 573 | fun f xs -> Accessor.map Accessor.List.each xs ~f 574 | ``` 575 | 576 | It's a function from a mapping `a -> b` to a mapping `a list -> b 577 | list`. The mappings in the `Accessor.General.t` type are the same way: 578 | 579 | ```ocaml 580 | let each : (_ -> 'a -> 'b, _ -> 'a list -> 'b list, [< many ]) Accessor.General.t = 581 | Accessor.List.each 582 | ``` 583 | 584 | Polymorphic update is the reason `Accessor.General.t` has so much 585 | apparent redundancy in its type parameters. The types for accessors 586 | supporting polymorphic update cannot be written using the simpler 587 | `Accessor.t`. 588 | 589 | Indices 590 | ======= 591 | 592 | When accessing values in a data structure, it is sometimes convenient 593 | to be told how you got there. This is why `Base` has functions like 594 | `List.mapi`, which supply the function argument the index, which is 595 | what the `i` stands for, of the element being accessed in the list, or 596 | `Map.mapi`, which supplies the function the key (which if you squint 597 | is also an "index") of the element being accessed in the map. 598 | Accessors can be defined to provide indices, too. 599 | 600 | For example, `Accessor.List.eachi` supplies the index of each element 601 | it accesses: 602 | 603 | ```ocaml 604 | # let cell_a = { contents = "A"; location = { row = 1; col = 2 } } 605 | and cell_b = { contents = "B"; location = { row = 3; col = 4 } } 606 | in 607 | let shape = { cells = [ cell_a; cell_b ] } in 608 | Accessor.iteri (cells @> Accessor.List.eachi) shape ~f:(fun [ i ] cell -> 609 | print_s [%sexp (i, cell : int * cell)]) 610 | (0 ((contents A) (location ((row 1) (col 2))))) 611 | (1 ((contents B) (location ((row 3) (col 4))))) 612 | - : unit = () 613 | ``` 614 | 615 | In order to use an "indexed" accessor like `Accessor.List.eachi`, you 616 | have to use an indexed accessor consuming function like 617 | `Accessor.iteri`. Most of the common accessor functions have indexed 618 | counterparts. 619 | 620 | Indexed accessors can be composed with unindexed accessors, which has 621 | already been demonstrated. Indexed accessors can also be composed with 622 | other indexed accessors, in which case their indices are combined 623 | automatically. Multiple indices are provided to you in the form of a 624 | stack, with the top of the stack being the innermost index. The 625 | compiler knows the size of the stack statically, so you can just 626 | pattern match on it directly, with only one case. The syntax for 627 | pattern matching on indices is that same as for normal OCaml lists. 628 | Here is an example of accessing the elements in a list of lists along 629 | with their indices in both lists: 630 | 631 | ```ocaml 632 | # Accessor.iteri 633 | (Accessor.List.eachi @> Accessor.List.eachi) 634 | [ [ "a"; "b" ]; [ "c"; "d"; "e" ] ] 635 | ~f:(fun [ inner; outer ] str -> 636 | print_s [%sexp (inner, outer, str : int * int * string)]) 637 | (0 0 a) 638 | (1 0 b) 639 | (0 1 c) 640 | (1 1 d) 641 | (2 1 e) 642 | - : unit = () 643 | ``` 644 | 645 | The type of indices 646 | ------------------- 647 | 648 | Even though they are presented as lists, indices actually are given to 649 | you using the following type: 650 | 651 | ``` 652 | module Index = struct 653 | type 'a t = 654 | | [] : unit t 655 | | ( :: ) : 'a * 'b t -> ('a * 'b) t 656 | end 657 | ``` 658 | 659 | This type definition means the indices don't even have to have the 660 | same types. For example, if you are accessing the data of a 661 | `String.Map.t Int.Map.t`, your index could include both a `string` and 662 | an `int`. 663 | 664 | Accessors present indices in their types by filling in the positions 665 | we've so far been rendering with underscores. Here are the actual, 666 | complete types of `Accessor.List.each` and `Accessor.List.eachi`: 667 | 668 | ```ocaml 669 | let each : ('i -> 'a -> 'b, 'i -> 'a list -> 'b list, [< many ]) Accessor.General.t = 670 | Accessor.List.each 671 | 672 | let eachi : (int * 'i -> 'a -> 'b, 'i -> 'a list -> 'b list, [< many ]) Accessor.General.t = 673 | Accessor.List.eachi 674 | ``` 675 | 676 | Remember, accessors are mapping transformers. `Accessor.List.eachi` 677 | transforms an inner mapping `int * i -> a -> b` into an outer mapping 678 | `i -> a list -> b list`. That means it must be adding an `int` to the 679 | top of the stack `i` before passing it to the inner mapping. Likewise, 680 | `Accessor.List.each` just passes the stack through, unchanged. 681 | 682 | When consuming an accessor, we always start with an empty stack, so 683 | the outer mapping's first type argument will always be `unit`. An 684 | unindexed consuming function will expect that the accessor doesn't 685 | change the stack at all, so the inner mapping's first type argument 686 | will also be `unit`: 687 | 688 | ```ocaml 689 | let map 690 | : (unit -> 'a -> 'b, unit -> 'at -> 'bt, [> many ]) Accessor.General.t -> 'at 691 | -> f:('a -> 'b) -> 'bt 692 | = Accessor.map 693 | ``` 694 | 695 | An indexed consuming function doesn't have such rigid expectations of 696 | how the stack is updated: 697 | 698 | ```ocaml 699 | let mapi 700 | : ('i -> 'a -> 'b, unit -> 'at -> 'bt, [> many ]) Accessor.General.t -> 'at 701 | -> f:('i Accessor.Index.t -> 'a -> 'b) -> 'bt 702 | = Accessor.mapi 703 | ``` 704 | 705 | The indexed functions are strictly more expressive than the unindexed 706 | ones, but the unindexed functions are a little more convenient when 707 | you don't need to use indices, since the indexed functions would 708 | require you to deal with a superfluous `[]` argument. 709 | 710 | All kinds of accessors 711 | ====================== 712 | 713 | We've seen a couple kinds of accessors so far: `field` and `many`. 714 | There are many more, and they are all related with subtyping: 715 | 716 | ![Accessor subtyping](./subtyping.svg) 717 | 718 | A downward line from `A` to `B` means that an `A` can be freely 719 | coerced into a `B`. For example, a `field` can be coerced into a 720 | `getter`. The relationship is transitive. For example, because a 721 | `getter` can be coerced into an `optional_getter`, a `field` can also 722 | be coerced into an `optional_getter`. 723 | 724 | When composing different kinds of accessors, the result is the nearest 725 | common descendent in this diagram. Here are some examples: 726 | 727 | - An `isomorphism` composed with a `field` is a `field`. 728 | - A `field` composed with a `variant` is an `optional`. 729 | - A `getter` composed with a `variant` is an `optional_getter`. 730 | 731 | If you try to compose accessors with no common descendent, such as a 732 | `constructor` with a `mapper`, compilation fails with a type error. 733 | 734 | The diagram renders arrows in several colors, where each color 735 | represents a feature that is lost as you coerce an accessor from one 736 | kind to another. The features are, roughly: 737 | 738 | - **red**: accesses at least one value 739 | - **orange**: accesses at most one value 740 | - **yellow**: inner and outer types are the same 741 | - **green**: construct outer from inner 742 | - **blue**: extract inner from outer 743 | - **indigo**: update inner values within outer value 744 | 745 | Generalized operations 746 | ---------------------- 747 | 748 | We've been sneakily using several of these accessor kinds throughout 749 | the tutorial. Let's come clean, now. 750 | 751 | `Accessor.get` works on any `getter`. As you can see from the diagram, 752 | every `field` can be used as a `getter`. However, a `many` accessor 753 | cannot be used as a `getter`, which is why `Accessor.get` does not 754 | work with `Accessor.List.each`. 755 | 756 | ```ocaml 757 | let get : (unit -> 'a -> _, unit -> 'at -> _, [> getter ]) Accessor.General.t -> 'at -> 'a = 758 | Accessor.get 759 | ``` 760 | 761 | `Accessor.to_list` works on any `many_getter`. As you can see from the diagram, every 762 | `field` and every `many` can be used as a `many_getter`. This means you can use 763 | `Accessor.to_list` on a `field` even though it targets exactly one value; you just get a 764 | singleton list as a result. 765 | 766 | ```ocaml 767 | let to_list 768 | : (unit -> 'a -> _, unit -> 'at -> _, [> many_getter ]) Accessor.General.t -> 'at -> 'a list 769 | = Accessor.to_list 770 | ``` 771 | 772 | `Accessor.map` works on any `mapper`. The diagram shows that `field` accessors and `many` 773 | accessors both can be used as `mapper` accessors. However, the read-only accessors like 774 | `getter` and `many_getter` cannot be used as `mapper` accessors. 775 | 776 | ```ocaml 777 | let map 778 | : (unit -> 'a -> 'b, unit -> 'at -> 'bt, [> mapper ]) Accessor.General.t -> 'at 779 | -> f:('a -> 'b) -> 'bt 780 | = Accessor.map 781 | ``` 782 | 783 | Brief summary of each kind of accessor 784 | -------------------------------------- 785 | 786 | - `equality`: a proof that the outer and inner types are actually the same type 787 | - `isomorphism`: can convert back and forth between the outer and inner types 788 | - `field`: a getter and setter 789 | - `variant`: an optional getter and constructor 790 | - `optional`: like a field, but isn't sure that an inner value is present 791 | - `getter`: can get an inner from an outer 792 | - `constructor`: can create an outer from an inner 793 | - `optional_getter`: like a getter, but isn't sure that an inner value is present 794 | - `many`: like a field, but isn't sure how many inner values are present 795 | - `many_getter`: like a getter, but isn't sure how many inner values are present 796 | - `nonempty`: like a field, but has no upper bound on the count of inner values 797 | - `nonempty_getter`: like a getter, but has no upper bound on the count of inner values 798 | - `mapper`: can update/set the inner value(s) inside an outer value 799 | 800 | Applicative and monadic operations 801 | ================================== 802 | 803 | `Accessor` supports applicative and monadic code, too. For example, 804 | here are a couple versions of functions we've already seen, but which 805 | support using `Async`: 806 | 807 | ```ocaml 808 | let map 809 | : ?how:[ `Parallel | `Sequential ] 810 | -> (unit -> 'a -> 'b, unit -> 'at -> 'bt, [> many ]) Accessor.General.t 811 | -> 'at 812 | -> f:('a -> 'b Deferred.t) 813 | -> 'bt Deferred.t 814 | = Accessor.Deferred.map 815 | 816 | let iter 817 | : ?how:[ `Parallel | `Sequential ] 818 | -> (unit -> 'a -> _, unit -> 'at -> _, [> many_getter ]) Accessor.General.t 819 | -> 'at 820 | -> f:('a -> unit Deferred.t) 821 | -> unit Deferred.t 822 | = Accessor.Deferred.iter 823 | ``` 824 | 825 | There is a fairly large suite of monadic operations available, and 826 | `Accessor` is a good solution to the combinatorial explosion of 827 | operations that work on different data structures using different 828 | monads. 829 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.17) 2 | -------------------------------------------------------------------------------- /src/applicative_signatures_intf.ml: -------------------------------------------------------------------------------- 1 | open! Base 2 | open! Import 3 | open Subtyping 4 | 5 | module type Applicative_general = sig 6 | type ('inner, 'outer, 'kind) accessor 7 | type 'a optional_args 8 | type ('a, 'd, 'e) t 9 | 10 | val map 11 | : ((unit -> 'a -> 'b, unit -> 'at -> 'bt, [> many ]) accessor 12 | -> 'at 13 | -> f:('a -> ('b, 'd, 'e) t) 14 | -> ('bt, 'd, 'e) t) 15 | optional_args 16 | 17 | val mapi 18 | : (('i -> 'a -> 'b, unit -> 'at -> 'bt, [> many ]) accessor 19 | -> 'at 20 | -> f:('i Index.t -> 'a -> ('b, 'd, 'e) t) 21 | -> ('bt, 'd, 'e) t) 22 | optional_args 23 | 24 | val all 25 | : (unit -> ('a, 'd, 'e) t -> 'a, unit -> 'at -> 'bt, [> many ]) accessor 26 | -> 'at 27 | -> ('bt, 'd, 'e) t 28 | 29 | val all_unit 30 | : (unit -> (unit, 'd, 'e) t -> _, unit -> 'at -> _, [> many_getter ]) accessor 31 | -> 'at 32 | -> (unit, 'd, 'e) t 33 | 34 | val iter 35 | : ((unit -> 'a -> _, unit -> 'at -> _, [> many_getter ]) accessor 36 | -> 'at 37 | -> f:('a -> (unit, 'd, 'e) t) 38 | -> (unit, 'd, 'e) t) 39 | optional_args 40 | 41 | val iteri 42 | : (('i -> 'a -> _, unit -> 'at -> _, [> many_getter ]) accessor 43 | -> 'at 44 | -> f:('i Index.t -> 'a -> (unit, 'd, 'e) t) 45 | -> (unit, 'd, 'e) t) 46 | optional_args 47 | 48 | val sum 49 | : ((module Container.Summable with type t = 'sum) 50 | -> (unit -> 'a -> _, unit -> 'at -> _, [> many_getter ]) accessor 51 | -> 'at 52 | -> f:('a -> ('sum, 'd, 'e) t) 53 | -> ('sum, 'd, 'e) t) 54 | optional_args 55 | 56 | val sumi 57 | : ((module Container.Summable with type t = 'sum) 58 | -> ('i -> 'a -> _, unit -> 'at -> _, [> many_getter ]) accessor 59 | -> 'at 60 | -> f:('i Index.t -> 'a -> ('sum, 'd, 'e) t) 61 | -> ('sum, 'd, 'e) t) 62 | optional_args 63 | 64 | val count 65 | : ((unit -> 'a -> _, unit -> 'at -> _, [> many_getter ]) accessor 66 | -> 'at 67 | -> f:('a -> (bool, 'd, 'e) t) 68 | -> (int, 'd, 'e) t) 69 | optional_args 70 | 71 | val counti 72 | : (('i -> 'a -> _, unit -> 'at -> _, [> many_getter ]) accessor 73 | -> 'at 74 | -> f:('i Index.t -> 'a -> (bool, 'd, 'e) t) 75 | -> (int, 'd, 'e) t) 76 | optional_args 77 | 78 | val map_reduce 79 | : ((unit -> 'a -> _, unit -> 'at -> _, [> many_getter ]) accessor 80 | -> 'at 81 | -> empty:'b 82 | -> combine:('b -> 'b -> 'b) 83 | -> f:('a -> ('b, 'd, 'e) t) 84 | -> ('b, 'd, 'e) t) 85 | optional_args 86 | 87 | val map_reducei 88 | : (('i -> 'a -> _, unit -> 'at -> _, [> many_getter ]) accessor 89 | -> 'at 90 | -> empty:'b 91 | -> combine:('b -> 'b -> 'b) 92 | -> f:('i Index.t -> 'a -> ('b, 'd, 'e) t) 93 | -> ('b, 'd, 'e) t) 94 | optional_args 95 | 96 | val map_reduce_nonempty 97 | : ((unit -> 'a -> _, unit -> 'at -> _, [> nonempty_getter ]) accessor 98 | -> 'at 99 | -> combine:('b -> 'b -> 'b) 100 | -> f:('a -> ('b, 'd, 'e) t) 101 | -> ('b, 'd, 'e) t) 102 | optional_args 103 | 104 | val map_reduce_nonemptyi 105 | : (('i -> 'a -> _, unit -> 'at -> _, [> nonempty_getter ]) accessor 106 | -> 'at 107 | -> combine:('b -> 'b -> 'b) 108 | -> f:('i Index.t -> 'a -> ('b, 'd, 'e) t) 109 | -> ('b, 'd, 'e) t) 110 | optional_args 111 | end 112 | 113 | module type Applicative_without_return_general = sig 114 | type ('inner, 'outer, 'kind) accessor 115 | type 'a optional_args 116 | type ('a, 'd, 'e) t 117 | 118 | val map 119 | : ((unit -> 'a -> 'b, unit -> 'at -> 'bt, [> nonempty ]) accessor 120 | -> 'at 121 | -> f:('a -> ('b, 'd, 'e) t) 122 | -> ('bt, 'd, 'e) t) 123 | optional_args 124 | 125 | val mapi 126 | : (('i -> 'a -> 'b, unit -> 'at -> 'bt, [> nonempty ]) accessor 127 | -> 'at 128 | -> f:('i Index.t -> 'a -> ('b, 'd, 'e) t) 129 | -> ('bt, 'd, 'e) t) 130 | optional_args 131 | 132 | val iter 133 | : ((unit -> 'a -> _, unit -> 'at -> _, [> nonempty_getter ]) accessor 134 | -> 'at 135 | -> f:('a -> (unit, 'd, 'e) t) 136 | -> (unit, 'd, 'e) t) 137 | optional_args 138 | 139 | val iteri 140 | : (('i -> 'a -> _, unit -> 'at -> _, [> nonempty_getter ]) accessor 141 | -> 'at 142 | -> f:('i Index.t -> 'a -> (unit, 'd, 'e) t) 143 | -> (unit, 'd, 'e) t) 144 | optional_args 145 | 146 | val sum 147 | : ((module Container.Summable with type t = 'sum) 148 | -> (unit -> 'a -> _, unit -> 'at -> _, [> nonempty_getter ]) accessor 149 | -> 'at 150 | -> f:('a -> ('sum, 'd, 'e) t) 151 | -> ('sum, 'd, 'e) t) 152 | optional_args 153 | 154 | val sumi 155 | : ((module Container.Summable with type t = 'sum) 156 | -> ('i -> 'a -> _, unit -> 'at -> _, [> nonempty_getter ]) accessor 157 | -> 'at 158 | -> f:('i Index.t -> 'a -> ('sum, 'd, 'e) t) 159 | -> ('sum, 'd, 'e) t) 160 | optional_args 161 | 162 | val count 163 | : ((unit -> 'a -> _, unit -> 'at -> _, [> nonempty_getter ]) accessor 164 | -> 'at 165 | -> f:('a -> (bool, 'd, 'e) t) 166 | -> (int, 'd, 'e) t) 167 | optional_args 168 | 169 | val counti 170 | : (('i -> 'a -> _, unit -> 'at -> _, [> nonempty_getter ]) accessor 171 | -> 'at 172 | -> f:('i Index.t -> 'a -> (bool, 'd, 'e) t) 173 | -> (int, 'd, 'e) t) 174 | optional_args 175 | 176 | val all 177 | : (unit -> ('a, 'd, 'e) t -> 'a, unit -> 'at -> 'bt, [> nonempty ]) accessor 178 | -> 'at 179 | -> ('bt, 'd, 'e) t 180 | 181 | val all_unit 182 | : (unit -> (unit, 'd, 'e) t -> _, unit -> 'at -> _, [> nonempty_getter ]) accessor 183 | -> 'at 184 | -> (unit, 'd, 'e) t 185 | 186 | val map_reduce_nonempty 187 | : ((unit -> 'a -> _, unit -> 'at -> _, [> nonempty_getter ]) accessor 188 | -> 'at 189 | -> combine:('b -> 'b -> 'b) 190 | -> f:('a -> ('b, 'd, 'e) t) 191 | -> ('b, 'd, 'e) t) 192 | optional_args 193 | 194 | val map_reduce_nonemptyi 195 | : (('i -> 'a -> _, unit -> 'at -> _, [> nonempty_getter ]) accessor 196 | -> 'at 197 | -> combine:('b -> 'b -> 'b) 198 | -> f:('i Index.t -> 'a -> ('b, 'd, 'e) t) 199 | -> ('b, 'd, 'e) t) 200 | optional_args 201 | end 202 | 203 | module type Functor_s3 = sig 204 | type ('inner, 'outer, 'kind) accessor 205 | type ('a, 'd, 'e) t 206 | 207 | val map 208 | : (unit -> 'a -> 'b, unit -> 'at -> 'bt, [> field ]) accessor 209 | -> 'at 210 | -> f:('a -> ('b, 'd, 'e) t) 211 | -> ('bt, 'd, 'e) t 212 | 213 | val mapi 214 | : ('i -> 'a -> 'b, unit -> 'at -> 'bt, [> field ]) accessor 215 | -> 'at 216 | -> f:('i Index.t -> 'a -> ('b, 'd, 'e) t) 217 | -> ('bt, 'd, 'e) t 218 | 219 | val all 220 | : (unit -> ('a, 'd, 'e) t -> 'a, unit -> 'at -> 'bt, [> field ]) accessor 221 | -> 'at 222 | -> ('bt, 'd, 'e) t 223 | end 224 | 225 | module type Functor_s2 = sig 226 | type ('a, 'd) t 227 | 228 | include Functor_s3 with type ('a, 'd, _) t := ('a, 'd) t 229 | end 230 | 231 | module type Functor_s = sig 232 | type 'a t 233 | 234 | include Functor_s2 with type ('a, _) t := 'a t 235 | end 236 | 237 | module type Applicative_s3 = Applicative_general with type 'a optional_args := 'a 238 | 239 | module type Applicative_without_return_s3 = 240 | Applicative_without_return_general with type 'a optional_args := 'a 241 | 242 | module type Applicative_s2 = sig 243 | type ('a, 'e) t 244 | 245 | include Applicative_s3 with type ('a, _, 'e) t := ('a, 'e) t 246 | end 247 | 248 | module type Applicative_without_return_s2 = sig 249 | type ('a, 'e) t 250 | 251 | include Applicative_without_return_s3 with type ('a, _, 'e) t := ('a, 'e) t 252 | end 253 | 254 | module type Applicative_s = sig 255 | type 'a t 256 | 257 | include Applicative_s2 with type ('a, _) t := 'a t 258 | end 259 | 260 | module type Applicative_without_return_s = sig 261 | type 'a t 262 | 263 | include Applicative_without_return_s2 with type ('a, _) t := 'a t 264 | end 265 | 266 | module type Monad_s3 = sig 267 | include 268 | Applicative_general 269 | with type 'a optional_args := ?how:[ `Parallel | `Sequential ] -> 'a 270 | 271 | val fold 272 | : (unit -> 'a -> _, unit -> 'at -> _, [> many_getter ]) accessor 273 | -> 'at 274 | -> init:'acc 275 | -> f:('acc -> 'a -> ('acc, 'd, 'e) t) 276 | -> ('acc, 'd, 'e) t 277 | 278 | val foldi 279 | : ('i -> 'a -> _, unit -> 'at -> _, [> many_getter ]) accessor 280 | -> 'at 281 | -> init:'acc 282 | -> f:('i Index.t -> 'acc -> 'a -> ('acc, 'd, 'e) t) 283 | -> ('acc, 'd, 'e) t 284 | end 285 | 286 | module type Monad_without_return_s3 = sig 287 | include 288 | Applicative_without_return_general 289 | with type 'a optional_args := ?how:[ `Parallel | `Sequential ] -> 'a 290 | 291 | val fold 292 | : (unit -> 'a -> _, unit -> 'at -> _, [> nonempty_getter ]) accessor 293 | -> 'at 294 | -> init:'acc 295 | -> f:('acc -> 'a -> ('acc, 'd, 'e) t) 296 | -> ('acc, 'd, 'e) t 297 | 298 | val foldi 299 | : ('i -> 'a -> _, unit -> 'at -> _, [> nonempty_getter ]) accessor 300 | -> 'at 301 | -> init:'acc 302 | -> f:('i Index.t -> 'acc -> 'a -> ('acc, 'd, 'e) t) 303 | -> ('acc, 'd, 'e) t 304 | end 305 | 306 | module type Monad_s2 = sig 307 | type ('a, 'e) t 308 | 309 | include Monad_s3 with type ('a, _, 'e) t := ('a, 'e) t 310 | end 311 | 312 | module type Monad_without_return_s2 = sig 313 | type ('a, 'e) t 314 | 315 | include Monad_without_return_s3 with type ('a, _, 'e) t := ('a, 'e) t 316 | end 317 | 318 | module type Monad_s = sig 319 | type 'a t 320 | 321 | include Monad_s2 with type ('a, _) t := 'a t 322 | end 323 | 324 | module type Monad_without_return_s = sig 325 | type 'a t 326 | 327 | include Monad_without_return_s2 with type ('a, _) t := 'a t 328 | end 329 | -------------------------------------------------------------------------------- /src/custom_mappings_intf.ml: -------------------------------------------------------------------------------- 1 | open! Base 2 | open! Import 3 | open Subtyping 4 | 5 | module type S = sig 6 | type ('inner, 'outer, 'kind) accessor 7 | 8 | (** An [equality] can transform any mapping. There is no need for you to provide any 9 | functionality of your own. *) 10 | module Equality : sig 11 | module Make_access (T : sig 12 | type ('a, 'b) t 13 | end) : sig 14 | val access 15 | : ('i -> 'a -> 'b, 'it -> 'at -> 'bt, [> equality ]) accessor 16 | -> ('i Index.t * 'a, 'b) T.t 17 | -> ('it Index.t * 'at, 'bt) T.t 18 | end 19 | 20 | module Make_access3 (T : sig 21 | type ('a, 'b, 'c) t 22 | end) : sig 23 | val access 24 | : ('i -> 'a -> 'b, 'it -> 'at -> 'bt, [> equality ]) accessor 25 | -> ('i Index.t * 'a, 'b, 'c) T.t 26 | -> ('it Index.t * 'at, 'bt, 'c) T.t 27 | end 28 | 29 | module Make_access4 (T : sig 30 | type ('a, 'b, 'c, 'd) t 31 | end) : sig 32 | val access 33 | : ('i -> 'a -> 'b, 'it -> 'at -> 'bt, [> equality ]) accessor 34 | -> ('i Index.t * 'a, 'b, 'c, 'd) T.t 35 | -> ('it Index.t * 'at, 'bt, 'c, 'd) T.t 36 | end 37 | end 38 | 39 | module Isomorphism : sig 40 | module Make_access (T : sig 41 | type ('a, 'b) t 42 | 43 | (** A legal implementation of this function must satisfy the following properties: 44 | 45 | {[ 46 | isomorphism ~get:Fn.id ~construct:Fn.id = Fn.id 47 | ]} 48 | 49 | {[ 50 | Fn.compose 51 | (isomorphism ~get:g1 ~construct:c1) 52 | (isomorphism ~get:g2 ~construct:c2) 53 | = isomorphism ~get:(Fn.compose g2 g1) ~construct:(Fn.compose c1 c2) 54 | ]} *) 55 | val isomorphism 56 | : get:('at -> 'a) 57 | -> construct:('b -> 'bt) 58 | -> ('a, 'b) t 59 | -> ('at, 'bt) t 60 | end) : sig 61 | val access 62 | : ('i -> 'a -> 'b, 'it -> 'at -> 'bt, [> isomorphism ]) accessor 63 | -> ('i Index.t * 'a, 'b) T.t 64 | -> ('it Index.t * 'at, 'bt) T.t 65 | end 66 | 67 | module Make_access3 (T : sig 68 | type ('a, 'b, 'c) t 69 | 70 | val isomorphism 71 | : get:('at -> 'a) 72 | -> construct:('b -> 'bt) 73 | -> ('a, 'b, 'c) t 74 | -> ('at, 'bt, 'c) t 75 | end) : sig 76 | val access 77 | : ('i -> 'a -> 'b, 'it -> 'at -> 'bt, [> isomorphism ]) accessor 78 | -> ('i Index.t * 'a, 'b, 'c) T.t 79 | -> ('it Index.t * 'at, 'bt, 'c) T.t 80 | end 81 | 82 | module Make_access4 (T : sig 83 | type ('a, 'b, 'c, 'd) t 84 | 85 | val isomorphism 86 | : get:('at -> 'a) 87 | -> construct:('b -> 'bt) 88 | -> ('a, 'b, 'c, 'd) t 89 | -> ('at, 'bt, 'c, 'd) t 90 | end) : sig 91 | val access 92 | : ('i -> 'a -> 'b, 'it -> 'at -> 'bt, [> isomorphism ]) accessor 93 | -> ('i Index.t * 'a, 'b, 'c, 'd) T.t 94 | -> ('it Index.t * 'at, 'bt, 'c, 'd) T.t 95 | end 96 | end 97 | 98 | module Field : sig 99 | module Make_access (T : sig 100 | type ('a, 'b) t 101 | 102 | (** A legal implementation of this function must satisfy the following properties: 103 | 104 | {[ 105 | field (fun a -> a, Fn.id) = Fn.id 106 | ]} 107 | 108 | {[ 109 | Fn.compose (field f) (field g) 110 | = field (fun a -> 111 | let a, j = f a in 112 | let a, k = g a in 113 | a, Fn.compose j k) 114 | ]} *) 115 | val field : ('at -> 'a * ('b -> 'bt)) -> ('a, 'b) t -> ('at, 'bt) t 116 | end) : sig 117 | val access 118 | : ('i -> 'a -> 'b, 'it -> 'at -> 'bt, [> field ]) accessor 119 | -> ('i Index.t * 'a, 'b) T.t 120 | -> ('it Index.t * 'at, 'bt) T.t 121 | end 122 | 123 | module Make_access3 (T : sig 124 | type ('a, 'b, 'c) t 125 | 126 | val field : ('at -> 'a * ('b -> 'bt)) -> ('a, 'b, 'c) t -> ('at, 'bt, 'c) t 127 | end) : sig 128 | val access 129 | : ('i -> 'a -> 'b, 'it -> 'at -> 'bt, [> field ]) accessor 130 | -> ('i Index.t * 'a, 'b, 'c) T.t 131 | -> ('it Index.t * 'at, 'bt, 'c) T.t 132 | end 133 | 134 | module Make_access4 (T : sig 135 | type ('a, 'b, 'c, 'd) t 136 | 137 | val field 138 | : ('at -> 'a * ('b -> 'bt)) 139 | -> ('a, 'b, 'c, 'd) t 140 | -> ('at, 'bt, 'c, 'd) t 141 | end) : sig 142 | val access 143 | : ('i -> 'a -> 'b, 'it -> 'at -> 'bt, [> field ]) accessor 144 | -> ('i Index.t * 'a, 'b, 'c, 'd) T.t 145 | -> ('it Index.t * 'at, 'bt, 'c, 'd) T.t 146 | end 147 | end 148 | 149 | module Variant : sig 150 | module Make_access (T : sig 151 | type ('a, 'b) t 152 | 153 | (** A legal implementation of this function must satisfy the following properties: 154 | 155 | {[ 156 | variant ~match_:Either.first ~construct:Fn.id = Fn.id 157 | ]} 158 | 159 | {[ 160 | Fn.compose 161 | (variant ~match_:m1 ~construct:c1) 162 | (variant ~match_:m2 ~construct:c2) 163 | = variant 164 | ~match_:(fun a -> 165 | match m1 a with 166 | | Second _ as a -> a 167 | | First a -> 168 | (match m2 a with 169 | | First _ as a -> a 170 | | Second a -> Second (c1 a))) 171 | ~construct:(Fn.compose c1 c2) 172 | ]} *) 173 | val variant 174 | : match_:('at -> ('a, 'bt) Either.t) 175 | -> construct:('b -> 'bt) 176 | -> ('a, 'b) t 177 | -> ('at, 'bt) t 178 | end) : sig 179 | val access 180 | : ('i -> 'a -> 'b, 'it -> 'at -> 'bt, [> variant ]) accessor 181 | -> ('i Index.t * 'a, 'b) T.t 182 | -> ('it Index.t * 'at, 'bt) T.t 183 | end 184 | 185 | module Make_access3 (T : sig 186 | type ('a, 'b, 'c) t 187 | 188 | val variant 189 | : match_:('at -> ('a, 'bt) Either.t) 190 | -> construct:('b -> 'bt) 191 | -> ('a, 'b, 'c) t 192 | -> ('at, 'bt, 'c) t 193 | end) : sig 194 | val access 195 | : ('i -> 'a -> 'b, 'it -> 'at -> 'bt, [> variant ]) accessor 196 | -> ('i Index.t * 'a, 'b, 'c) T.t 197 | -> ('it Index.t * 'at, 'bt, 'c) T.t 198 | end 199 | 200 | module Make_access4 (T : sig 201 | type ('a, 'b, 'c, 'd) t 202 | 203 | val variant 204 | : match_:('at -> ('a, 'bt) Either.t) 205 | -> construct:('b -> 'bt) 206 | -> ('a, 'b, 'c, 'd) t 207 | -> ('at, 'bt, 'c, 'd) t 208 | end) : sig 209 | val access 210 | : ('i -> 'a -> 'b, 'it -> 'at -> 'bt, [> variant ]) accessor 211 | -> ('i Index.t * 'a, 'b, 'c, 'd) T.t 212 | -> ('it Index.t * 'at, 'bt, 'c, 'd) T.t 213 | end 214 | end 215 | 216 | module Constructor : sig 217 | module Make_access (T : sig 218 | type ('a, 'b) t 219 | 220 | (** A legal implementation of this function must satisfy the following properties: 221 | 222 | {[ 223 | constructor Fn.id = Fn.id 224 | ]} 225 | 226 | {[ 227 | Fn.compose (construct f) (construct g) = construct (Fn.compose f g) 228 | ]} *) 229 | val constructor : ('b -> 'bt) -> ('a, 'b) t -> ('at, 'bt) t 230 | end) : sig 231 | val access 232 | : ('i -> 'a -> 'b, 'it -> 'at -> 'bt, [> constructor ]) accessor 233 | -> ('i Index.t * 'a, 'b) T.t 234 | -> ('it Index.t * 'at, 'bt) T.t 235 | end 236 | 237 | module Make_access3 (T : sig 238 | type ('a, 'b, 'c) t 239 | 240 | val constructor : ('b -> 'bt) -> ('a, 'b, 'c) t -> ('at, 'bt, 'c) t 241 | end) : sig 242 | val access 243 | : ('i -> 'a -> 'b, 'it -> 'at -> 'bt, [> constructor ]) accessor 244 | -> ('i Index.t * 'a, 'b, 'c) T.t 245 | -> ('it Index.t * 'at, 'bt, 'c) T.t 246 | end 247 | 248 | module Make_access4 (T : sig 249 | type ('a, 'b, 'c, 'd) t 250 | 251 | val constructor : ('b -> 'bt) -> ('a, 'b, 'c, 'd) t -> ('at, 'bt, 'c, 'd) t 252 | end) : sig 253 | val access 254 | : ('i -> 'a -> 'b, 'it -> 'at -> 'bt, [> constructor ]) accessor 255 | -> ('i Index.t * 'a, 'b, 'c, 'd) T.t 256 | -> ('it Index.t * 'at, 'bt, 'c, 'd) T.t 257 | end 258 | end 259 | 260 | module Getter : sig 261 | module Make_access (T : sig 262 | type ('a, 'b) t 263 | 264 | (** A legal implementation of this function must satisfy the following properties: 265 | 266 | {[ 267 | getter Fn.id = Fn.id 268 | ]} 269 | 270 | {[ 271 | Fn.compose (getter f) (getter g) = getter (Fn.compose g f) 272 | ]} *) 273 | val getter : ('at -> 'a) -> ('a, 'b) t -> ('at, 'bt) t 274 | end) : sig 275 | val access 276 | : ('i -> 'a -> 'b, 'it -> 'at -> 'bt, [> getter ]) accessor 277 | -> ('i Index.t * 'a, 'b) T.t 278 | -> ('it Index.t * 'at, 'bt) T.t 279 | end 280 | 281 | module Make_access3 (T : sig 282 | type ('a, 'b, 'c) t 283 | 284 | val getter : ('at -> 'a) -> ('a, 'b, 'c) t -> ('at, 'bt, 'c) t 285 | end) : sig 286 | val access 287 | : ('i -> 'a -> 'b, 'it -> 'at -> 'bt, [> getter ]) accessor 288 | -> ('i Index.t * 'a, 'b, 'c) T.t 289 | -> ('it Index.t * 'at, 'bt, 'c) T.t 290 | end 291 | 292 | module Make_access4 (T : sig 293 | type ('a, 'b, 'c, 'd) t 294 | 295 | val getter : ('at -> 'a) -> ('a, 'b, 'c, 'd) t -> ('at, 'bt, 'c, 'd) t 296 | end) : sig 297 | val access 298 | : ('i -> 'a -> 'b, 'it -> 'at -> 'bt, [> getter ]) accessor 299 | -> ('i Index.t * 'a, 'b, 'c, 'd) T.t 300 | -> ('it Index.t * 'at, 'bt, 'c, 'd) T.t 301 | end 302 | end 303 | 304 | module Optional : sig 305 | module Make_access (T : sig 306 | type ('a, 'b) t 307 | 308 | (** A legal implementation of this function must satisfy the following properties: 309 | 310 | {[ 311 | optional (fun a -> First (a, Fn.id)) = Fn.id 312 | ]} 313 | 314 | {[ 315 | Fn.compose (optional f) (optional g) 316 | = optional (fun a -> 317 | match f a with 318 | | Second _ as a -> a 319 | | First (a, j) -> 320 | (match g a with 321 | | First (a, k) -> First (a, Fn.compose j k) 322 | | Second a -> Second (j a))) 323 | ]} *) 324 | val optional 325 | : ('at -> ('a * ('b -> 'bt), 'bt) Either.t) 326 | -> ('a, 'b) t 327 | -> ('at, 'bt) t 328 | end) : sig 329 | val access 330 | : ('i -> 'a -> 'b, 'it -> 'at -> 'bt, [> optional ]) accessor 331 | -> ('i Index.t * 'a, 'b) T.t 332 | -> ('it Index.t * 'at, 'bt) T.t 333 | end 334 | 335 | module Make_access3 (T : sig 336 | type ('a, 'b, 'c) t 337 | 338 | val optional 339 | : ('at -> ('a * ('b -> 'bt), 'bt) Either.t) 340 | -> ('a, 'b, 'c) t 341 | -> ('at, 'bt, 'c) t 342 | end) : sig 343 | val access 344 | : ('i -> 'a -> 'b, 'it -> 'at -> 'bt, [> optional ]) accessor 345 | -> ('i Index.t * 'a, 'b, 'c) T.t 346 | -> ('it Index.t * 'at, 'bt, 'c) T.t 347 | end 348 | 349 | module Make_access4 (T : sig 350 | type ('a, 'b, 'c, 'd) t 351 | 352 | val optional 353 | : ('at -> ('a * ('b -> 'bt), 'bt) Either.t) 354 | -> ('a, 'b, 'c, 'd) t 355 | -> ('at, 'bt, 'c, 'd) t 356 | end) : sig 357 | val access 358 | : ('i -> 'a -> 'b, 'it -> 'at -> 'bt, [> optional ]) accessor 359 | -> ('i Index.t * 'a, 'b, 'c, 'd) T.t 360 | -> ('it Index.t * 'at, 'bt, 'c, 'd) T.t 361 | end 362 | end 363 | 364 | module Optional_getter : sig 365 | module Make_access (T : sig 366 | type ('a, 'b) t 367 | 368 | (** A legal implementation of this function must satisfy the following properties: 369 | 370 | {[ 371 | optional_getter Option.some = Fn.id 372 | ]} 373 | 374 | {[ 375 | Fn.compose (optional_getter f) (optional_getter g) 376 | = optional_getter (fun a -> Option.bind (f a) ~f:g) 377 | ]} *) 378 | val optional_getter : ('at -> 'a option) -> ('a, 'b) t -> ('at, 'bt) t 379 | end) : sig 380 | val access 381 | : ('i -> 'a -> 'b, 'it -> 'at -> 'bt, [> optional_getter ]) accessor 382 | -> ('i Index.t * 'a, 'b) T.t 383 | -> ('it Index.t * 'at, 'bt) T.t 384 | end 385 | 386 | module Make_access3 (T : sig 387 | type ('a, 'b, 'c) t 388 | 389 | val optional_getter : ('at -> 'a option) -> ('a, 'b, 'c) t -> ('at, 'bt, 'c) t 390 | end) : sig 391 | val access 392 | : ('i -> 'a -> 'b, 'it -> 'at -> 'bt, [> optional_getter ]) accessor 393 | -> ('i Index.t * 'a, 'b, 'c) T.t 394 | -> ('it Index.t * 'at, 'bt, 'c) T.t 395 | end 396 | 397 | module Make_access4 (T : sig 398 | type ('a, 'b, 'c, 'd) t 399 | 400 | val optional_getter 401 | : ('at -> 'a option) 402 | -> ('a, 'b, 'c, 'd) t 403 | -> ('at, 'bt, 'c, 'd) t 404 | end) : sig 405 | val access 406 | : ('i -> 'a -> 'b, 'it -> 'at -> 'bt, [> optional_getter ]) accessor 407 | -> ('i Index.t * 'a, 'b, 'c, 'd) T.t 408 | -> ('it Index.t * 'at, 'bt, 'c, 'd) T.t 409 | end 410 | end 411 | 412 | module Nonempty : sig 413 | include module type of Nonempty (** @inline *) 414 | 415 | (** Access everything that the given accessor accesses. *) 416 | val access_nonempty 417 | : (unit -> 'a -> 'b, unit -> 'at -> 'bt, [> nonempty ]) accessor 418 | -> 'at 419 | -> ('bt, 'a, 'b) t 420 | 421 | module Let_syntax : sig 422 | include module type of Nonempty.Let_syntax 423 | 424 | module Let_syntax : sig 425 | include module type of Nonempty.Let_syntax.Let_syntax 426 | 427 | module Open_on_rhs : sig 428 | include module type of Nonempty.Let_syntax.Let_syntax.Open_on_rhs 429 | 430 | val access_nonempty 431 | : (unit -> 'a -> 'b, unit -> 'at -> 'bt, [> nonempty ]) accessor 432 | -> 'at 433 | -> ('bt, 'a, 'b) t 434 | end 435 | end 436 | end 437 | 438 | module Accessor : 439 | Applicative_signatures_intf.Applicative_without_return_s3 440 | with type ('a, 'd, 'e) t := ('a, 'd, 'e) t 441 | with type ('inner, 'outer, 'kind) accessor := ('inner, 'outer, 'kind) accessor 442 | 443 | module Make_access (T : sig 444 | type ('a, 'b) t 445 | 446 | (** A legal implementation of this function must satisfy the following properties: 447 | 448 | {[ 449 | nonempty Nonempty.Accessed.return = Fn.id 450 | ]} 451 | 452 | {[ 453 | Fn.compose (nonempty f) (nonempty g) 454 | = nonempty (fun at -> Nonempty.Accessed.bind (f at) ~f:g) 455 | ]} *) 456 | val nonempty : ('at -> ('bt, 'a, 'b) Nonempty.t) -> ('a, 'b) t -> ('at, 'bt) t 457 | end) : sig 458 | val access 459 | : ('i -> 'a -> 'b, 'it -> 'at -> 'bt, [> nonempty ]) accessor 460 | -> ('i Index.t * 'a, 'b) T.t 461 | -> ('it Index.t * 'at, 'bt) T.t 462 | end 463 | 464 | module Make_access3 (T : sig 465 | type ('a, 'b, 'c) t 466 | 467 | val nonempty 468 | : ('at -> ('bt, 'a, 'b) Nonempty.t) 469 | -> ('a, 'b, 'c) t 470 | -> ('at, 'bt, 'c) t 471 | end) : sig 472 | val access 473 | : ('i -> 'a -> 'b, 'it -> 'at -> 'bt, [> nonempty ]) accessor 474 | -> ('i Index.t * 'a, 'b, 'c) T.t 475 | -> ('it Index.t * 'at, 'bt, 'c) T.t 476 | end 477 | 478 | module Make_access4 (T : sig 479 | type ('a, 'b, 'c, 'd) t 480 | 481 | val nonempty 482 | : ('at -> ('bt, 'a, 'b) Nonempty.t) 483 | -> ('a, 'b, 'c, 'd) t 484 | -> ('at, 'bt, 'c, 'd) t 485 | end) : sig 486 | val access 487 | : ('i -> 'a -> 'b, 'it -> 'at -> 'bt, [> nonempty ]) accessor 488 | -> ('i Index.t * 'a, 'b, 'c, 'd) T.t 489 | -> ('it Index.t * 'at, 'bt, 'c, 'd) T.t 490 | end 491 | end 492 | 493 | module Nonempty_getter : sig 494 | include module type of Nonempty_getter (** @inline *) 495 | 496 | module Make_access (T : sig 497 | type ('a, 'b) t 498 | 499 | (** A legal implementation of this function must satisfy the following properties: 500 | 501 | {[ 502 | nonempty_getter Nonempty_getter.return = Fn.id 503 | ]} 504 | 505 | {[ 506 | Fn.compose (nonempty_getter f) (nonempty_getter g) 507 | = nonempty_getter (fun at -> Nonempty_getter.bind (f at) ~f:g) 508 | ]} *) 509 | val nonempty_getter : ('at -> 'a Nonempty_getter.t) -> ('a, 'b) t -> ('at, 'bt) t 510 | end) : sig 511 | val access 512 | : ('i -> 'a -> 'b, 'it -> 'at -> 'bt, [> nonempty_getter ]) accessor 513 | -> ('i Index.t * 'a, 'b) T.t 514 | -> ('it Index.t * 'at, 'bt) T.t 515 | end 516 | 517 | module Make_access3 (T : sig 518 | type ('a, 'b, 'c) t 519 | 520 | val nonempty_getter 521 | : ('at -> 'a Nonempty_getter.t) 522 | -> ('a, 'b, 'c) t 523 | -> ('at, 'bt, 'c) t 524 | end) : sig 525 | val access 526 | : ('i -> 'a -> 'b, 'it -> 'at -> 'bt, [> nonempty_getter ]) accessor 527 | -> ('i Index.t * 'a, 'b, 'c) T.t 528 | -> ('it Index.t * 'at, 'bt, 'c) T.t 529 | end 530 | 531 | module Make_access4 (T : sig 532 | type ('a, 'b, 'c, 'd) t 533 | 534 | val nonempty_getter 535 | : ('at -> 'a Nonempty_getter.t) 536 | -> ('a, 'b, 'c, 'd) t 537 | -> ('at, 'bt, 'c, 'd) t 538 | end) : sig 539 | val access 540 | : ('i -> 'a -> 'b, 'it -> 'at -> 'bt, [> nonempty_getter ]) accessor 541 | -> ('i Index.t * 'a, 'b, 'c, 'd) T.t 542 | -> ('it Index.t * 'at, 'bt, 'c, 'd) T.t 543 | end 544 | end 545 | 546 | module Many : sig 547 | include module type of Many (** @inline *) 548 | 549 | (** Access everything that the given accessor accesses. *) 550 | val access_many 551 | : (unit -> 'a -> 'b, unit -> 'at -> 'bt, [> many ]) accessor 552 | -> 'at 553 | -> ('bt, 'a, 'b) t 554 | 555 | module Let_syntax : sig 556 | include module type of Many.Let_syntax 557 | 558 | module Let_syntax : sig 559 | include module type of Many.Let_syntax.Let_syntax 560 | 561 | module Open_on_rhs : sig 562 | include module type of Many.Let_syntax.Let_syntax.Open_on_rhs 563 | 564 | val access_many 565 | : (unit -> 'a -> 'b, unit -> 'at -> 'bt, [> many ]) accessor 566 | -> 'at 567 | -> ('bt, 'a, 'b) t 568 | end 569 | end 570 | end 571 | 572 | module Accessor : 573 | Applicative_signatures_intf.Applicative_s3 574 | with type ('a, 'd, 'e) t := ('a, 'd, 'e) t 575 | with type ('inner, 'outer, 'kind) accessor := ('inner, 'outer, 'kind) accessor 576 | 577 | module Make_access (T : sig 578 | type ('a, 'b) t 579 | 580 | (** A legal implementation of this function must satisfy the following properties: 581 | 582 | {[ 583 | many Many.Accessed.return = Fn.id 584 | ]} 585 | 586 | {[ 587 | Fn.compose (many f) (many g) 588 | = many (fun at -> Many.Accessed.bind (f at) ~f:g) 589 | ]} *) 590 | val many : ('at -> ('bt, 'a, 'b) Many.t) -> ('a, 'b) t -> ('at, 'bt) t 591 | end) : sig 592 | val access 593 | : ('i -> 'a -> 'b, 'it -> 'at -> 'bt, [> many ]) accessor 594 | -> ('i Index.t * 'a, 'b) T.t 595 | -> ('it Index.t * 'at, 'bt) T.t 596 | end 597 | 598 | module Make_access3 (T : sig 599 | type ('a, 'b, 'c) t 600 | 601 | val many : ('at -> ('bt, 'a, 'b) Many.t) -> ('a, 'b, 'c) t -> ('at, 'bt, 'c) t 602 | end) : sig 603 | val access 604 | : ('i -> 'a -> 'b, 'it -> 'at -> 'bt, [> many ]) accessor 605 | -> ('i Index.t * 'a, 'b, 'c) T.t 606 | -> ('it Index.t * 'at, 'bt, 'c) T.t 607 | end 608 | 609 | module Make_access4 (T : sig 610 | type ('a, 'b, 'c, 'd) t 611 | 612 | val many 613 | : ('at -> ('bt, 'a, 'b) Many.t) 614 | -> ('a, 'b, 'c, 'd) t 615 | -> ('at, 'bt, 'c, 'd) t 616 | end) : sig 617 | val access 618 | : ('i -> 'a -> 'b, 'it -> 'at -> 'bt, [> many ]) accessor 619 | -> ('i Index.t * 'a, 'b, 'c, 'd) T.t 620 | -> ('it Index.t * 'at, 'bt, 'c, 'd) T.t 621 | end 622 | end 623 | 624 | module Many_getter : sig 625 | include module type of Many_getter (** @inline *) 626 | 627 | module Make_access (T : sig 628 | type ('a, 'b) t 629 | 630 | (** A legal implementation of this function must satisfy the following properties: 631 | 632 | {[ 633 | many_getter Many_getter.return = Fn.id 634 | ]} 635 | 636 | {[ 637 | Fn.compose (many_getter f) (many_getter g) 638 | = many_getter (fun at -> Many_getter.bind (f at) ~f:g) 639 | ]} *) 640 | val many_getter : ('at -> 'a Many_getter.t) -> ('a, 'b) t -> ('at, 'bt) t 641 | end) : sig 642 | val access 643 | : ('i -> 'a -> 'b, 'it -> 'at -> 'bt, [> many_getter ]) accessor 644 | -> ('i Index.t * 'a, 'b) T.t 645 | -> ('it Index.t * 'at, 'bt) T.t 646 | end 647 | 648 | module Make_access3 (T : sig 649 | type ('a, 'b, 'c) t 650 | 651 | val many_getter : ('at -> 'a Many_getter.t) -> ('a, 'b, 'c) t -> ('at, 'bt, 'c) t 652 | end) : sig 653 | val access 654 | : ('i -> 'a -> 'b, 'it -> 'at -> 'bt, [> many_getter ]) accessor 655 | -> ('i Index.t * 'a, 'b, 'c) T.t 656 | -> ('it Index.t * 'at, 'bt, 'c) T.t 657 | end 658 | 659 | module Make_access4 (T : sig 660 | type ('a, 'b, 'c, 'd) t 661 | 662 | val many_getter 663 | : ('at -> 'a Many_getter.t) 664 | -> ('a, 'b, 'c, 'd) t 665 | -> ('at, 'bt, 'c, 'd) t 666 | end) : sig 667 | val access 668 | : ('i -> 'a -> 'b, 'it -> 'at -> 'bt, [> many_getter ]) accessor 669 | -> ('i Index.t * 'a, 'b, 'c, 'd) T.t 670 | -> ('it Index.t * 'at, 'bt, 'c, 'd) T.t 671 | end 672 | end 673 | 674 | module Mapper : sig 675 | module Make_access (T : sig 676 | type ('a, 'b) t 677 | 678 | (** A legal implementation of this function must satisfy the following properties: 679 | 680 | {[ 681 | mapper (fun a ~f -> f a) = Fn.id 682 | ]} 683 | 684 | {[ 685 | Fn.compose (mapper f) (mapper g) = mapper (fun a ~f:h -> f a ~f:(g ~f:h)) 686 | ]} *) 687 | val mapper : ('at -> f:('a -> 'b) -> 'bt) -> ('a, 'b) t -> ('at, 'bt) t 688 | end) : sig 689 | val access 690 | : ('i -> 'a -> 'b, 'it -> 'at -> 'bt, [> mapper ]) accessor 691 | -> ('i Index.t * 'a, 'b) T.t 692 | -> ('it Index.t * 'at, 'bt) T.t 693 | end 694 | 695 | module Make_access3 (T : sig 696 | type ('a, 'b, 'c) t 697 | 698 | val mapper : ('at -> f:('a -> 'b) -> 'bt) -> ('a, 'b, 'c) t -> ('at, 'bt, 'c) t 699 | end) : sig 700 | val access 701 | : ('i -> 'a -> 'b, 'it -> 'at -> 'bt, [> mapper ]) accessor 702 | -> ('i Index.t * 'a, 'b, 'c) T.t 703 | -> ('it Index.t * 'at, 'bt, 'c) T.t 704 | end 705 | 706 | module Make_access4 (T : sig 707 | type ('a, 'b, 'c, 'd) t 708 | 709 | val mapper 710 | : ('at -> f:('a -> 'b) -> 'bt) 711 | -> ('a, 'b, 'c, 'd) t 712 | -> ('at, 'bt, 'c, 'd) t 713 | end) : sig 714 | val access 715 | : ('i -> 'a -> 'b, 'it -> 'at -> 'bt, [> mapper ]) accessor 716 | -> ('i Index.t * 'a, 'b, 'c, 'd) T.t 717 | -> ('it Index.t * 'at, 'bt, 'c, 'd) T.t 718 | end 719 | end 720 | end 721 | -------------------------------------------------------------------------------- /src/dictionary.ml: -------------------------------------------------------------------------------- 1 | open! Base 2 | open! Import 3 | open Subtyping 4 | 5 | (* This module is inspired by the approach described in the paper "Profunctor Optics", by 6 | Matthew Pickering, Jeremy Gibbons, and Nicolas Wu. Although there are significant 7 | differences, it's probably worth at least taking a look at in order to understand the 8 | ideas behind this module. *) 9 | 10 | module Create = struct 11 | (* These types stand in for type class dictionaries. For example, an [Isomorphism.t] is 12 | like an instance of the following type class as would be written in Haskell: 13 | 14 | {v 15 | class Isomorphism w where 16 | f : (at -> a) -> (b -> bt) -> w a b -> w at bt 17 | v} *) 18 | 19 | module Isomorphism = struct 20 | type 'w t = 21 | { f : 22 | 'a 'b 'at 'bt. 23 | get:('at -> 'a) 24 | -> construct:('b -> 'bt) 25 | -> ('a, 'b, 'w) Hk.t2 26 | -> ('at, 'bt, 'w) Hk.t2 27 | } 28 | [@@unboxed] 29 | end 30 | 31 | module Field = struct 32 | type 'w t = 33 | { f : 34 | 'a 'b 'at 'bt. 35 | ('at -> 'a * ('b -> 'bt)) -> ('a, 'b, 'w) Hk.t2 -> ('at, 'bt, 'w) Hk.t2 36 | } 37 | [@@unboxed] 38 | end 39 | 40 | module Variant = struct 41 | type 'w t = 42 | { f : 43 | 'a 'b 'at 'bt. 44 | match_:('at -> ('a, 'bt) Either.t) 45 | -> construct:('b -> 'bt) 46 | -> ('a, 'b, 'w) Hk.t2 47 | -> ('at, 'bt, 'w) Hk.t2 48 | } 49 | [@@unboxed] 50 | end 51 | 52 | module Constructor = struct 53 | type 'w t = 54 | { f : 'a 'b 'at 'bt. ('b -> 'bt) -> ('a, 'b, 'w) Hk.t2 -> ('at, 'bt, 'w) Hk.t2 } 55 | [@@unboxed] 56 | end 57 | 58 | module Getter = struct 59 | type 'w t = 60 | { f : 'a 'b 'at 'bt. ('at -> 'a) -> ('a, 'b, 'w) Hk.t2 -> ('at, 'bt, 'w) Hk.t2 } 61 | [@@unboxed] 62 | end 63 | 64 | module Optional = struct 65 | type 'w t = 66 | { f : 67 | 'a 'b 'at 'bt. 68 | ('at -> ('a * ('b -> 'bt), 'bt) Either.t) 69 | -> ('a, 'b, 'w) Hk.t2 70 | -> ('at, 'bt, 'w) Hk.t2 71 | } 72 | [@@unboxed] 73 | end 74 | 75 | module Optional_getter = struct 76 | type 'w t = 77 | { f : 78 | 'a 'b 'at 'bt. ('at -> 'a option) -> ('a, 'b, 'w) Hk.t2 -> ('at, 'bt, 'w) Hk.t2 79 | } 80 | [@@unboxed] 81 | end 82 | 83 | module Nonempty = struct 84 | type 'w t = 85 | { f : 86 | 'a 'b 'at 'bt. 87 | ('at -> ('bt, 'a, 'b) Nonempty.t) -> ('a, 'b, 'w) Hk.t2 -> ('at, 'bt, 'w) Hk.t2 88 | } 89 | [@@unboxed] 90 | end 91 | 92 | module Nonempty_getter = struct 93 | type 'w t = 94 | { f : 95 | 'a 'b 'at 'bt. 96 | ('at -> 'a Nonempty_getter.t) -> ('a, 'b, 'w) Hk.t2 -> ('at, 'bt, 'w) Hk.t2 97 | } 98 | [@@unboxed] 99 | end 100 | 101 | module Many = struct 102 | type 'w t = 103 | { f : 104 | 'a 'b 'at 'bt. 105 | ('at -> ('bt, 'a, 'b) Many.t) -> ('a, 'b, 'w) Hk.t2 -> ('at, 'bt, 'w) Hk.t2 106 | } 107 | [@@unboxed] 108 | end 109 | 110 | module Many_getter = struct 111 | type 'w t = 112 | { f : 113 | 'a 'b 'at 'bt. 114 | ('at -> 'a Many_getter.t) -> ('a, 'b, 'w) Hk.t2 -> ('at, 'bt, 'w) Hk.t2 115 | } 116 | [@@unboxed] 117 | end 118 | 119 | module Mapper = struct 120 | type 'w t = 121 | { f : 122 | 'a 'b 'at 'bt. 123 | ('at -> f:('a -> 'b) -> 'bt) -> ('a, 'b, 'w) Hk.t2 -> ('at, 'bt, 'w) Hk.t2 124 | } 125 | [@@unboxed] 126 | end 127 | 128 | (* The type classes above are related with this GADT, using a phantom polymorphic 129 | variant type index. *) 130 | type ('c, 'w) t = 131 | | Equality : ([> equality ], _) t 132 | | Isomorphism : 'w Isomorphism.t -> ([> isomorphism ], 'w) t 133 | | Field : 'w Field.t -> ([> field ], 'w) t 134 | | Variant : 'w Variant.t -> ([> variant ], 'w) t 135 | | Constructor : 'w Constructor.t -> ([> constructor ], 'w) t 136 | | Getter : 'w Getter.t -> ([> getter ], 'w) t 137 | | Optional : 'w Optional.t -> ([> optional ], 'w) t 138 | | Optional_getter : 'w Optional_getter.t -> ([> optional_getter ], 'w) t 139 | | Nonempty : 'w Nonempty.t -> ([> nonempty ], 'w) t 140 | | Nonempty_getter : 'w Nonempty_getter.t -> ([> nonempty_getter ], 'w) t 141 | | Many : 'w Many.t -> ([> many ], 'w) t 142 | | Many_getter : 'w Many_getter.t -> ([> many_getter ], 'w) t 143 | | Mapper : 'w Mapper.t -> ([> mapper ], 'w) t 144 | 145 | let equality = Equality 146 | let isomorphism isomorphism = Isomorphism isomorphism 147 | let field field = Field field 148 | let variant variant = Variant variant 149 | let constructor constructor = Constructor constructor 150 | let getter getter = Getter getter 151 | let optional optional = Optional optional 152 | let optional_getter optional_getter = Optional_getter optional_getter 153 | let nonempty nonempty = Nonempty nonempty 154 | let nonempty_getter nonempty_getter = Nonempty_getter nonempty_getter 155 | let many many = Many many 156 | let many_getter many_getter = Many_getter many_getter 157 | let mapper mapper = Mapper mapper 158 | end 159 | 160 | type nonrec ('c, 'w) t = ('c, 'w) Create.t 161 | 162 | module Run = struct 163 | (* These functions define how the coercions between different kinds of accessors 164 | actually work. For example, an accessor that is defined as a field can be used as a 165 | getter, so the [field] function includes a case for [Getter], and in that case it 166 | only uses the [get] ability of the defined field. *) 167 | 168 | let equality (_ : _ t) = Fn.id 169 | 170 | (* The [*_hack] type constructors are a way to introduce a "restricted locally abstract 171 | type variable". Imagine if one could both declare a locally abstract variable: {[ 172 | 173 | let constructor (type a) (t : (a, 'w) t) = 174 | 175 | ]} and also constrain its type: {[ 176 | 177 | let constructor (t : ([< constructor ], 'w) t) = 178 | 179 | ]}. The compiler understands this, but OCaml has no concrete syntax to create them 180 | directly. Instead we arrange our code so that the type checker chooses to introduce 181 | such a variable for us. *) 182 | 183 | type 'w constructor_hack = 184 | | Constructor_hack : ([< constructor ], 'w) t -> 'w constructor_hack 185 | [@@unboxed] 186 | 187 | let constructor t = 188 | let (Constructor_hack (Constructor { f })) = Constructor_hack t in 189 | f 190 | ;; 191 | 192 | type 'w field_hack = Field_hack : ([< field ], 'w) t -> 'w field_hack [@@unboxed] 193 | 194 | let field t field_f = 195 | let (Field_hack t) = Field_hack t in 196 | match t with 197 | | Field { f } -> f field_f 198 | | Getter { f } -> f (fun at -> fst (field_f at)) 199 | | Optional { f } -> f (fun at -> First (field_f at)) 200 | | Optional_getter { f } -> f (fun at -> Some (fst (field_f at))) 201 | | Nonempty { f } -> 202 | f (fun at -> 203 | let open Nonempty.Let_syntax in 204 | let a, construct = field_f at in 205 | let%map b = Nonempty.access a in 206 | construct b) 207 | | Nonempty_getter { f } -> f (fun at -> Nonempty_getter.access (fst (field_f at))) 208 | | Many { f } -> 209 | f (fun at -> 210 | let open Many.Let_syntax in 211 | let a, construct = field_f at in 212 | let%map b = Many.access a in 213 | construct b) 214 | | Many_getter { f } -> f (fun at -> Many_getter.access (fst (field_f at))) 215 | | Mapper { f } -> 216 | f (fun at ~f -> 217 | let a, construct = field_f at in 218 | construct (f a)) 219 | ;; 220 | 221 | type 'w getter_hack = Getter_hack : ([< getter ], 'w) t -> 'w getter_hack [@@unboxed] 222 | 223 | let getter t get = 224 | let (Getter_hack t) = Getter_hack t in 225 | match t with 226 | | Getter { f } -> f get 227 | | Optional_getter { f } -> f (fun at -> Some (get at)) 228 | | Nonempty_getter { f } -> f (fun at -> Nonempty_getter.access (get at)) 229 | | Many_getter { f } -> f (fun at -> Many_getter.access (get at)) 230 | ;; 231 | 232 | type 'w isomorphism_hack = 233 | | Isomorphism_hack : ([< isomorphism ], 'w) t -> 'w isomorphism_hack 234 | [@@unboxed] 235 | 236 | let isomorphism t ~get ~construct = 237 | let (Isomorphism_hack t) = Isomorphism_hack t in 238 | match t with 239 | | Isomorphism { f } -> f ~get ~construct 240 | | Field { f } -> f (fun at -> get at, construct) 241 | | Variant { f } -> f ~match_:(fun at -> First (get at)) ~construct 242 | | Constructor { f } -> f construct 243 | | Getter { f } -> f get 244 | | Optional { f } -> f (fun at -> First (get at, construct)) 245 | | Optional_getter { f } -> f (fun at -> Some (get at)) 246 | | Nonempty { f } -> 247 | f (fun at -> 248 | let open Nonempty.Let_syntax in 249 | let%map b = Nonempty.access (get at) in 250 | construct b) 251 | | Nonempty_getter { f } -> f (fun at -> Nonempty_getter.access (get at)) 252 | | Many { f } -> 253 | f (fun at -> 254 | let open Many.Let_syntax in 255 | let%map b = Many.access (get at) in 256 | construct b) 257 | | Many_getter { f } -> f (fun at -> Many_getter.access (get at)) 258 | | Mapper { f } -> f (fun at ~f -> construct (f (get at))) 259 | ;; 260 | 261 | type 'w mapper_hack = Mapper_hack : ([< mapper ], 'w) t -> 'w mapper_hack [@@unboxed] 262 | 263 | let mapper t = 264 | let (Mapper_hack (Mapper { f })) = Mapper_hack t in 265 | f 266 | ;; 267 | 268 | type 'w many_hack = Many_hack : ([< many ], 'w) t -> 'w many_hack [@@unboxed] 269 | 270 | let many t traverse = 271 | let (Many_hack t) = Many_hack t in 272 | match t with 273 | | Many { f } -> f traverse 274 | | Many_getter { f } -> f (fun at -> Many_getter.of_many (traverse at)) 275 | | Mapper { f } -> f (fun at ~f -> Ident.of_many (traverse at) ~access:f) 276 | ;; 277 | 278 | type 'w many_getter_hack = 279 | | Many_getter_hack : ([< many_getter ], 'w) t -> 'w many_getter_hack 280 | [@@unboxed] 281 | 282 | let many_getter t = 283 | let (Many_getter_hack (Many_getter { f })) = Many_getter_hack t in 284 | f 285 | ;; 286 | 287 | type 'w nonempty_hack = Nonempty_hack : ([< nonempty ], 'w) t -> 'w nonempty_hack 288 | [@@unboxed] 289 | 290 | let nonempty t traverse = 291 | let (Nonempty_hack t) = Nonempty_hack t in 292 | match t with 293 | | Nonempty { f } -> f traverse 294 | | Nonempty_getter { f } -> f (fun at -> Nonempty_getter.of_nonempty (traverse at)) 295 | | Many { f } -> f (fun at -> Many.of_nonempty (traverse at)) 296 | | Many_getter { f } -> f (fun at -> Many_getter.of_nonempty (traverse at)) 297 | | Mapper { f } -> f (fun at ~f -> Ident.of_nonempty (traverse at) ~access:f) 298 | ;; 299 | 300 | type 'w nonempty_getter_hack = 301 | | Nonempty_getter_hack : ([< nonempty_getter ], 'w) t -> 'w nonempty_getter_hack 302 | [@@unboxed] 303 | 304 | let nonempty_getter t traverse = 305 | let (Nonempty_getter_hack t) = Nonempty_getter_hack t in 306 | match t with 307 | | Nonempty_getter { f } -> f traverse 308 | | Many_getter { f } -> f (fun at -> Many_getter.of_nonempty_getter (traverse at)) 309 | ;; 310 | 311 | type 'w optional_hack = Optional_hack : ([< optional ], 'w) t -> 'w optional_hack 312 | [@@unboxed] 313 | 314 | let optional t optional_f = 315 | let (Optional_hack t) = Optional_hack t in 316 | match t with 317 | | Optional { f } -> f optional_f 318 | | Optional_getter { f } -> 319 | f (fun at -> 320 | match optional_f at with 321 | | First (a, _) -> Some a 322 | | Second _ -> None) 323 | | Many { f } -> 324 | f (fun at -> 325 | let open Many.Let_syntax in 326 | match optional_f at with 327 | | Either.First (a, construct) -> Many.access a >>| construct 328 | | Second bt -> return bt) 329 | | Many_getter { f } -> 330 | f (fun at -> 331 | match optional_f at with 332 | | Either.First (a, _) -> Many_getter.access a 333 | | Second _ -> Many_getter.empty) 334 | | Mapper { f } -> 335 | f (fun at ~f -> 336 | match optional_f at with 337 | | Either.First (a, construct) -> construct (f a) 338 | | Second bt -> bt) 339 | ;; 340 | 341 | type 'w optional_getter_hack = 342 | | Optional_getter_hack : ([< optional_getter ], 'w) t -> 'w optional_getter_hack 343 | [@@unboxed] 344 | 345 | let optional_getter t get_option = 346 | let (Optional_getter_hack t) = Optional_getter_hack t in 347 | match t with 348 | | Optional_getter { f } -> f get_option 349 | | Many_getter { f } -> 350 | f (fun at -> 351 | match get_option at with 352 | | Some a -> Many_getter.access a 353 | | None -> Many_getter.empty) 354 | ;; 355 | 356 | type 'w variant_hack = Variant_hack : ([< variant ], 'w) t -> 'w variant_hack 357 | [@@unboxed] 358 | 359 | let variant t ~match_ ~construct = 360 | let (Variant_hack t) = Variant_hack t in 361 | match t with 362 | | Variant { f } -> f ~match_ ~construct 363 | | Constructor { f } -> f construct 364 | | Optional { f } -> 365 | f (fun at -> 366 | match match_ at with 367 | | First a -> First (a, construct) 368 | | Second _ as bt -> bt) 369 | | Optional_getter { f } -> 370 | f (fun at -> 371 | match match_ at with 372 | | First a -> Some a 373 | | Second _ -> None) 374 | | Many { f } -> 375 | f (fun at -> 376 | let open Many.Let_syntax in 377 | match match_ at with 378 | | Either.First a -> Many.access a >>| construct 379 | | Second bt -> return bt) 380 | | Many_getter { f } -> 381 | f (fun at -> 382 | match match_ at with 383 | | Either.First a -> Many_getter.access a 384 | | Second _ -> Many_getter.empty) 385 | | Mapper { f } -> 386 | f (fun at ~f -> 387 | match match_ at with 388 | | Either.First a -> construct (f a) 389 | | Second bt -> bt) 390 | ;; 391 | end 392 | -------------------------------------------------------------------------------- /src/dictionary.mli: -------------------------------------------------------------------------------- 1 | open! Base 2 | open! Import 3 | open Subtyping 4 | 5 | (** A [(c, w) t] explains how to construct a mapping from some specification. For example, 6 | an [(isomorphism, w) t] knows how to convert the specification containing [get] and 7 | [construct] functions into a function over mappings witnessed by [w]. *) 8 | type ('c, 'w) t 9 | 10 | module Create : sig 11 | module Isomorphism : sig 12 | type 'w t = 13 | { f : 14 | 'a 'b 'at 'bt. 15 | get:('at -> 'a) 16 | -> construct:('b -> 'bt) 17 | -> ('a, 'b, 'w) Hk.t2 18 | -> ('at, 'bt, 'w) Hk.t2 19 | } 20 | [@@unboxed] 21 | end 22 | 23 | module Field : sig 24 | type 'w t = 25 | { f : 26 | 'a 'b 'at 'bt. 27 | ('at -> 'a * ('b -> 'bt)) -> ('a, 'b, 'w) Hk.t2 -> ('at, 'bt, 'w) Hk.t2 28 | } 29 | [@@unboxed] 30 | end 31 | 32 | module Variant : sig 33 | type 'w t = 34 | { f : 35 | 'a 'b 'at 'bt. 36 | match_:('at -> ('a, 'bt) Either.t) 37 | -> construct:('b -> 'bt) 38 | -> ('a, 'b, 'w) Hk.t2 39 | -> ('at, 'bt, 'w) Hk.t2 40 | } 41 | [@@unboxed] 42 | end 43 | 44 | module Constructor : sig 45 | type 'w t = 46 | { f : 'a 'b 'at 'bt. ('b -> 'bt) -> ('a, 'b, 'w) Hk.t2 -> ('at, 'bt, 'w) Hk.t2 } 47 | [@@unboxed] 48 | end 49 | 50 | module Getter : sig 51 | type 'w t = 52 | { f : 'a 'b 'at 'bt. ('at -> 'a) -> ('a, 'b, 'w) Hk.t2 -> ('at, 'bt, 'w) Hk.t2 } 53 | [@@unboxed] 54 | end 55 | 56 | module Optional : sig 57 | type 'w t = 58 | { f : 59 | 'a 'b 'at 'bt. 60 | ('at -> ('a * ('b -> 'bt), 'bt) Either.t) 61 | -> ('a, 'b, 'w) Hk.t2 62 | -> ('at, 'bt, 'w) Hk.t2 63 | } 64 | [@@unboxed] 65 | end 66 | 67 | module Optional_getter : sig 68 | type 'w t = 69 | { f : 70 | 'a 'b 'at 'bt. ('at -> 'a option) -> ('a, 'b, 'w) Hk.t2 -> ('at, 'bt, 'w) Hk.t2 71 | } 72 | [@@unboxed] 73 | end 74 | 75 | module Nonempty : sig 76 | type 'w t = 77 | { f : 78 | 'a 'b 'at 'bt. 79 | ('at -> ('bt, 'a, 'b) Nonempty.t) -> ('a, 'b, 'w) Hk.t2 -> ('at, 'bt, 'w) Hk.t2 80 | } 81 | [@@unboxed] 82 | end 83 | 84 | module Nonempty_getter : sig 85 | type 'w t = 86 | { f : 87 | 'a 'b 'at 'bt. 88 | ('at -> 'a Nonempty_getter.t) -> ('a, 'b, 'w) Hk.t2 -> ('at, 'bt, 'w) Hk.t2 89 | } 90 | [@@unboxed] 91 | end 92 | 93 | module Many : sig 94 | type 'w t = 95 | { f : 96 | 'a 'b 'at 'bt. 97 | ('at -> ('bt, 'a, 'b) Many.t) -> ('a, 'b, 'w) Hk.t2 -> ('at, 'bt, 'w) Hk.t2 98 | } 99 | [@@unboxed] 100 | end 101 | 102 | module Many_getter : sig 103 | type 'w t = 104 | { f : 105 | 'a 'b 'at 'bt. 106 | ('at -> 'a Many_getter.t) -> ('a, 'b, 'w) Hk.t2 -> ('at, 'bt, 'w) Hk.t2 107 | } 108 | [@@unboxed] 109 | end 110 | 111 | module Mapper : sig 112 | type 'w t = 113 | { f : 114 | 'a 'b 'at 'bt. 115 | ('at -> f:('a -> 'b) -> 'bt) -> ('a, 'b, 'w) Hk.t2 -> ('at, 'bt, 'w) Hk.t2 116 | } 117 | [@@unboxed] 118 | end 119 | 120 | val equality : ([> equality ], _) t 121 | val isomorphism : 'w Isomorphism.t -> ([> isomorphism ], 'w) t 122 | val field : 'w Field.t -> ([> field ], 'w) t 123 | val variant : 'w Variant.t -> ([> variant ], 'w) t 124 | val constructor : 'w Constructor.t -> ([> constructor ], 'w) t 125 | val getter : 'w Getter.t -> ([> getter ], 'w) t 126 | val optional : 'w Optional.t -> ([> optional ], 'w) t 127 | val optional_getter : 'w Optional_getter.t -> ([> optional_getter ], 'w) t 128 | val nonempty : 'w Nonempty.t -> ([> nonempty ], 'w) t 129 | val nonempty_getter : 'w Nonempty_getter.t -> ([> nonempty_getter ], 'w) t 130 | val many : 'w Many.t -> ([> many ], 'w) t 131 | val many_getter : 'w Many_getter.t -> ([> many_getter ], 'w) t 132 | val mapper : 'w Mapper.t -> ([> mapper ], 'w) t 133 | end 134 | 135 | module Run : sig 136 | val equality : (_, 'w) t -> ('a, 'b, 'w) Hk.t2 -> ('a, 'b, 'w) Hk.t2 137 | 138 | val constructor 139 | : ([< constructor ], 'w) t 140 | -> ('b -> 'bt) 141 | -> ('a, 'b, 'w) Hk.t2 142 | -> ('at, 'bt, 'w) Hk.t2 143 | 144 | val field 145 | : ([< field ], 'w) t 146 | -> ('at -> 'a * ('b -> 'bt)) 147 | -> ('a, 'b, 'w) Hk.t2 148 | -> ('at, 'bt, 'w) Hk.t2 149 | 150 | val getter 151 | : ([< getter ], 'w) t 152 | -> ('at -> 'a) 153 | -> ('a, 'b, 'w) Hk.t2 154 | -> ('at, 'bt, 'w) Hk.t2 155 | 156 | val isomorphism 157 | : ([< isomorphism ], 'w) t 158 | -> get:('at -> 'a) 159 | -> construct:('b -> 'bt) 160 | -> ('a, 'b, 'w) Hk.t2 161 | -> ('at, 'bt, 'w) Hk.t2 162 | 163 | val mapper 164 | : ([< mapper ], 'w) t 165 | -> ('at -> f:('a -> 'b) -> 'bt) 166 | -> ('a, 'b, 'w) Hk.t2 167 | -> ('at, 'bt, 'w) Hk.t2 168 | 169 | val many 170 | : ([< many ], 'w) t 171 | -> ('at -> ('bt, 'a, 'b) Many.t) 172 | -> ('a, 'b, 'w) Hk.t2 173 | -> ('at, 'bt, 'w) Hk.t2 174 | 175 | val many_getter 176 | : ([< many_getter ], 'w) t 177 | -> ('at -> 'a Many_getter.t) 178 | -> ('a, 'b, 'w) Hk.t2 179 | -> ('at, 'bt, 'w) Hk.t2 180 | 181 | val nonempty 182 | : ([< nonempty ], 'w) t 183 | -> ('at -> ('bt, 'a, 'b) Nonempty.t) 184 | -> ('a, 'b, 'w) Hk.t2 185 | -> ('at, 'bt, 'w) Hk.t2 186 | 187 | val nonempty_getter 188 | : ([< nonempty_getter ], 'w) t 189 | -> ('at -> 'a Nonempty_getter.t) 190 | -> ('a, 'b, 'w) Hk.t2 191 | -> ('at, 'bt, 'w) Hk.t2 192 | 193 | val optional 194 | : ([< optional ], 'w) t 195 | -> ('at -> ('a * ('b -> 'bt), 'bt) Either.t) 196 | -> ('a, 'b, 'w) Hk.t2 197 | -> ('at, 'bt, 'w) Hk.t2 198 | 199 | val optional_getter 200 | : ([< optional_getter ], 'w) t 201 | -> ('at -> 'a option) 202 | -> ('a, 'b, 'w) Hk.t2 203 | -> ('at, 'bt, 'w) Hk.t2 204 | 205 | val variant 206 | : ([< variant ], 'w) t 207 | -> match_:('at -> ('a, 'bt) Either.t) 208 | -> construct:('b -> 'bt) 209 | -> ('a, 'b, 'w) Hk.t2 210 | -> ('at, 'bt, 'w) Hk.t2 211 | end 212 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name accessor) 3 | (public_name accessor) 4 | (libraries applicative_without_return base higher_kinded) 5 | (preprocess 6 | (pps ppx_jane))) 7 | -------------------------------------------------------------------------------- /src/ident.ml: -------------------------------------------------------------------------------- 1 | open! Base 2 | open! Import 3 | 4 | module T = struct 5 | include Monad.Ident 6 | 7 | let apply t1 t2 = t1 t2 8 | end 9 | 10 | include T 11 | include Many.Of_applicative (T) 12 | include Nonempty.Of_applicative_without_return (T) 13 | -------------------------------------------------------------------------------- /src/ident.mli: -------------------------------------------------------------------------------- 1 | open! Base 2 | open! Import 3 | 4 | (** An applicative used to convert a [many] into a [mapper]. *) 5 | type 'a t = 'a 6 | 7 | val of_many : ('bt, 'a, 'b) Many.t -> access:('a -> 'b t) -> 'bt t 8 | val of_nonempty : ('bt, 'a, 'b) Nonempty.t -> access:('a -> 'b t) -> 'bt t 9 | -------------------------------------------------------------------------------- /src/import.ml: -------------------------------------------------------------------------------- 1 | module Hk = Higher_kinded 2 | -------------------------------------------------------------------------------- /src/index.ml: -------------------------------------------------------------------------------- 1 | open! Base 2 | open! Import 3 | 4 | type 'a t = 5 | | [] : unit t 6 | | ( :: ) : 'a * 'b t -> ('a * 'b) t 7 | 8 | let hd (hd :: _) = hd 9 | let tl (_ :: tl) = tl 10 | 11 | let rec tail_recursive_with_tuple : type a r. a t -> f:(a -> r) -> r = 12 | fun t ~f -> 13 | match t with 14 | | [] -> f () 15 | | hd :: tl -> tail_recursive_with_tuple tl ~f:(fun tl -> f (hd, tl)) 16 | ;; 17 | 18 | let to_tuple t = tail_recursive_with_tuple t ~f:Fn.id 19 | let hash_fold_t hash_fold_tuple hash_state t = hash_fold_tuple hash_state (to_tuple t) 20 | 21 | (* renders like a list *) 22 | let sexp_of_t sexp_of_tuple = 23 | let rec loop acc = function 24 | | Sexp.List [] -> Sexp.List (List.rev acc) 25 | | Sexp.List [ sexp; sexps ] -> loop (sexp :: acc) sexps 26 | | (Sexp.Atom _ | Sexp.List [ _ ] | Sexp.List (_ :: _ :: _)) as sexp -> 27 | raise_s 28 | [%message 29 | "Bug in Index.sexp_of_t: unexpected nested sexp for nested tuple" 30 | (sexp : Sexp.t)] 31 | in 32 | fun t -> loop [] (sexp_of_tuple (to_tuple t)) 33 | ;; 34 | -------------------------------------------------------------------------------- /src/index.mli: -------------------------------------------------------------------------------- 1 | open! Base 2 | open! Import 3 | 4 | (** A stack of indices accumulated during traversal of a data structure. *) 5 | type 'a t = 6 | | [] : unit t 7 | | ( :: ) : 'a * 'b t -> ('a * 'b) t 8 | [@@deriving hash, sexp_of] 9 | 10 | val hd : ('hd * _) t -> 'hd 11 | val tl : (_ * 'tl) t -> 'tl t 12 | -------------------------------------------------------------------------------- /src/many.ml: -------------------------------------------------------------------------------- 1 | open! Base 2 | open! Import 3 | 4 | module Applicative = struct 5 | type 'w t = 6 | { return : 'a. 'a -> ('a, 'w) Hk.t1 7 | ; map : 'a 'b. ('a, 'w) Hk.t1 -> f:('a -> 'b) -> ('b, 'w) Hk.t1 8 | ; apply : 'a 'b. ('a -> 'b, 'w) Hk.t1 -> ('a, 'w) Hk.t1 -> ('b, 'w) Hk.t1 9 | } 10 | end 11 | 12 | module T = struct 13 | type ('bt, 'a, 'b) t = 14 | { f : 'w. 'w Applicative.t -> access:('a -> ('b, 'w) Hk.t1) -> ('bt, 'w) Hk.t1 } 15 | [@@unboxed] 16 | 17 | let access a = { f = (fun _ ~access -> access a) } 18 | 19 | include Base.Applicative.Make3 (struct 20 | type nonrec ('bt, 'a, 'b) t = ('bt, 'a, 'b) t 21 | 22 | let return a = { f = (fun applicative ~access:_ -> applicative.return a) } 23 | 24 | let map t ~f = 25 | { f = (fun applicative ~access -> applicative.map (t.f applicative ~access) ~f) } 26 | ;; 27 | 28 | let map = `Custom map 29 | 30 | let apply t1 t2 = 31 | { f = 32 | (fun applicative ~access -> 33 | applicative.apply (t1.f applicative ~access) (t2.f applicative ~access)) 34 | } 35 | ;; 36 | end) 37 | end 38 | 39 | include T 40 | 41 | module Open_on_rhs_intf = struct 42 | module type S = sig 43 | val access : 'a -> ('b, 'a, 'b) t 44 | end 45 | end 46 | 47 | include 48 | Base.Applicative.Make_let_syntax3 (T) (Open_on_rhs_intf) 49 | (struct 50 | let access = access 51 | end) 52 | 53 | module Accessed = Monad.Make_indexed (struct 54 | type nonrec ('a, 'bt, 'b) t = ('bt, 'a, 'b) t 55 | 56 | let return = access 57 | 58 | let map t ~f = 59 | { f = (fun applicative ~access -> t.f applicative ~access:(fun a -> access (f a))) } 60 | ;; 61 | 62 | let bind t ~f = 63 | { f = 64 | (fun applicative ~access -> 65 | t.f applicative ~access:(fun a -> (f a).f applicative ~access)) 66 | } 67 | ;; 68 | 69 | let map = `Custom map 70 | end) 71 | 72 | module Of_applicative3 (A : sig 73 | type ('a, 'd, 'e) t 74 | 75 | val return : 'a -> ('a, _, _) t 76 | val map : ('a, 'd, 'e) t -> f:('a -> 'b) -> ('b, 'd, 'e) t 77 | val apply : ('a -> 'b, 'd, 'e) t -> ('a, 'd, 'e) t -> ('b, 'd, 'e) t 78 | end) = 79 | struct 80 | module H = Hk.Make3 (A) 81 | 82 | let applicative = 83 | { Applicative.return = (fun a -> H.inject (A.return a)) 84 | ; map = (fun a ~f -> H.inject (A.map (H.project a) ~f)) 85 | ; apply = (fun a b -> H.inject (A.apply (H.project a) (H.project b))) 86 | } 87 | ;; 88 | 89 | let of_many t ~access = 90 | H.project (t.f applicative ~access:(fun a -> H.inject (access a))) 91 | ;; 92 | end 93 | 94 | module Of_applicative2 (A : sig 95 | type ('a, 'e) t 96 | 97 | val return : 'a -> ('a, _) t 98 | val map : ('a, 'e) t -> f:('a -> 'b) -> ('b, 'e) t 99 | val apply : ('a -> 'b, 'e) t -> ('a, 'e) t -> ('b, 'e) t 100 | end) = 101 | Of_applicative3 (struct 102 | type ('a, _, 'e) t = ('a, 'e) A.t 103 | 104 | include (A : module type of A with type ('a, 'e) t := ('a, 'e) A.t) 105 | end) 106 | 107 | module Of_applicative (A : sig 108 | type 'a t 109 | 110 | val return : 'a -> 'a t 111 | val map : 'a t -> f:('a -> 'b) -> 'b t 112 | val apply : ('a -> 'b) t -> 'a t -> 'b t 113 | end) = 114 | Of_applicative2 (struct 115 | type ('a, _) t = 'a A.t 116 | 117 | include (A : module type of A with type 'a t := 'a A.t) 118 | end) 119 | 120 | include Nonempty.Of_applicative_without_return3 (T) 121 | 122 | let of_nonempty nonempty = of_nonempty nonempty ~access 123 | -------------------------------------------------------------------------------- /src/many.mli: -------------------------------------------------------------------------------- 1 | open! Base 2 | open! Import 3 | 4 | (** An [(a, x, y) t] is an applicative for defining [many] accessors. See the 5 | documentation of [Accessor.many] for more information. 6 | 7 | A value of type [(a, x, y) t] can make the following claim: I can give you some number 8 | of [x]es and if you tell me how to replace each of them with a [y], I will also give 9 | you an [a]. *) 10 | type ('a, +'x, 'y) t 11 | 12 | module Accessed : Monad.S_indexed with type ('x, 'a, 'y) t := ('a, 'x, 'y) t 13 | 14 | (** [access a] "accesses" [a] and returns the value you are expected replace it with. *) 15 | val access : 'a -> ('b, 'a, 'b) t 16 | 17 | val of_nonempty : ('a, 'x, 'y) Nonempty.t -> ('a, 'x, 'y) t 18 | 19 | module Of_applicative (A : sig 20 | type 'a t 21 | 22 | val return : 'a -> 'a t 23 | val map : 'a t -> f:('a -> 'b) -> 'b t 24 | val apply : ('a -> 'b) t -> 'a t -> 'b t 25 | end) : sig 26 | val of_many : ('bt, 'a, 'b) t -> access:('a -> 'b A.t) -> 'bt A.t 27 | end 28 | 29 | module Of_applicative2 (A : sig 30 | type ('a, 'e) t 31 | 32 | val return : 'a -> ('a, 'e) t 33 | val map : ('a, 'e) t -> f:('a -> 'b) -> ('b, 'e) t 34 | val apply : ('a -> 'b, 'e) t -> ('a, 'e) t -> ('b, 'e) t 35 | end) : sig 36 | val of_many : ('bt, 'a, 'b) t -> access:('a -> ('b, 'e) A.t) -> ('bt, 'e) A.t 37 | end 38 | 39 | module Of_applicative3 (A : sig 40 | type ('a, 'd, 'e) t 41 | 42 | val return : 'a -> ('a, _, _) t 43 | val map : ('a, 'd, 'e) t -> f:('a -> 'b) -> ('b, 'd, 'e) t 44 | val apply : ('a -> 'b, 'd, 'e) t -> ('a, 'd, 'e) t -> ('b, 'd, 'e) t 45 | end) : sig 46 | val of_many : ('bt, 'a, 'b) t -> access:('a -> ('b, 'd, 'e) A.t) -> ('bt, 'd, 'e) A.t 47 | end 48 | 49 | module Open_on_rhs_intf : sig 50 | module type S = sig 51 | val access : 'a -> ('b, 'a, 'b) t 52 | end 53 | end 54 | 55 | include Applicative.S3 with type ('a, 'b, 'c) t := ('a, 'b, 'c) t 56 | 57 | include 58 | Applicative.Let_syntax3 59 | with type ('a, 'b, 'c) t := ('a, 'b, 'c) t 60 | with module Open_on_rhs_intf := Open_on_rhs_intf 61 | -------------------------------------------------------------------------------- /src/many_getter.ml: -------------------------------------------------------------------------------- 1 | open! Base 2 | open! Import 3 | 4 | type 'a t = { f : 'r. empty:'r -> combine:('r -> 'r -> 'r) -> f:('a -> 'r) -> 'r } 5 | [@@unboxed] 6 | 7 | let access a = { f = (fun ~empty:_ ~combine:_ ~f -> f a) } 8 | 9 | let of_list ts = 10 | { f = 11 | (fun ~empty ~combine ~f -> 12 | List.map ts ~f:(fun t -> t.f ~empty ~combine ~f) 13 | |> List.reduce ~f:combine 14 | |> Option.value ~default:empty) 15 | } 16 | ;; 17 | 18 | include Monad.Make (struct 19 | type nonrec 'a t = 'a t 20 | 21 | let return = access 22 | 23 | let map t ~f = 24 | { f = (fun ~empty ~combine ~f:g -> t.f ~empty ~combine ~f:(fun a -> g (f a))) } 25 | ;; 26 | 27 | let bind t ~f = 28 | { f = 29 | (fun ~empty ~combine ~f:g -> 30 | t.f ~empty ~combine ~f:(fun a -> (f a).f ~empty ~combine ~f:g)) 31 | } 32 | ;; 33 | 34 | let map = `Custom map 35 | end) 36 | 37 | let empty = { f = (fun ~empty ~combine:_ ~f:_ -> empty) } 38 | let map_reduce t = t.f 39 | 40 | let append t1 t2 = 41 | { f = 42 | (fun ~empty ~combine ~f -> 43 | let a = t1.f ~empty ~combine ~f in 44 | let b = t2.f ~empty ~combine ~f in 45 | combine a b) 46 | } 47 | ;; 48 | 49 | module O = struct 50 | let ( @ ) = append 51 | end 52 | 53 | include O 54 | 55 | include Many.Of_applicative2 (struct 56 | type nonrec (_, 'a) t = 'a t 57 | 58 | let return _ = empty 59 | let map t ~f:_ = t 60 | let apply = append 61 | end) 62 | 63 | let of_many many = of_many many ~access 64 | let of_nonempty nonempty = of_many (Many.of_nonempty nonempty) 65 | 66 | let of_nonempty_getter nonempty_getter = 67 | Nonempty_getter.map_reduce nonempty_getter ~combine:append ~f:access 68 | ;; 69 | -------------------------------------------------------------------------------- /src/many_getter.mli: -------------------------------------------------------------------------------- 1 | open! Base 2 | open! Import 3 | 4 | (** [t] is an appendable type for defining [many_getter] accessors. See the documentation 5 | of [Accessor.many_getter] for more information. *) 6 | type +'a t 7 | 8 | include Monad.S with type 'a t := 'a t 9 | 10 | (** [access a] "accesses" [a]. *) 11 | val access : 'a -> 'a t 12 | 13 | (** Don't access anything. *) 14 | val empty : _ t 15 | 16 | (** [append a b] accesses everything [a] accesses, then accesses everything [b] accesses. *) 17 | val append : 'a t -> 'a t -> 'a t 18 | 19 | (** Append all the [t]s in a list together. *) 20 | val of_list : 'a t list -> 'a t 21 | 22 | module O : sig 23 | val ( @ ) : 'a t -> 'a t -> 'a t 24 | end 25 | 26 | include module type of O 27 | 28 | val map_reduce : 'a t -> empty:'r -> combine:('r -> 'r -> 'r) -> f:('a -> 'r) -> 'r 29 | val of_many : (_, 'a, _) Many.t -> 'a t 30 | val of_nonempty : (_, 'a, _) Nonempty.t -> 'a t 31 | val of_nonempty_getter : 'a Nonempty_getter.t -> 'a t 32 | -------------------------------------------------------------------------------- /src/mapping.ml: -------------------------------------------------------------------------------- 1 | open! Base 2 | open! Import 3 | 4 | type ('m, 'w) t = T : ('i Index.t * 'a, 'b, 'w) Hk.t2 -> ('i -> 'a -> 'b, 'w) t 5 | [@@unboxed] 6 | 7 | let with_hk f (T t) = T (f t) 8 | 9 | module Make4 (T : sig 10 | type ('a, 'b, 'c, 'd) t 11 | end) = 12 | struct 13 | include Hk.Make4 (T) 14 | 15 | let projected t ~f = inject (f (project t)) 16 | 17 | let injected t ~f = 18 | let (T t) = f (T (inject t)) in 19 | project t 20 | ;; 21 | end 22 | -------------------------------------------------------------------------------- /src/mapping.mli: -------------------------------------------------------------------------------- 1 | open! Base 2 | open! Import 3 | 4 | (** An [(i -> a -> b, w) t] is some mapping from [i] and [a] to [b]. [w] determines what 5 | kind of mapping it is. *) 6 | type (_, _) t 7 | 8 | val with_hk 9 | : (('a Index.t * 'b, 'c, 'd) Hk.t2 -> ('e Index.t * 'f, 'g, 'h) Hk.t2) 10 | -> ('a -> 'b -> 'c, 'd) t 11 | -> ('e -> 'f -> 'g, 'h) t 12 | 13 | module Make4 (T : sig 14 | type ('a, 'b, 'c, 'd) t 15 | end) : sig 16 | include Hk.S4 with type ('a, 'b, 'c, 'd) t := ('a, 'b, 'c, 'd) T.t 17 | 18 | val projected 19 | : ('a, 'b, 'c, 'd, higher_kinded) Higher_kinded.t4 20 | -> f:(('a, 'b, 'c, 'd) T.t -> ('e, 'f, 'g, 'h) T.t) 21 | -> ('e, 'f, 'g, 'h, higher_kinded) Higher_kinded.t4 22 | 23 | val injected 24 | : ('a Index.t * 'b, 'c, 'd, 'e) T.t 25 | -> f: 26 | (('a -> 'b -> 'c, 'd -> 'e -> higher_kinded) t 27 | -> ('f -> 'g -> 'h, 'i -> 'j -> higher_kinded) t) 28 | -> ('f Index.t * 'g, 'h, 'i, 'j) T.t 29 | end 30 | -------------------------------------------------------------------------------- /src/nonempty.ml: -------------------------------------------------------------------------------- 1 | open! Base 2 | open! Import 3 | 4 | module Applicative = struct 5 | type 'w t = 6 | { map : 'a 'b. ('a, 'w) Hk.t1 -> f:('a -> 'b) -> ('b, 'w) Hk.t1 7 | ; apply : 'a 'b. ('a -> 'b, 'w) Hk.t1 -> ('a, 'w) Hk.t1 -> ('b, 'w) Hk.t1 8 | } 9 | end 10 | 11 | type ('bt, 'a, 'b) t = 12 | { f : 'w. 'w Applicative.t -> access:('a -> ('b, 'w) Hk.t1) -> ('bt, 'w) Hk.t1 } 13 | [@@unboxed] 14 | 15 | let access a = { f = (fun _ ~access -> access a) } 16 | 17 | module Accessed = Monad.Make_indexed (struct 18 | type nonrec ('a, 'bt, 'b) t = ('bt, 'a, 'b) t 19 | 20 | let return = access 21 | 22 | let map t ~f = 23 | { f = (fun applicative ~access -> t.f applicative ~access:(fun a -> access (f a))) } 24 | ;; 25 | 26 | let bind t ~f = 27 | { f = 28 | (fun applicative ~access -> 29 | t.f applicative ~access:(fun a -> (f a).f applicative ~access)) 30 | } 31 | ;; 32 | 33 | let map = `Custom map 34 | end) 35 | 36 | module A1 = Applicative_without_return.Make3 (struct 37 | type nonrec ('bt, 'a, 'b) t = ('bt, 'a, 'b) t 38 | 39 | let map t ~f = 40 | { f = (fun applicative ~access -> applicative.map (t.f applicative ~access) ~f) } 41 | ;; 42 | 43 | let apply t1 t2 = 44 | { f = 45 | (fun applicative ~access -> 46 | applicative.apply (t1.f applicative ~access) (t2.f applicative ~access)) 47 | } 48 | ;; 49 | end) 50 | 51 | module A2 : module type of A1 with module Let_syntax := A1.Let_syntax = A1 52 | include A2 53 | 54 | module Let_syntax = struct 55 | include A2 56 | 57 | module Let_syntax = struct 58 | include A2 59 | 60 | module Open_on_rhs = struct 61 | let access = access 62 | end 63 | end 64 | end 65 | 66 | module Of_applicative_without_return3 (A : sig 67 | type ('a, 'e, 'f) t 68 | 69 | val map : ('a, 'e, 'f) t -> f:('a -> 'b) -> ('b, 'e, 'f) t 70 | val apply : ('a -> 'b, 'e, 'f) t -> ('a, 'e, 'f) t -> ('b, 'e, 'f) t 71 | end) = 72 | struct 73 | module H = Hk.Make3 (A) 74 | 75 | let applicative = 76 | { Applicative.map = (fun a ~f -> H.inject (A.map (H.project a) ~f)) 77 | ; apply = (fun a b -> H.inject (A.apply (H.project a) (H.project b))) 78 | } 79 | ;; 80 | 81 | let of_nonempty t ~access = 82 | H.project (t.f applicative ~access:(fun a -> H.inject (access a))) 83 | ;; 84 | end 85 | 86 | module Of_applicative_without_return2 (A : sig 87 | type ('a, 'e) t 88 | 89 | val map : ('a, 'e) t -> f:('a -> 'b) -> ('b, 'e) t 90 | val apply : ('a -> 'b, 'e) t -> ('a, 'e) t -> ('b, 'e) t 91 | end) = 92 | Of_applicative_without_return3 (struct 93 | type ('a, 'e, _) t = ('a, 'e) A.t 94 | 95 | include (A : module type of A with type ('a, 'e) t := ('a, 'e) A.t) 96 | end) 97 | 98 | module Of_applicative_without_return (A : sig 99 | type 'a t 100 | 101 | val map : 'a t -> f:('a -> 'b) -> 'b t 102 | val apply : ('a -> 'b) t -> 'a t -> 'b t 103 | end) = 104 | Of_applicative_without_return2 (struct 105 | type ('a, _) t = 'a A.t 106 | 107 | include (A : module type of A with type 'a t := 'a A.t) 108 | end) 109 | 110 | include Of_applicative_without_return3 (struct 111 | type nonrec ('bt, 'a, 'b) t = ('bt, 'a, 'b) t 112 | 113 | let map = map 114 | let apply = apply 115 | end) 116 | -------------------------------------------------------------------------------- /src/nonempty.mli: -------------------------------------------------------------------------------- 1 | open! Base 2 | open! Import 3 | 4 | (** An [(a, x, y) t] is an applicative for defining [nonempty] accessors. See the 5 | documentation of [Accessor.nonempty] for more information. *) 6 | type ('a, +'x, 'y) t 7 | 8 | include 9 | Applicative_without_return.S3_without_let_syntax 10 | with type ('a, 'x, 'y) t := ('a, 'x, 'y) t 11 | 12 | module Let_syntax : sig 13 | val map : ('a, 'e, 'f) t -> f:('a -> 'b) -> ('b, 'e, 'f) t 14 | val both : ('a, 'e, 'f) t -> ('b, 'e, 'f) t -> ('a * 'b, 'e, 'f) t 15 | 16 | module Let_syntax : sig 17 | val map : ('a, 'e, 'f) t -> f:('a -> 'b) -> ('b, 'e, 'f) t 18 | val both : ('a, 'e, 'f) t -> ('b, 'e, 'f) t -> ('a * 'b, 'e, 'f) t 19 | 20 | module Open_on_rhs : sig 21 | val access : 'a -> ('b, 'a, 'b) t 22 | end 23 | end 24 | end 25 | 26 | module Accessed : Monad.S_indexed with type ('a, 'bt, 'b) t := ('bt, 'a, 'b) t 27 | 28 | (** [access a] "accesses" [a] and returns the value you are expected replace it with. *) 29 | val access : 'a -> ('b, 'a, 'b) t 30 | 31 | module Of_applicative_without_return (A : sig 32 | type 'a t 33 | 34 | val map : 'a t -> f:('a -> 'b) -> 'b t 35 | val apply : ('a -> 'b) t -> 'a t -> 'b t 36 | end) : sig 37 | val of_nonempty : ('bt, 'a, 'b) t -> access:('a -> 'b A.t) -> 'bt A.t 38 | end 39 | 40 | module Of_applicative_without_return2 (A : sig 41 | type ('a, 'e) t 42 | 43 | val map : ('a, 'e) t -> f:('a -> 'b) -> ('b, 'e) t 44 | val apply : ('a -> 'b, 'e) t -> ('a, 'e) t -> ('b, 'e) t 45 | end) : sig 46 | val of_nonempty : ('bt, 'a, 'b) t -> access:('a -> ('b, 'e) A.t) -> ('bt, 'e) A.t 47 | end 48 | 49 | module Of_applicative_without_return3 (A : sig 50 | type ('a, 'e, 'f) t 51 | 52 | val map : ('a, 'e, 'f) t -> f:('a -> 'b) -> ('b, 'e, 'f) t 53 | val apply : ('a -> 'b, 'e, 'f) t -> ('a, 'e, 'f) t -> ('b, 'e, 'f) t 54 | end) : sig 55 | val of_nonempty 56 | : ('bt, 'a, 'b) t 57 | -> access:('a -> ('b, 'e, 'f) A.t) 58 | -> ('bt, 'e, 'f) A.t 59 | end 60 | -------------------------------------------------------------------------------- /src/nonempty_getter.ml: -------------------------------------------------------------------------------- 1 | open! Base 2 | open! Import 3 | 4 | type 'a t = { f : 'r. combine:('r -> 'r -> 'r) -> f:('a -> 'r) -> 'r } [@@unboxed] 5 | 6 | let access a = { f = (fun ~combine:_ ~f -> f a) } 7 | 8 | include Monad.Make (struct 9 | type nonrec 'a t = 'a t 10 | 11 | let return = access 12 | let map t ~f = { f = (fun ~combine ~f:g -> t.f ~combine ~f:(fun a -> g (f a))) } 13 | 14 | let bind t ~f = 15 | { f = (fun ~combine ~f:g -> t.f ~combine ~f:(fun a -> (f a).f ~combine ~f:g)) } 16 | ;; 17 | 18 | let map = `Custom map 19 | end) 20 | 21 | let map_reduce t = t.f 22 | 23 | let append t1 t2 = 24 | { f = (fun ~combine ~f -> combine (t1.f ~combine ~f) (t2.f ~combine ~f)) } 25 | ;; 26 | 27 | module O = struct 28 | let ( @ ) = append 29 | end 30 | 31 | include O 32 | 33 | include Nonempty.Of_applicative_without_return2 (struct 34 | type nonrec (_, 'a) t = 'a t 35 | 36 | let map t ~f:_ = t 37 | let apply = append 38 | end) 39 | 40 | let of_nonempty nonempty = of_nonempty nonempty ~access 41 | -------------------------------------------------------------------------------- /src/nonempty_getter.mli: -------------------------------------------------------------------------------- 1 | open! Base 2 | open! Import 3 | 4 | (** [t] is an appendable type for defining [nonempty_getter] accessors. See the 5 | documentation of [Accessor.nonempty_getter] for more information. *) 6 | type +'a t 7 | 8 | include Monad.S with type 'a t := 'a t 9 | 10 | (** [access a] "accesses" [a]. *) 11 | val access : 'a -> 'a t 12 | 13 | (** [append a b] accesses everything [a] accesses, then accesses everything [b] accesses. *) 14 | val append : 'a t -> 'a t -> 'a t 15 | 16 | module O : sig 17 | val ( @ ) : 'a t -> 'a t -> 'a t 18 | end 19 | 20 | include module type of O 21 | 22 | val map_reduce : 'a t -> combine:('r -> 'r -> 'r) -> f:('a -> 'r) -> 'r 23 | val of_nonempty : (_, 'a, _) Nonempty.t -> 'a t 24 | -------------------------------------------------------------------------------- /src/subtyping.ml: -------------------------------------------------------------------------------- 1 | module rec T : Subtyping_intf.Subtyping = T 2 | include T 3 | -------------------------------------------------------------------------------- /src/subtyping.mli: -------------------------------------------------------------------------------- 1 | include Subtyping_intf.Subtyping (** @inline *) 2 | -------------------------------------------------------------------------------- /src/subtyping_intf.ml: -------------------------------------------------------------------------------- 1 | open! Base 2 | open! Import 3 | 4 | module type Subtyping = sig 5 | (** The subtyping scheme for accessors involves the following "feature" types. Each 6 | kind of accessor is defined by the features it has. If an accessor A's features is 7 | a subset of another accessor B's features, then A is a supertype of B. *) 8 | 9 | type at_least_one = [ `at_least_one ] 10 | type at_most_one = [ `at_most_one ] 11 | type coerce = [ `coerce ] 12 | type construct = [ `construct ] 13 | type get = [ `get ] 14 | type map = [ `map ] 15 | type constructor = construct 16 | 17 | type equality = 18 | [ get 19 | | map 20 | | at_most_one 21 | | at_least_one 22 | | construct 23 | | coerce 24 | ] 25 | 26 | type field = 27 | [ get 28 | | map 29 | | at_most_one 30 | | at_least_one 31 | ] 32 | 33 | type getter = 34 | [ get 35 | | at_least_one 36 | | at_most_one 37 | ] 38 | 39 | type isomorphism = 40 | [ get 41 | | map 42 | | at_most_one 43 | | at_least_one 44 | | construct 45 | ] 46 | 47 | type many = 48 | [ get 49 | | map 50 | ] 51 | 52 | type many_getter = get 53 | type mapper = map 54 | 55 | type nonempty = 56 | [ get 57 | | map 58 | | at_least_one 59 | ] 60 | 61 | type nonempty_getter = 62 | [ get 63 | | at_least_one 64 | ] 65 | 66 | type optional = 67 | [ get 68 | | map 69 | | at_most_one 70 | ] 71 | 72 | type optional_getter = 73 | [ get 74 | | at_most_one 75 | ] 76 | 77 | type variant = 78 | [ get 79 | | map 80 | | at_most_one 81 | | construct 82 | ] 83 | end 84 | with type at_least_one := [ `at_least_one ] 85 | and type at_most_one := [ `at_most_one ] 86 | and type coerce := [ `coerce ] 87 | and type construct := [ `construct ] 88 | and type get := [ `get ] 89 | and type map := [ `map ] 90 | -------------------------------------------------------------------------------- /test/accessor_tests.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Import 3 | 4 | let%expect_test "Index.sexp_of_t" = 5 | print_s [%sexp ([] : unit Accessor.Index.t)]; 6 | [%expect {| () |}]; 7 | print_s [%sexp ([ "a", "b" ] : ((string * string) * unit) Accessor.Index.t)]; 8 | [%expect {| ((a b)) |}]; 9 | print_s 10 | [%sexp ([ "a"; "b"; "c" ] : (string * (string * (string * unit))) Accessor.Index.t)]; 11 | [%expect {| (a b c) |}] 12 | ;; 13 | 14 | let%expect_test "invert" = 15 | let accessor = 16 | Accessor.isomorphism ~get:(fun at -> `get at) ~construct:(fun b -> `construct b) 17 | in 18 | print_s [%sexp (Accessor.get accessor () : [ `get of unit ])]; 19 | [%expect {| (get ()) |}]; 20 | print_s [%sexp (Accessor.construct accessor () : [ `construct of unit ])]; 21 | [%expect {| (construct ()) |}]; 22 | let inverted_accessor = Accessor.invert accessor in 23 | print_s [%sexp (Accessor.get inverted_accessor () : [ `construct of unit ])]; 24 | [%expect {| (construct ()) |}]; 25 | print_s [%sexp (Accessor.construct inverted_accessor () : [ `get of unit ])]; 26 | [%expect {| (get ()) |}] 27 | ;; 28 | 29 | let%expect_test "match_" = 30 | let module Foo = struct 31 | type 'a t = 32 | | A of 'a 33 | | B 34 | [@@deriving accessors, sexp_of] 35 | end 36 | in 37 | let a : int Foo.t = A 42 in 38 | print_s [%sexp (Accessor.match_ Foo.a a : (int, Nothing.t Foo.t) Either.t)]; 39 | [%expect {| (First 42) |}]; 40 | let b : int Foo.t = B in 41 | print_s [%sexp (Accessor.match_ Foo.a b : (int, Nothing.t Foo.t) Either.t)]; 42 | [%expect {| (Second B) |}] 43 | ;; 44 | 45 | let%expect_test "disjoint_field_product" = 46 | let module Foo = struct 47 | type t = 48 | { x : int 49 | ; y : int 50 | } 51 | [@@deriving accessors, sexp_of] 52 | end 53 | in 54 | let tupled = [%accessor Accessor.disjoint_field_product Foo.x Foo.y] in 55 | let a = { Foo.x = 42; y = 1337 } in 56 | print_s [%sexp (a.@(tupled) : int * int)]; 57 | [%expect {| (42 1337) |}]; 58 | print_s [%sexp (a.@(tupled) <- 0, 1 : Foo.t)]; 59 | [%expect {| ((x 0) (y 1)) |}] 60 | ;; 61 | 62 | let%expect_test "disjoint_merge" = 63 | let module Foo = struct 64 | type t = 65 | { x : int 66 | ; y : int 67 | } 68 | [@@deriving accessors, sexp_of] 69 | end 70 | in 71 | let each = [%accessor Accessor.disjoint_merge Foo.x Foo.y] in 72 | let a = { Foo.x = 42; y = 1337 } in 73 | print_s [%sexp (a.@*(each) : int list)]; 74 | [%expect {| (42 1337) |}]; 75 | print_s [%sexp (Accessor.map each a ~f:succ : Foo.t)]; 76 | [%expect {| ((x 43) (y 1338)) |}] 77 | ;; 78 | 79 | let%expect_test "add_to_index" = 80 | let x = 42 in 81 | Accessor.iteri Accessor.add_to_index x ~f:(fun [ index ] value -> 82 | print_s [%message "" (index : int) (value : int)]); 83 | [%expect {| ((index 42) (value 42)) |}]; 84 | Accessor.mapi Accessor.add_to_index x ~f:(fun [ index ] value -> 85 | [%message "" (index : int) (value : int)]) 86 | |> print_s; 87 | [%expect {| ((index 42) (value 42)) |}] 88 | ;; 89 | -------------------------------------------------------------------------------- /test/accessor_tests.mli: -------------------------------------------------------------------------------- 1 | (*_ This signature is deliberately empty. *) 2 | -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name accessor_tests) 3 | (libraries accessor core) 4 | (preprocess 5 | (pps ppx_jane ppx_accessor))) 6 | -------------------------------------------------------------------------------- /test/import.ml: -------------------------------------------------------------------------------- 1 | module Accessor = Accessor 2 | include Accessor.O 3 | -------------------------------------------------------------------------------- /test_helpers/accessor_test_helpers.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Import 3 | 4 | module Quickcheckable = struct 5 | module type S = sig 6 | type t [@@deriving quickcheck, sexp_of] 7 | end 8 | 9 | let tuple (type a b) (module A : S with type t = a) (module B : S with type t = b) = 10 | let module AB = struct 11 | type t = A.t * B.t [@@deriving quickcheck, sexp_of] 12 | end 13 | in 14 | (module AB : S with type t = a * b) 15 | ;; 16 | end 17 | 18 | module Testable = struct 19 | module type S = sig 20 | type t [@@deriving equal, quickcheck, sexp_of] 21 | end 22 | 23 | module Either (A : S) (B : S) = struct 24 | type t = (A.t, B.t) Either.t [@@deriving equal, quickcheck, sexp_of] 25 | end 26 | 27 | module Tuple (A : S) (B : S) = struct 28 | type t = A.t * B.t [@@deriving equal, quickcheck, sexp_of] 29 | end 30 | 31 | module Option (A : S) = struct 32 | type t = A.t option [@@deriving equal, quickcheck, sexp_of] 33 | end 34 | 35 | module List (A : S) = struct 36 | type t = A.t list [@@deriving equal, quickcheck, sexp_of] 37 | end 38 | 39 | module Bool_map (A : S) = struct 40 | type t = A.t Bool.Map.t [@@deriving equal, sexp_of] 41 | 42 | let quickcheck_generator = [%quickcheck.generator: (bool, A.t) Bool.Map.t] 43 | let quickcheck_shrinker = [%quickcheck.shrinker: (bool, A.t) Bool.Map.t] 44 | let quickcheck_observer = [%quickcheck.observer: (bool, A.t) Bool.Map.t] 45 | end 46 | 47 | module Bool_set = struct 48 | type t = Bool.Set.t [@@deriving equal, sexp_of] 49 | 50 | let quickcheck_generator = [%quickcheck.generator: bool Bool.Set.t] 51 | let quickcheck_shrinker = [%quickcheck.shrinker: bool Bool.Set.t] 52 | let quickcheck_observer = [%quickcheck.observer: bool Bool.Set.t] 53 | end 54 | end 55 | 56 | let test_eq (type t) equal sexp_of_t x y = 57 | (* Fake the availability of [compare], which ppx_assert requires. In practice, it only 58 | uses [compare] to test equality, so we can return any non-zero integer in the not 59 | equal case. We do this to avoid imposing the requirement of [deriving compare] on 60 | callers that may only support equality testing. *) 61 | let compare x y = 62 | match equal x y with 63 | | true -> 0 64 | | false -> 1 65 | in 66 | [%test_eq: t] x y 67 | ;; 68 | 69 | let test 70 | (type e a) 71 | (module Env : Quickcheckable.S with type t = e) 72 | (module T : Quickcheckable.S with type t = a) 73 | accessor 74 | ~f 75 | = 76 | Quickcheck.test 77 | [%quickcheck.generator: Env.t * T.t] 78 | ~sexp_of:[%sexp_of: Env.t * T.t] 79 | ~shrinker:[%quickcheck.shrinker: Env.t * T.t] 80 | ~f:(fun (env, t) -> f (accessor env) t) 81 | ;; 82 | 83 | let mapper 84 | (type a at) 85 | (module A : Testable.S with type t = a) 86 | (module At : Testable.S with type t = at) 87 | env 88 | accessor 89 | = 90 | test 91 | env 92 | (module At) 93 | accessor 94 | ~f:(fun accessor at -> 95 | test_eq [%equal: At.t] [%sexp_of: At.t] (Accessor.map accessor at ~f:Fn.id) at); 96 | test 97 | env 98 | (module struct 99 | type t = At.t * (A.t -> A.t) * (A.t -> A.t) [@@deriving quickcheck, sexp_of] 100 | end) 101 | accessor 102 | ~f:(fun accessor (at, f, g) -> 103 | test_eq 104 | [%equal: At.t] 105 | [%sexp_of: At.t] 106 | (Accessor.map accessor at ~f:(Fn.compose f g)) 107 | (Accessor.map accessor (Accessor.map accessor at ~f:g) ~f)) 108 | ;; 109 | 110 | let many 111 | (type a at) 112 | (module A : Testable.S with type t = a) 113 | (module At : Testable.S with type t = at) 114 | env 115 | accessor 116 | = 117 | let module X : sig 118 | type 'a t [@@deriving equal, quickcheck, sexp_of] 119 | 120 | include Applicative.S with type 'a t := 'a t 121 | module Accessor : Accessor.Applicative.S with type 'a t := 'a t 122 | end = struct 123 | module T = struct 124 | type 'a t = A.t list * 'a [@@deriving equal, quickcheck, sexp_of] 125 | 126 | include Applicative.Make_using_map2 (struct 127 | type 'a t = A.t list * 'a 128 | 129 | let return a = [], a 130 | let map = `Define_using_map2 131 | let map2 (xs, a) (ys, b) ~f = xs @ ys, f a b 132 | end) 133 | end 134 | 135 | include T 136 | module Accessor = Accessor.Of_applicative (T) 137 | end 138 | in 139 | let module Y : module type of X = X in 140 | let module XY = struct 141 | module T = Applicative.Compose (X) (Y) 142 | include T 143 | module Accessor = Accessor.Of_applicative (T) 144 | end 145 | in 146 | test 147 | env 148 | (module At) 149 | accessor 150 | ~f:(fun accessor at -> 151 | test_eq 152 | [%equal: At.t X.t] 153 | [%sexp_of: At.t X.t] 154 | (X.Accessor.map accessor at ~f:X.return) 155 | (X.return at)); 156 | test 157 | env 158 | (module struct 159 | type t = At.t * (A.t -> A.t X.t) * (A.t -> A.t Y.t) [@@deriving quickcheck, sexp_of] 160 | end) 161 | accessor 162 | ~f:(fun accessor (at, f, g) -> 163 | test_eq 164 | [%equal: At.t X.t Y.t] 165 | [%sexp_of: At.t X.t Y.t] 166 | (XY.Accessor.map accessor at ~f:(fun a -> Y.map (g a) ~f)) 167 | (Y.map (Y.Accessor.map accessor at ~f:g) ~f:(fun at -> 168 | X.Accessor.map accessor at ~f))) 169 | ;; 170 | 171 | let nonempty 172 | (type a at) 173 | (module A : Testable.S with type t = a) 174 | (module At : Testable.S with type t = at) 175 | env 176 | accessor 177 | = 178 | let module X : sig 179 | type 'a t [@@deriving equal, quickcheck, sexp_of] 180 | 181 | include Applicative_without_return.S with type 'a t := 'a t 182 | module Accessor : Accessor.Applicative_without_return.S with type 'a t := 'a t 183 | end = struct 184 | module T = struct 185 | type 'a t = A.t Nonempty_list.t * 'a [@@deriving equal, quickcheck, sexp_of] 186 | 187 | include Applicative_without_return.Make (struct 188 | type 'a t = A.t Nonempty_list.t * 'a 189 | 190 | let map (xs, a) ~f = xs, f a 191 | 192 | let apply (xs, f) (ys, a) = 193 | Nonempty_list.append xs (Nonempty_list.to_list ys), f a 194 | ;; 195 | end) 196 | end 197 | 198 | include T 199 | module Accessor = Accessor.Of_applicative_without_return (T) 200 | end 201 | in 202 | let module Y : module type of X = X in 203 | let module XY = struct 204 | module T = struct 205 | type 'a t = 'a X.t Y.t 206 | 207 | include Applicative_without_return.Make (struct 208 | type 'a t = 'a X.t Y.t 209 | 210 | let map t ~f = Y.map t ~f:(X.map ~f) 211 | let apply f a = Y.apply (Y.map f ~f:X.apply) a 212 | end) 213 | end 214 | 215 | include T 216 | module Accessor = Accessor.Of_applicative_without_return (T) 217 | end 218 | in 219 | test 220 | env 221 | (module struct 222 | type t = At.t * (A.t -> A.t X.t) * (A.t -> A.t Y.t) [@@deriving quickcheck, sexp_of] 223 | end) 224 | accessor 225 | ~f:(fun accessor (at, f, g) -> 226 | test_eq 227 | [%equal: At.t X.t Y.t] 228 | [%sexp_of: At.t X.t Y.t] 229 | (XY.Accessor.map accessor at ~f:(fun a -> Y.map (g a) ~f)) 230 | (Y.map (Y.Accessor.map accessor at ~f:g) ~f:(fun at -> 231 | X.Accessor.map accessor at ~f))) 232 | ;; 233 | 234 | let optional 235 | (type a at) 236 | (module A : Testable.S with type t = a) 237 | (module At : Testable.S with type t = at) 238 | env 239 | accessor 240 | = 241 | test 242 | env 243 | (Quickcheckable.tuple (module At) (module A)) 244 | accessor 245 | ~f:(fun accessor (at, a) -> 246 | test_eq 247 | [%equal: (A.t, At.t) Either.t] 248 | [%sexp_of: (A.t, At.t) Either.t] 249 | (Accessor.match_ accessor (at.@(accessor) <- a)) 250 | (Either.First.map (Accessor.match_ accessor at) ~f:(const a))); 251 | test 252 | env 253 | (module At) 254 | accessor 255 | ~f:(fun accessor at -> 256 | let bt = 257 | match Accessor.match_ accessor at with 258 | | First a -> at.@(accessor) <- a 259 | | Second bt -> bt 260 | in 261 | test_eq [%equal: At.t] [%sexp_of: At.t] at bt); 262 | test 263 | env 264 | (Quickcheckable.tuple (module At) (module A)) 265 | accessor 266 | ~f:(fun accessor (at, a) -> 267 | test_eq 268 | [%equal: At.t] 269 | [%sexp_of: At.t] 270 | ((at.@(accessor) <- a).@(accessor) <- a) 271 | (at.@(accessor) <- a)) 272 | ;; 273 | 274 | let field 275 | (type a at) 276 | (module A : Testable.S with type t = a) 277 | (module At : Testable.S with type t = at) 278 | env 279 | accessor 280 | = 281 | test 282 | env 283 | (Quickcheckable.tuple (module At) (module A)) 284 | accessor 285 | ~f:(fun accessor (at, a) -> 286 | test_eq [%equal: A.t] [%sexp_of: A.t] (at.@(accessor) <- a).@(accessor) a); 287 | test 288 | env 289 | (module At) 290 | accessor 291 | ~f:(fun accessor at -> 292 | test_eq [%equal: At.t] [%sexp_of: At.t] (at.@(accessor) <- at.@(accessor)) at); 293 | test 294 | env 295 | (Quickcheckable.tuple (module At) (module A)) 296 | accessor 297 | ~f:(fun accessor (at, a) -> 298 | test_eq 299 | [%equal: At.t] 300 | [%sexp_of: At.t] 301 | ((at.@(accessor) <- a).@(accessor) <- a) 302 | (at.@(accessor) <- a)) 303 | ;; 304 | 305 | let variant 306 | (type a at) 307 | (module A : Testable.S with type t = a) 308 | (module At : Testable.S with type t = at) 309 | env 310 | accessor 311 | = 312 | test 313 | env 314 | (module A) 315 | accessor 316 | ~f:(fun accessor a -> 317 | test_eq 318 | [%equal: (A.t, At.t) Either.t] 319 | [%sexp_of: (A.t, At.t) Either.t] 320 | (Accessor.match_ accessor (Accessor.construct accessor a)) 321 | (First a)); 322 | test 323 | env 324 | (module At) 325 | accessor 326 | ~f:(fun accessor at -> 327 | let bt = 328 | match Accessor.match_ accessor at with 329 | | First a -> Accessor.construct accessor a 330 | | Second bt -> bt 331 | in 332 | test_eq [%equal: At.t] [%sexp_of: At.t] at bt) 333 | ;; 334 | 335 | let isomorphism 336 | (type a at) 337 | (module A : Testable.S with type t = a) 338 | (module At : Testable.S with type t = at) 339 | env 340 | accessor 341 | = 342 | test 343 | env 344 | (module A) 345 | accessor 346 | ~f:(fun accessor a -> 347 | test_eq [%equal: A.t] [%sexp_of: A.t] (Accessor.construct accessor a).@(accessor) a); 348 | test 349 | env 350 | (module At) 351 | accessor 352 | ~f:(fun accessor at -> 353 | test_eq 354 | [%equal: At.t] 355 | [%sexp_of: At.t] 356 | (Accessor.construct accessor at.@(accessor)) 357 | at) 358 | ;; 359 | -------------------------------------------------------------------------------- /test_helpers/accessor_test_helpers.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Import 3 | 4 | module Quickcheckable : sig 5 | module type S = sig 6 | type t [@@deriving quickcheck, sexp_of] 7 | end 8 | end 9 | 10 | module Testable : sig 11 | module type S = sig 12 | type t [@@deriving equal, quickcheck, sexp_of] 13 | end 14 | 15 | module Either (A : S) (B : S) : S with type t = (A.t, B.t) Either.t 16 | module Tuple (A : S) (B : S) : S with type t = A.t * B.t 17 | module Option (A : S) : S with type t = A.t option 18 | module List (A : S) : S with type t = A.t list 19 | module Bool_map (A : S) : S with type t = A.t Bool.Map.t 20 | module Bool_set : S with type t = Bool.Set.t 21 | end 22 | 23 | val mapper 24 | : (module Testable.S with type t = 'a) 25 | -> (module Testable.S with type t = 'at) 26 | -> (module Quickcheckable.S with type t = 'env) 27 | -> ('env -> (unit, 'a, 'at, [> mapper ]) Accessor.t) 28 | -> unit 29 | 30 | val many 31 | : (module Testable.S with type t = 'a) 32 | -> (module Testable.S with type t = 'at) 33 | -> (module Quickcheckable.S with type t = 'env) 34 | -> ('env -> (unit, 'a, 'at, [> many ]) Accessor.t) 35 | -> unit 36 | 37 | val nonempty 38 | : (module Testable.S with type t = 'a) 39 | -> (module Testable.S with type t = 'at) 40 | -> (module Quickcheckable.S with type t = 'env) 41 | -> ('env -> (unit, 'a, 'at, [> nonempty ]) Accessor.t) 42 | -> unit 43 | 44 | val optional 45 | : (module Testable.S with type t = 'a) 46 | -> (module Testable.S with type t = 'at) 47 | -> (module Quickcheckable.S with type t = 'env) 48 | -> ('env -> (unit, 'a, 'at, [> optional ]) Accessor.t) 49 | -> unit 50 | 51 | val field 52 | : (module Testable.S with type t = 'a) 53 | -> (module Testable.S with type t = 'at) 54 | -> (module Quickcheckable.S with type t = 'env) 55 | -> ('env -> (unit, 'a, 'at, [> field ]) Accessor.t) 56 | -> unit 57 | 58 | val variant 59 | : (module Testable.S with type t = 'a) 60 | -> (module Testable.S with type t = 'at) 61 | -> (module Quickcheckable.S with type t = 'env) 62 | -> ('env -> (unit, 'a, 'at, [> variant ]) Accessor.t) 63 | -> unit 64 | 65 | val isomorphism 66 | : (module Testable.S with type t = 'a) 67 | -> (module Testable.S with type t = 'at) 68 | -> (module Quickcheckable.S with type t = 'env) 69 | -> ('env -> (unit, 'a, 'at, [> isomorphism ]) Accessor.t) 70 | -> unit 71 | -------------------------------------------------------------------------------- /test_helpers/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name accessor_test_helpers) 3 | (libraries accessor applicative_without_return core 4 | core_kernel.nonempty_list) 5 | (preprocess 6 | (pps ppx_jane ppx_accessor))) 7 | -------------------------------------------------------------------------------- /test_helpers/import.ml: -------------------------------------------------------------------------------- 1 | include Accessor.O 2 | --------------------------------------------------------------------------------