├── BRZO ├── src ├── typegist.mllib ├── typegist.mli └── typegist.ml ├── .gitignore ├── .merlin ├── .ocp-indent ├── _tags ├── CHANGES.md ├── pkg ├── META └── pkg.ml ├── DEVEL.md ├── LICENSE.md ├── doc ├── index.mld ├── quick.mld ├── notes.mld └── cookbook.mld ├── test ├── cookbook.ml └── test_typegist.ml ├── B0.ml ├── opam └── README.md /BRZO: -------------------------------------------------------------------------------- 1 | (srcs-x pkg tmp) -------------------------------------------------------------------------------- /src/typegist.mllib: -------------------------------------------------------------------------------- 1 | Typegist -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _b0 2 | _build 3 | tmp 4 | *.install -------------------------------------------------------------------------------- /.merlin: -------------------------------------------------------------------------------- 1 | PKG b0.kit 2 | S src 3 | S test 4 | B _b0/** -------------------------------------------------------------------------------- /.ocp-indent: -------------------------------------------------------------------------------- 1 | strict_with=always,match_clause=4,strict_else=never -------------------------------------------------------------------------------- /_tags: -------------------------------------------------------------------------------- 1 | true : bin_annot, safe_string 2 | <_b0> : -traverse 3 | : include -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | v0.1.0 YYYY-MM-DD Loc 2 | ------------------------ 3 | 4 | First release. 5 | -------------------------------------------------------------------------------- /pkg/META: -------------------------------------------------------------------------------- 1 | description = "Represent the essence of OCaml types as values" 2 | version = "%%VERSION_NUM%%" 3 | requires = "" 4 | archive(byte) = "typegist.cma" 5 | archive(native) = "typegist.cmxa" 6 | plugin(byte) = "typegist.cma" 7 | plugin(native) = "typegist.cmxs" 8 | -------------------------------------------------------------------------------- /DEVEL.md: -------------------------------------------------------------------------------- 1 | This project uses (perhaps the development version of) [`b0`] for 2 | development. Consult [b0 occasionally] for quick hints on how to 3 | perform common development tasks. 4 | 5 | [`b0`]: https://erratique.ch/software/b0 6 | [b0 occasionally]: https://erratique.ch/software/b0/doc/occasionally.html 7 | 8 | -------------------------------------------------------------------------------- /pkg/pkg.ml: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ocaml 2 | #use "topfind" 3 | #require "topkg" 4 | open Topkg 5 | 6 | let () = 7 | Pkg.describe "typegist" @@ fun c -> 8 | Ok [ Pkg.mllib "src/typegist.mllib"; 9 | Pkg.doc "doc/index.mld" ~dst:"odoc-pages/index.mld"; 10 | Pkg.doc "doc/quick.mld" ~dst:"odoc-pages/quick.mld"; 11 | Pkg.doc "doc/notes.mld" ~dst:"odoc-pages/notes.mld"; 12 | Pkg.doc "doc/cookbook.mld" ~dst:"odoc-pages/cookbook.mld"; 13 | ] 14 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | Copyright (c) 2023 The typegist programmers 2 | 3 | Permission to use, copy, modify, and/or distribute this software for any 4 | purpose with or without fee is hereby granted, provided that the above 5 | copyright notice and this permission notice appear in all copies. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 8 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 9 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 10 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 11 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 12 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 13 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 14 | -------------------------------------------------------------------------------- /doc/index.mld: -------------------------------------------------------------------------------- 1 | {0 Typegist {%html: %%VERSION%%%}} 2 | 3 | Typegist represents the essence of OCaml types as values. This dynamic 4 | type representation can be used to devise generic type-indexed 5 | functions – value printers, parsers, differs, generators, editors, ffi 6 | etc. 7 | 8 | {1:manual Manuals} 9 | 10 | The following manuals are available: 11 | 12 | {ul 13 | {- The {{!page-quick}quick start} should do so.} 14 | {- The {{!page-cookbook}Typegist cookbook} has a few conventions 15 | and gist definition recipes.} 16 | {- The {{!page-notes}design notes} explains design choices made by 17 | the library.}} 18 | 19 | {1:lib_typegist Library [typegist]} 20 | 21 | This library has the type gist definition as an extension of the 22 | {!Stdlib.Type} module and provides generic functions in an extended 23 | {!Stdlib.Fun} module. 24 | 25 | {!modules: Typegist} 26 | {!modules: Typegist.Type.Gist Typegist.Fun.Generic} 27 | -------------------------------------------------------------------------------- /doc/quick.mld: -------------------------------------------------------------------------------- 1 | {0 Typegist Quick start} 2 | 3 | The library is unstable and the quick start remains todo, for now 4 | there are just a few {{!examples}examples} and 5 | a generic {{!function_template}function template} for processing type gists. 6 | 7 | {1:describing Describing your types} 8 | 9 | {b TODO} 10 | {ul 11 | {- Show simple examples of each structures. Make it principled, define 12 | first the contructor, then the projector, then the dimensions etc.} 13 | {- Show how to write recursion properly} 14 | {- Show how to use metadata with {!Typegist.Fun.Generic.pp} or 15 | to specify the range of scalars (e.g. for random generation)} 16 | {- Show how to hide GADT witnesses.} 17 | {- Notes on polymorphism and first-order kind.}} 18 | 19 | {1:using Processing the description} 20 | 21 | {b TODO} 22 | {ul 23 | {- Devise something consuming values} 24 | {- Show how to create and process metadata} 25 | {- Devise something producing values (e.g. deriving a [Cmdliner] term)} 26 | {- Show how specialisations can be easily generalized 27 | (e.g. {!Typegist.Type.Gist.Sum.to_variant}).}} 28 | 29 | {1:examples Examples} 30 | -------------------------------------------------------------------------------- /test/cookbook.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2024 The typegist programmers. All rights reserved. 3 | SPDX-License-Identifier: CC0-1.0 4 | ---------------------------------------------------------------------------*) 5 | 6 | (* Examples from the cookbook *) 7 | 8 | (* Records *) 9 | 10 | module Person = struct 11 | type t = { name : string; age : int option } 12 | let make name age = { name; age } 13 | let name p = p.name 14 | let age p = p.age 15 | 16 | open Typegist 17 | 18 | let gist = 19 | Type.Gist.record "Person.t" make 20 | |> Type.Gist.field "name" Type.Gist.string_as_utf_8 name 21 | |> Type.Gist.field "age" Type.Gist.(option int) age 22 | |> Type.Gist.finish_record 23 | 24 | let pp = Fun.Generic.pp gist 25 | end 26 | 27 | (* Variants *) 28 | 29 | module Status = struct 30 | type t = Todo | Done | Cancelled 31 | 32 | open Typegist 33 | 34 | let gist = 35 | let todo = Type.Gist.case0 "Status.Todo" Todo in 36 | let done' = Type.Gist.case0 "Status.Done" Done in 37 | let cancelled = Type.Gist.case0 "Status.Cancelled" Done in 38 | let project = function 39 | | Todo -> todo | Done -> done' | Cancelled -> cancelled 40 | in 41 | let cases = [todo; done'; cancelled] in 42 | Type.Gist.variant "Status.t" project cases 43 | 44 | let pp = Fun.Generic.pp gist 45 | end 46 | -------------------------------------------------------------------------------- /B0.ml: -------------------------------------------------------------------------------- 1 | open B0_kit.V000 2 | open Result.Syntax 3 | 4 | (* OCaml library names *) 5 | 6 | let typegist = B0_ocaml.libname "typegist" 7 | let b0_std = B0_ocaml.libname "b0.std" 8 | 9 | (* Libraries *) 10 | 11 | let typegist_lib = B0_ocaml.lib typegist ~srcs: [`Dir ~/"src"] 12 | 13 | (* Tests *) 14 | 15 | let test ?(requires = []) = B0_ocaml.test ~requires:(typegist :: requires) 16 | let test_typegist = test ~/"test/test_typegist.ml" ~requires:[b0_std] 17 | let cookbook = test ~/"test/cookbook.ml" ~run:false 18 | 19 | (* Packs *) 20 | 21 | let default = 22 | let meta = 23 | B0_meta.empty 24 | |> ~~ B0_meta.authors ["The typegist programmers"] 25 | |> ~~ B0_meta.maintainers ["Daniel Bünzli "] 26 | |> ~~ B0_meta.homepage "https://erratique.ch/software/typegist" 27 | |> ~~ B0_meta.online_doc "https://erratique.ch/software/typegist/doc" 28 | |> ~~ B0_meta.licenses ["ISC"] 29 | |> ~~ B0_meta.repo "git+https://erratique.ch/repos/typegist.git" 30 | |> ~~ B0_meta.issues "https://github.com/dbuenzli/typegist/issues" 31 | |> ~~ B0_meta.description_tags ["typerep"; "generic"; "org:erratique"] 32 | |> ~~ B0_opam.build 33 | {|[["ocaml" "pkg/pkg.ml" "build" "--dev-pkg" "%{dev}%"]]|} 34 | |> ~~ B0_opam.depends 35 | [ "ocaml", {|>= "4.14.0"|}; 36 | "ocamlfind", {|build|}; 37 | "ocamlbuild", {|build|}; ] 38 | |> B0_meta.tag B0_opam.tag 39 | in 40 | B0_pack.make "default" ~doc:"The typegist package" ~meta ~locked:true @@ 41 | B0_unit.list () 42 | -------------------------------------------------------------------------------- /opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "typegist" 3 | synopsis: "Represent the essence of OCaml types as values" 4 | description: """\ 5 | Typegist represents the essence of OCaml types as values. This dynamic 6 | type representation can be used to devise generic type-indexed 7 | functions – value printers, parsers, differs, generators, editors, 8 | ffi, etc. 9 | 10 | The mechanism is flexible: more than one representation can be provided 11 | for a single type and any accessible type can be described up to the 12 | limits defined by its public interface. Abstract types can expose 13 | multiple versioned public representations (or none) which allows to 14 | interface with older representations your program may be subjected to. 15 | 16 | Typegist aims at providing an ergonomic interface for both producers 17 | and consumers of the representation. As such it does not try to 18 | capture the full complexity of OCaml's type definition language. It 19 | focuses on a core structural type representation decorated with 20 | type-indexed existential metadata for customizing and extending the 21 | behaviour of generic functions. 22 | 23 | Typegist is distributed under the ISC license. It has no dependencies. 24 | 25 | Homepage: """ 26 | maintainer: "Daniel Bünzli " 27 | authors: "The typegist programmers" 28 | license: "ISC" 29 | tags: ["typerep" "generic" "org:erratique"] 30 | homepage: "https://erratique.ch/software/typegist" 31 | doc: "https://erratique.ch/software/typegist/doc" 32 | bug-reports: "https://github.com/dbuenzli/typegist/issues" 33 | depends: [ 34 | "ocaml" {>= "4.14.0"} 35 | "ocamlfind" {build} 36 | "ocamlbuild" {build} 37 | ] 38 | build: ["ocaml" "pkg/pkg.ml" "build" "--dev-pkg" "%{dev}%"] 39 | dev-repo: "git+https://erratique.ch/repos/typegist.git" 40 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | typegist — Represent the essence of OCaml types as values 2 | ========================================================= 3 | %%VERSION%% 4 | 5 | Typegist represents the essence of OCaml types as values. This dynamic 6 | type representation can be used to devise generic type-indexed 7 | functions – value printers, parsers, differs, generators, editors, 8 | ffi, etc. 9 | 10 | The mechanism is flexible: more than one representation can be provided 11 | for a single type and any accessible type can be described up to the 12 | limits defined by its public interface. Abstract types can expose 13 | multiple versioned public representations (or none) which allows to 14 | interface with older representations your program may be subjected to. 15 | 16 | Typegist aims at providing an ergonomic interface for both producers 17 | and consumers of the representation. As such it does not try to 18 | capture the full complexity of OCaml's type definition language. It 19 | focuses on a core structural type representation decorated with 20 | type-indexed existential metadata for customizing and extending the 21 | behaviour of generic functions. 22 | 23 | Typegist is distributed under the ISC license. It has no dependencies. 24 | 25 | Homepage: 26 | 27 | # Installation 28 | 29 | Typegist can be installed with `opam`: 30 | 31 | opam install typegist 32 | 33 | If you don't use `opam` consult the [`opam`](opam) file for build 34 | instructions. 35 | 36 | # Documentation 37 | 38 | The documentation can be consulted [online][doc] or via `odig doc typegist`. 39 | 40 | Questions are welcome but better asked on the [OCaml forum][ocaml-forum] 41 | than on the issue tracker. 42 | 43 | [doc]: https://erratique.ch/software/typegist/doc 44 | [ocaml-forum]: https://discuss.ocaml.org/ 45 | 46 | 47 | 48 | 49 | 50 | -------------------------------------------------------------------------------- /doc/notes.mld: -------------------------------------------------------------------------------- 1 | {0 [typegist] design notes} 2 | 3 | The type representation is similar to 4 | {{:https://arxiv.org/abs/1812.11665}Balestrieri et al.'s} low level 5 | view (§2.3.4). However the representation is not extensible, a few 6 | case are dropped, some representations are unified, some 7 | specializations are added. 8 | 9 | Here are a few salient points: 10 | 11 | {ul 12 | {- Products, records and variant (cases) are distinguished at the 13 | toplevel but they all share a single representation: a {e product 14 | of fields representation}. This economical uniformity benefits 15 | both processors and the programmer's mind.} 16 | {- The {{!Typegist.Type.Gist.product_ops}product of fields 17 | representation} does not go through tuples, it stores a 18 | deconstruction of the type into its (ordered) fields and a 19 | constructor to recreate it from its fields. Thus rather than 20 | providing conversion to/from a multi-dimensional tuple, the user 21 | provides field projectors and a constructor that creates values 22 | from the fields. This representation is rather natural and easy to 23 | explain. It's a good fit for abstract records since APIs usually 24 | already provide a constructor and field accessors. It is however 25 | more painful for variant cases which are usually deconstructed via 26 | pattern matching, having a quick way of devising these projectors 27 | would be useful.} 28 | {- The {{!Typegist.Type.Gist.abstract_ops}representation of abstract 29 | types} can expose more than one public representation (or 30 | none). Public representations have a version label which allows to 31 | interact with systems still using the previous representation.} 32 | {- The {{!Typegist.Type.Gist.variant_ops}representation of 33 | variants} is different from Balestrieri et al. Each variant 34 | case is a product of fields named after the constructor. We 35 | store an ordered list of cases and one function that returns a 36 | case given a value (rather than one function per case that 37 | tests if a value has the case).} 38 | {- The representation is decorated with 39 | {{!Typegist.Type.Gist.Meta}type-indexed existential metadata}. 40 | This allows generic functions to be customized and extended 41 | (see for example 42 | the keys in {!Typegist.Fun.Generic.Meta} for the functions in 43 | {!Typegist.Fun.Generic}). We use the type level defunctionalization of 44 | {{:https://www.cl.cam.ac.uk/~jdy22/papers/lightweight-higher-kinded-polymorphism.pdf}Yallop et al.} to allow metadata values to depend on the 45 | type of represented values. One open question is where exactly 46 | to place the metadata, see the {{!todo}TODO}.} 47 | {- Balance between specialisation and generalisation. We have 48 | a few cases that represent OCaml types directly. For example 49 | {!Type.Gist.sum}, has one case for arbitrary variants and other 50 | cases for common Stdlib variant types like lists. If there's no 51 | interest in the specialisation a generic view can easily be obtained 52 | with {!Typegist.Type.Gist.Sum.to_variant}. Similar schemes are provided 53 | by {!Typegist.Type.Gist.maplike}, {!Typegist.Type.Gist.arraylike}. 54 | Scalar values are all grouped under {!Typegist.Type.Gist.scalar} for which 55 | a few generic operations are provided in 56 | {!Typegist.Type.Gist.module-Scalar}.} 57 | {- The representation is a closed variant. Not really convinced 58 | by this aspect of the design in Balestrieri et al. Extensibility 59 | creeps into all processor which need an optional argument for dealing 60 | with extensions and entail runtime errors on unsupported extensions. 61 | Breaking at compile time the rare times a case will really need to be 62 | added seems a better course of action.}} 63 | 64 | {1:todo TODO} 65 | 66 | {ul 67 | {- [Meta] placement. Must be nailed down before any release. 68 | See {{!meta_placement}this section}.} 69 | {- For now we just have one dimensional bigarrays as arrays. Should we have 70 | the other dimensions, or just Genarray ? Where should we put it 71 | from a generic point of view ? {!Type.Gist.arraylike} is decidely 1D. 72 | A few alternatives: 73 | {ol 74 | {- One case for [Array1] and one case for [Genarray]. 75 | and {!Type.Gist.Arraylike.to_array_module} reshapes [Genarray] 76 | to [Array1]} 77 | {- Only a [Genarray] case and {!Type.Gist.Arraylike.to_array_module} 78 | reshapes [Genarray] to [Array1]} 79 | {- Only [Array1] (what we have now) except we add an [int array] 80 | that has the dimensions of a Genarray from which it was reshaped}}} 81 | {- Arraylike. Distinguish mutability ? More convenience for 82 | construction ?} 83 | {- Maplike, is possible to have a direct case for [Map] ? I doubt 84 | (no way to capture the module argument [Ord] as a parameter 85 | when writing the type [Map.Make(Ord).t]). The current scheme 86 | requires a functor application to embed a map. It's quite ugly.} 87 | {- Setlike ?} 88 | {- Add a standard error mecanism to allow abstract representations to 89 | only partially map (just having options is obscure).} 90 | {- Except for the variants the representation types are kept abstract. 91 | This entails however a loss of polymorphism for empty variant cases. 92 | In the Gist module itself we can have a polymorphic description of [None] 93 | we can't with [Type.Gist.(case "None" @@ ctor None))]. Should open 94 | the representation of {!Type.Gist.Field.t} ?} 95 | {- Move field {{!Type.Gist.Field.default}default values} to a 96 | standard [Meta] key or keep them ? Do a review once a codec with 97 | default values on absence has been written.} 98 | {- {!Type.Gist.Rec} and {!Type.Gist.rec'} rename to [Unlazy] 99 | and unlazy ?} 100 | {- {!Type.Gist.String} and {!Type.Gist.Bytes} it's unclear 101 | whether we want the char gist.} 102 | {- [Typegist.Fun.Generic.{equal,compare}] clarify and document 103 | the behaviour on {!Typegist.Type.Gist.maplike}, 104 | {!Typegist.Type.Gist.arraylike} and variant cases. The implementation 105 | on [Hashtbl.t] are inefficient, the stdlib doesn't help much.} 106 | {- Should we add [Stdlib.Seq] to {!Typegist.Type.Gist.sum} ? 107 | Feels a bit odd to mix in corecursion in there} 108 | {- Representation of variants. The internal data structure is a bit too 109 | naive. Both {!Fun.Generic.compare} and {!Typegist.Fun.Generic.random} are 110 | quite inefficient.} 111 | {- Add optional parameters to easily specify [Meta.Doc] ?} 112 | {- The semantics of {!Typegist.Type.Gist.Product.name} depends on the 113 | context. Should we split [name] into [case_name] and 114 | [type_name]} 115 | {- Clarify the meta of fields. Note all other metas 116 | are tied to types and their values. Fields are not 117 | types.}} 118 | 119 | {2:meta_placement Meta placement} 120 | 121 | Difficult to find the right design. Basically we can have it 122 | everywhere like now, or only in the toplevel cases or in a single 123 | case at the toplevel. This may lead to different attachement 124 | interpretations though. 125 | 126 | Tried to simply shift them in every toplevel case and let, for 127 | example, the gist of a field define the meta of the field but it 128 | is problematic with a field whose gist is a recursion step (at a 129 | meta to the rec step ?). Also our intepretation in the pretty 130 | printer example is different. The meta for the field redefines 131 | the whole field printing. While the pretty printer of the field's 132 | gist redefines the value. Is it important for other processors ? 133 | 134 | In general it looks easier if we don't have to redefine the meta 135 | of existing gists to be able to specify metadata at a given point 136 | (e.g. the metadata of fields). The drawback is that processors 137 | need to document a bit more precisely which meta is relevant for 138 | them and we get more lookups (the field's meta and its gist). 139 | 140 | Also tried to have meta in the parent case for cases which are 141 | variants ([Type.Gist.Scalar], [Type.Gist.Scalar]. etc.) but in the 142 | end I shifted them back into the subvariants themselves despite 143 | the types looking heavier ({!Typegist.Type.Gist.scalar}, 144 | {!Typegist.Type.Gist.sum}, etc.). It makes the types meta-aware 145 | without needing to carry something on the side. The drawback is 146 | that generic meta lookup on a gist is likely slower. 147 | 148 | The current scheme ends up making a lots of lookups. For this 149 | having only meta as a toplevel case is likely better. It also 150 | makes the AST more lightweight. Given the current generic function 151 | examples, except maybe for the pretty printer, that would be 152 | entirely sufficient. But once we get to for example, type-directed 153 | uis. things may look a bit different, especially at the field level. 154 | It also means that generic functions need to thread and handle the 155 | scope of meta, that looks like a bad idea. 156 | -------------------------------------------------------------------------------- /test/test_typegist.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2023 The typegist programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | open B0_testing 7 | open Typegist 8 | 9 | let test_pair () = 10 | Test.test "pairs" @@ fun () -> 11 | let pair_gist gfst gsnd = 12 | Type.Gist.product (fun x y -> (x, y)) 13 | |> Type.Gist.dim gfst fst 14 | |> Type.Gist.dim gsnd snd 15 | |> Type.Gist.finish_product 16 | in 17 | let pair = pair_gist Type.Gist.int Type.Gist.string_as_utf_8 in 18 | Test.log " type: @[%a@]" Type.Gist.pp_type pair; 19 | Test.log "value: @[%a@]" (Fun.Generic.pp pair) (3, "hey") 20 | 21 | let test_func () = 22 | Test.test "function representation" @@ fun () -> 23 | let func = Type.Gist.(string_as_utf_8 @-> int) in 24 | let ret_pair = Type.Gist.(int @-> int @-> p2 int int) in 25 | let pair x y = x, y in 26 | Test.log " value String.length: @[%a@]" (Fun.Generic.pp func) String.length; 27 | Test.log "value pair constructor: @[%a@]" (Fun.Generic.pp ret_pair) pair 28 | 29 | let test_btree () = 30 | Test.test "binary tree" @@ fun () -> 31 | let module Btree : sig 32 | type 'a t = Empty | Node of 'a t * 'a * 'a t 33 | val type_gist : 'a Type.Gist.t -> 'a t Type.Gist.t 34 | val pp : 'a Type.Gist.t -> Format.formatter -> 'a t -> unit 35 | end = struct 36 | type 'a t = Empty | Node of 'a t * 'a * 'a t 37 | let type_gist gel = 38 | let rec g = lazy begin 39 | let g = Type.Gist.rec' g in 40 | let empty_case = Type.Gist.case0 "Btree.Empty" Empty in 41 | let node_case = 42 | Type.Gist.case "Btree.Node" (fun l v r -> Node (l, v, r)) 43 | |> Type.Gist.dim g (function Node (l,_,_) -> l | _ -> assert false) 44 | |> Type.Gist.dim gel (function Node (_,v,_) -> v | _ -> assert false) 45 | |> Type.Gist.dim g (function Node (_,_,r) -> r | _ -> assert false) 46 | |> Type.Gist.finish_case 47 | in 48 | Type.Gist.variant "Btree.t" 49 | (function Empty -> empty_case | Node _ -> node_case) 50 | [empty_case; node_case] 51 | end 52 | in 53 | Lazy.force g 54 | 55 | let pp elt = Fun.Generic.pp (type_gist elt) 56 | end 57 | in 58 | let int_tree = Btree.type_gist Type.Gist.int in 59 | let t = Btree.Node (Node (Empty, 2, Empty), 1, Empty) in 60 | Test.log " type: @[%a@]" Type.Gist.pp_type int_tree; 61 | Test.log "value: @[%a@]" (Btree.pp Type.Gist.int) t 62 | 63 | let test_abstract_person () = 64 | Test.test "Person" @@ fun () -> 65 | let module Person : sig 66 | type t 67 | val make : string -> string -> string option -> t 68 | val name : t -> string 69 | val email : t -> string 70 | val phone : t -> string option 71 | val type_gist : t Type.Gist.t 72 | val pp : Format.formatter -> t -> unit 73 | end = struct 74 | type t = { name : string; email : string; phone : string option } 75 | let make name email phone = { name; email; phone } 76 | let name p = p.name 77 | let email p = p.email 78 | let phone p = p.phone 79 | 80 | let name_field = 81 | Type.Gist.Field.make ~name:"name" Type.Gist.string_as_utf_8 name 82 | 83 | let email_field = 84 | Type.Gist.Field.make ~name:"email" Type.Gist.string_as_utf_8 email 85 | 86 | let phone_field = 87 | let phone_gist = Type.Gist.(option string_as_utf_8) in 88 | Type.Gist.Field.make ~name:"phone" phone_gist phone 89 | 90 | let type_gist = 91 | let repr_v0 = (* First version had no phone numbers *) 92 | let to_v1 name email = { name; email; phone = None } in 93 | let g = 94 | Type.Gist.record "person" to_v1 95 | |> Type.Gist.field' name_field 96 | |> Type.Gist.field' email_field 97 | |> Type.Gist.finish_record 98 | in 99 | Type.Gist.Abstract.repr ~version:"v0" g Fun.id Fun.id 100 | in 101 | let repr_v1 = (* Added phone numbers *) 102 | let g = 103 | Type.Gist.record "person" make 104 | |> Type.Gist.field' name_field 105 | |> Type.Gist.field' email_field 106 | |> Type.Gist.field' phone_field 107 | |> Type.Gist.finish_record 108 | in 109 | Type.Gist.Abstract.repr ~version:"v1" g Fun.id Fun.id 110 | in 111 | Type.Gist.abstract "person" [repr_v1; repr_v0] 112 | 113 | let pp = Fun.Generic.pp type_gist 114 | end 115 | in 116 | let p = 117 | Person.make "Bactrian" "bactrian@example.com" (Some "+XX XXX XX XX") 118 | in 119 | Test.log " type: @[%a@]" Type.Gist.pp_type Person.type_gist; 120 | Test.log "value: @[%a@]" Person.pp p 121 | 122 | let test_maplike () = 123 | Test.test "maplike" @@ fun () -> 124 | let module String_map = Map.Make (String) in 125 | let imap = String_map.(empty |> add "fst" 1 |> add "snd" 2) in 126 | let module M = Type.Gist.Maplike.Map_module_of_map (Int) (String_map) in 127 | let g = Type.Gist.(map_module (module M) string_as_utf_8 int) in 128 | Test.log " type: @[%a@]" Type.Gist.pp_type g; 129 | Test.log "value: @[%a@]" (Fun.Generic.pp g) imap 130 | 131 | let test_rec_meta () = 132 | let module M = struct 133 | type nat = Z | Succ of nat 134 | let type_gist = 135 | let rec g = lazy begin 136 | let g = Type.Gist.rec' g in 137 | let z = Type.Gist.case0 "M.Z" Z in 138 | let succ = 139 | Type.Gist.case "M.Succ" (fun n -> Succ n) 140 | |> Type.Gist.dim g (function Succ v -> v | _ -> assert false) 141 | |> Type.Gist.finish_case 142 | in 143 | let project = function Z -> z | Succ _ -> succ in 144 | Type.Gist.variant "M.nat" project [z; succ] 145 | end 146 | in 147 | Lazy.force g 148 | end 149 | in 150 | () 151 | 152 | let test_rec () = 153 | Test.test "mutually recursive" @@ fun () -> 154 | let module M = struct 155 | type one = One | To_two of two 156 | and two = Two | To_one of one 157 | 158 | let type_gist_one, type_gist_two = 159 | let rec gone = lazy begin 160 | let gtwo = Type.Gist.rec' gtwo in 161 | let one_case = Type.Gist.case0 "M.One" One in 162 | let to_two_case = 163 | Type.Gist.case "M.To_two" (fun t -> To_two t) 164 | |> Type.Gist.dim gtwo (function To_two v -> v | _ -> assert false) 165 | |> Type.Gist.finish_case 166 | in 167 | let one_proj = function One -> one_case | To_two _ -> to_two_case in 168 | Type.Gist.variant "M.one" one_proj [one_case; to_two_case] 169 | end 170 | and gtwo = lazy begin 171 | let gone = Type.Gist.rec' gone in 172 | let two_case = Type.Gist.case0 "Two" Two in 173 | let to_one_case = 174 | Type.Gist.case "To_one" (fun t -> To_one t) 175 | |> Type.Gist.dim gone (function To_one v -> v | _ -> assert false) 176 | |> Type.Gist.finish_case 177 | in 178 | let two_proj = function Two -> two_case | To_one _ -> to_one_case in 179 | Type.Gist.variant "M.two" two_proj [two_case; to_one_case] 180 | end 181 | in 182 | (Lazy.force gone), (Lazy.force gtwo) 183 | end 184 | in 185 | let v = M.To_two (M.To_one (M.To_two Two)) in 186 | Test.log "type one: @[%a@]" Type.Gist.pp_type M.type_gist_one; 187 | Test.log "type two: @[%a@]" Type.Gist.pp_type M.type_gist_two; 188 | Test.log " value: @[%a@]" (Fun.Generic.pp M.type_gist_one) v 189 | 190 | let test_custom_fmt () = 191 | Test.test "custom formatter" @@ fun () -> 192 | let us = [|Uchar.of_int 0x1F42B; Uchar.of_int 0x41|] in 193 | let uchar_debug ppf u = Format.fprintf ppf "U+%04X" (Uchar.to_int u) in 194 | let uchar_debug = 195 | let m = Type.Gist.Meta.empty |> Fun.Generic.Meta.Fmt.add uchar_debug in 196 | Type.Gist.Scalar (Uchar m) 197 | in 198 | let uchars = Type.Gist.(array uchar) in 199 | let uchars_debug = Type.Gist.(array uchar_debug) in 200 | Test.log "normal: @[%a@]" (Fun.Generic.pp uchars) us; 201 | Test.log "custom: @[%a@]" (Fun.Generic.pp uchars_debug) us 202 | 203 | let test_gadt () = 204 | Test.test "existential GADT" @@ fun () -> 205 | let module M = struct 206 | type 'a t = 207 | | Int : int t 208 | | Float : float t 209 | | Pair : 'a t * 'b t -> ('a * 'b) t 210 | 211 | type v = V : 'a t -> v (* We need to hide the witness. *) 212 | 213 | let type_gist : v Type.Gist.t = 214 | let rec g = lazy begin 215 | let g = Type.Gist.rec' g in 216 | let int_case = Type.Gist.case0 "Int" (V Int) in 217 | let float_case = Type.Gist.case0 "Float" (V Float) in 218 | let pair_case = 219 | Type.Gist.case "Pair" (fun (V a) (V b) -> V (Pair (a, b))) 220 | |> Type.Gist.dim g (function V Pair (a, _) -> V a | _ -> assert false) 221 | |> Type.Gist.dim g (function V Pair (_, b) -> V b | _ -> assert false) 222 | |> Type.Gist.finish_case 223 | in 224 | let t_proj : type a. v -> v Type.Gist.Variant.case = function 225 | | V Int -> int_case | V Float -> float_case | V (Pair _) -> pair_case 226 | in 227 | let cases = [int_case; float_case; pair_case] in 228 | Type.Gist.variant "_ M.t" t_proj cases 229 | end 230 | in 231 | Lazy.force g 232 | end 233 | in 234 | let v = M.V (Pair (Pair (Int, Float), Float)) in 235 | Test.log " type: @[%a@]" Type.Gist.pp_type M.type_gist; 236 | Test.log " type: @[%a@]" Type.Gist.pp_type M.type_gist; 237 | Test.log "value: @[%a@]" (Fun.Generic.pp M.type_gist) v; 238 | () 239 | 240 | let test_key () = 241 | Test.test "meta keys" @@ fun () -> 242 | let module Min = Type.Gist.Meta.Key (struct type 'a t = 'a end) in 243 | let meta = Min.add 3 Type.Gist.Meta.empty in 244 | assert (Min.find meta = Some 3) 245 | 246 | let main () = 247 | Test.main @@ fun () -> 248 | test_pair (); 249 | test_func (); 250 | test_btree (); 251 | test_abstract_person (); 252 | test_maplike (); 253 | test_rec (); 254 | test_custom_fmt (); 255 | test_gadt (); 256 | test_key (); 257 | () 258 | 259 | let () = if !Sys.interactive then () else exit (main ()) 260 | -------------------------------------------------------------------------------- /doc/cookbook.mld: -------------------------------------------------------------------------------- 1 | {0 [Typegist] cookbook} 2 | 3 | A few conventions and recipes to describe your types with {!Typegist.Type.Gist}. 4 | 5 | {1:conventions Conventions} 6 | 7 | Given an OCaml type [t] is type gist should be called [t_typegist]. If your 8 | type follows the [M.t] convention use [M.typegist]. 9 | 10 | {1:describing_records Describing records} 11 | 12 | An OCaml record is {{!Typegist.Type.Gist.record_ops}described} by 13 | naming a product of {{!Typegist.Type.Gist.field}named fields} with 14 | {!Typegist.Type.Gist.val-record}. 15 | 16 | {[ 17 | module Person = struct 18 | type t = { name : string; age : int option } 19 | let make name age = { name; age } 20 | let name p = p.name 21 | let age p = p.age 22 | 23 | open Typegist 24 | 25 | let gist = 26 | Type.Gist.record "Person.t" make 27 | |> Type.Gist.field "name" Type.Gist.string_as_utf_8 name 28 | |> Type.Gist.field "age" Type.Gist.(option int) age 29 | |> Type.Gist.finish_record 30 | 31 | let name = Type.Gist.(field "name" string_as_utf_8) name in 32 | let age = Type.Gist.(field "age" (option int)) age in 33 | Type.Gist.(record "person" @@ ctor make * name * age) 34 | 35 | let pp = Fun.Generic.pp gist 36 | end 37 | ]} 38 | 39 | {1:describing_variants Describing variants} 40 | 41 | An OCaml variant is {{!Typegist.Type.Gist.variant_ops}described} by a 42 | list of cases and a function that indicates how to select the case for 43 | a value. 44 | 45 | {2:enumerations Simple variant} 46 | 47 | A blueprint for an enumeration. 48 | 49 | {[ 50 | module Status = struct 51 | type t = Todo | Done | Cancelled 52 | 53 | open Typegist 54 | 55 | let gist = 56 | let todo = Type.Gist.case0 "Status.Todo" Todo in 57 | let done' = Type.Gist.case0 "Status.Done" Done in 58 | let cancelled = Type.Gist.case0 "Status.Cancelled" Done in 59 | let project = function 60 | | Todo -> todo | Done -> done' | Cancelled -> cancelled 61 | in 62 | let cases = [todo; done'; cancelled] in 63 | Type.Gist.variant "Status.t" project cases 64 | 65 | let pp = Fun.Generic.pp gist 66 | end 67 | ]} 68 | 69 | {2:simple Simple variants} 70 | 71 | {2:variants_special Special cases} 72 | 73 | {2:gatds GADT witness hiding} 74 | 75 | For GADTs we need to cheat a little bit. When trying to describe it as 76 | a variant we can't type the case list since each case has another type 77 | witness. We can however define an existential for the GADT and 78 | describe it as if it was a regular variant. 79 | 80 | {[ 81 | module M = struct 82 | type 'a t = 83 | | Int : int t 84 | | Float : float t 85 | | Pair : 'a t * 'b t -> ('a * 'b) t 86 | 87 | type e = E : 'a t -> e (* We need to hide the witness. *) 88 | 89 | let type_gist : e Type.Gist.t = 90 | let rec g = lazy begin 91 | let g = Type.Gist.rec' g in 92 | let int_case = Type.Gist.(case "Int" @@ ctor (E Int)) in 93 | let float_case = Type.Gist.(case "Float" @@ ctor (E Float)) in 94 | let pair_ctor (E a) (E b) = E (Pair (a, b)) in 95 | let pair_lproj = function E Pair (a, _) -> E a | _ -> assert false in 96 | let pair_rproj = function E Pair (_, b) -> E b | _ -> assert false in 97 | let pair_ldim = Type.Gist.dim g pair_lproj in 98 | let pair_rdim = Type.Gist.dim g pair_rproj in 99 | let pair_prod = Type.Gist.(ctor pair_ctor * pair_ldim * pair_rdim) in 100 | let pair_case = Type.Gist.case "Pair" pair_prod in 101 | let t_proj : type a. e -> e Type.Gist.Variant.case = function 102 | | E Int -> int_case | E Float -> float_case | E (Pair _) -> pair_case 103 | in 104 | let cases = [int_case; float_case; pair_case] in 105 | Type.Gist.variant "_ M.t" t_proj cases 106 | end 107 | in 108 | Lazy.force g 109 | end 110 | ]} 111 | 112 | {1:variants Describing recursive types} 113 | 114 | This example shows variants and recursive types via a simple binary 115 | tree. 116 | 117 | {[ 118 | module Btree : sig 119 | type 'a t = Empty | Node of 'a t * 'a * 'a t 120 | val type_gist : 'a Type.Gist.t -> 'a t Type.Gist.t 121 | val pp : 'a Type.Gist.t -> Format.formatter -> 'a t -> unit 122 | end = struct 123 | type 'a t = Empty | Node of 'a t * 'a * 'a t 124 | let type_gist gel = 125 | let rec g = lazy begin 126 | let g = Type.Gist.rec' g in 127 | let empty_case = Type.Gist.(case "Empty" @@ ctor Empty) in 128 | let node_ctor l v r = Node (l, v, r) in 129 | let node_lproj = function Node (l, _, _) -> l | _ -> assert false in 130 | let node_eproj = function Node (_, v, _) -> v | _ -> assert false in 131 | let node_rproj = function Node (_, _, r) -> r | _ -> assert false in 132 | let node_ldim = Type.Gist.(dim g node_lproj) in 133 | let node_edim = Type.Gist.(dim gel node_eproj) in 134 | let node_rdim = Type.Gist.(dim g node_rproj) in 135 | let node_case = 136 | Type.Gist.case "Node" @@ 137 | Type.Gist.(ctor node_ctor * node_ldim * node_edim * node_rdim) 138 | in 139 | let t_proj = function Empty -> empty_case | Node _ -> node_case in 140 | Type.Gist.variant "Btree.t" t_proj [empty_case; node_case] 141 | end 142 | in 143 | Lazy.force g 144 | 145 | let pp elt = Fun.Generic.pp (type_gist elt) 146 | end 147 | ]} 148 | 149 | {2:mutual Mutual recursion} 150 | 151 | Arbitrary mutual recursion is easily supported. Shown here between two types. 152 | 153 | {[ 154 | let module M = struct 155 | type one = One | To_two of two 156 | and two = Two | To_one of one 157 | 158 | let type_gist_one, type_gist_two = 159 | let rec gone = lazy begin 160 | let gtwo = Type.Gist.rec' gtwo in 161 | let one_case = Type.Gist.(case "One" @@ ctor One) in 162 | let to_two_ctor t = To_two t in 163 | let to_two_proj = function To_two v -> v | _ -> assert false in 164 | let to_two_dim = Type.Gist.(dim gtwo to_two_proj) in 165 | let to_two_prod = Type.Gist.(ctor to_two_ctor * to_two_dim) in 166 | let to_two_case = Type.Gist.case "To_two" to_two_prod in 167 | let one_proj = function One -> one_case | To_two _ -> to_two_case in 168 | Type.Gist.variant "M.one" one_proj [one_case; to_two_case] 169 | end 170 | and gtwo = lazy begin 171 | let gone = Type.Gist.rec' gone in 172 | let two_case = Type.Gist.(case "Two" @@ ctor Two) in 173 | let to_one_ctor t = To_one t in 174 | let to_one_proj = function To_one v -> v | _ -> assert false in 175 | let to_one_dim = Type.Gist.(dim gone to_one_proj) in 176 | let to_one_prod = Type.Gist.(ctor to_one_ctor * to_one_dim) in 177 | let to_one_case = Type.Gist.(case "To_one" @@ to_one_prod) in 178 | let two_proj = function Two -> two_case | To_one _ -> to_one_case in 179 | Type.Gist.variant "M.two" two_proj [two_case; to_one_case] 180 | end 181 | in 182 | (Lazy.force gone), (Lazy.force gtwo) 183 | end 184 | ]} 185 | 186 | {1:describing_parametric_types Describing parametric types} 187 | 188 | {1:versioning Abstract types and versioning} 189 | 190 | This example shows records and abstract type public representation versioning. 191 | 192 | {[ 193 | module Person : sig 194 | type t 195 | val v : string -> string -> string option -> t 196 | val name : t -> string 197 | val email : t -> string 198 | val phone : t -> string option 199 | val gist : t Type.Gist.t 200 | val pp : Format.formatter -> t -> unit 201 | end = struct 202 | type t = { name : string; email : string; phone : string option } 203 | let v name email phone = { name; email; phone } 204 | let name p = p.name 205 | let email p = p.email 206 | let phone p = p.phone 207 | let type_gist = 208 | let name = Type.Gist.(field "name" string_as_utf_8 name) in 209 | let email = Type.Gist.(field "email" string_as_utf_8 email) in 210 | let phone = Type.Gist.(field "phone" (option string_as_utf_8) phone) in 211 | let repr_v0 = (* First version had no phone numbers *) 212 | let to_v1 name email = { name; email; phone = None } in 213 | let g = Type.Gist.(record "person" @@ ctor to_v1 * name * email) in 214 | Type.Gist.Abstract.repr ~version:"v0" g Fun.id Fun.id 215 | in 216 | let repr_v1 = (* Added phone numbers *) 217 | let g = Type.Gist.(record "person" @@ ctor v * name * email * phone) in 218 | Type.Gist.Abstract.repr ~version:"v1" g Fun.id Fun.id 219 | in 220 | Type.Gist.abstract "person" ~reprs:[repr_v1; repr_v0] 221 | 222 | let pp = Fun.Generic.pp type_gist 223 | end 224 | ]} 225 | 226 | {1:writing_generic Writing a generic function} 227 | 228 | The following is a function template for processing two values by 229 | following their gists. 230 | 231 | Since the types need to be spelled out because of the GADT it is usually a 232 | good idea to define a type for the function you are defining. That's the 233 | purpose of the ['a t] below which takes two values and returns [unit] 234 | you likely want to adjust that. 235 | 236 | The implementation of the functions in {!Typegist.Fun.Generic} can 237 | also serve as simple examples. 238 | 239 | {[ 240 | module Generic_binary_fun = struct 241 | type 'a t = 'a -> 'a -> unit 242 | 243 | let rec fun_scalar : type a. a Type.Gist.scalar -> a t = fun s v0 v1 -> 244 | failwith "TODO" 245 | 246 | and fun_arraylike : 247 | type elt arr. (elt, arr) Type.Gist.arraylike -> arr t = fun a v0 v1 -> 248 | failwith "TODO" 249 | 250 | and fun_maplike : 251 | type k v m. (k, v, m) Type.Gist.maplike -> m t = fun m v0 v1 -> 252 | failwith "TODO" 253 | 254 | and fun_product : type p. p Type.Gist.product -> p t = fun p v0 v1 -> 255 | failwith "TODO" 256 | 257 | and fun_record : type r. r Type.Gist.record -> r t = fun r v0 v1 -> 258 | failwith "TODO" 259 | 260 | and fun_sum : type s. s Type.Gist.sum -> s t = fun s v0 v1 -> 261 | failwith "TODO" 262 | 263 | and fun_func : 264 | type d r. (d, r) Type.Gist.func -> (d -> r) t = fun f v0 v1 -> 265 | failwith "TODO" 266 | 267 | and fun_abstract : 268 | type a. a Type.Gist.abstract -> a t = fun a v0 v1 -> 269 | failwith "TODO" 270 | 271 | and fun_gist : type a. a Type.Gist.t -> a t = fun g v0 v1 -> match g with 272 | | Scalar s -> fun_scalar s v0 v1 273 | | Arraylike a -> fun_arraylike a v0 v1 274 | | Maplike m -> fun_maplike m v0 v1 275 | | Product p -> fun_product p v0 v1 276 | | Record r -> fun_record r v0 v1 277 | | Sum s -> fun_sum s v0 v1 278 | | Func f -> fun_func f v0 v1 279 | | Abstract a -> fun_abstract a v0 v1 280 | | Lazy (_, g) -> fun_gist g (Lazy.force v0) (Lazy.force v1) 281 | | Ref (_, g) -> fun_gist g !v0 !v1 282 | | Rec g -> fun_gist (Lazy.force g) v0 v1 283 | end 284 | ]} 285 | 286 | {2:meta Defining processing metadata} 287 | 288 | If your generic function needs additional metadata. 289 | -------------------------------------------------------------------------------- /src/typegist.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2023 The typegist programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | (** Extended {!Stdlib.Type} and {!Stdlib.Fun} modules. Open to use it. 7 | 8 | Open the module to use it. This adds these modules 9 | 10 | {!modules: Type.Gist Fun.Generic} 11 | 12 | to the {!Stdlib.Type} and {!Stdlib.Func} modules. Before OCaml 5.1 13 | this also defines the {!Type} module. 14 | 15 | The [typegist] library: 16 | 17 | Open the module to use it, this only redefines the [Type] and [Fun] modules 18 | in your scope. 19 | *) 20 | 21 | (** Type introspection. *) 22 | module Type : sig 23 | 24 | type (_, _) eq = Equal: ('a, 'a) eq (** *) 25 | (** The purpose of [eq] is to represent type equalities that may not otherwise 26 | be known by the type checker (e.g. because they may depend on dynamic 27 | data). 28 | 29 | A value of type [(a, b) eq] represents the fact that types [a] and [b] 30 | are equal. 31 | 32 | If one has a value [eq : (a, b) eq] that proves types [a] and [b] are 33 | equal, one can use it to convert a value of type [a] to a value of type 34 | [b] by pattern matching on [Equal]: 35 | {[ 36 | let cast (type a) (type b) (Equal : (a, b) Type.eq) (a : a) : b = a 37 | ]} 38 | 39 | At runtime, this function simply returns its second argument unchanged. 40 | 41 | Available in OCaml 5.1. *) 42 | 43 | (** Type identifiers (available in OCaml 5.1). 44 | 45 | A type identifier is a value that denotes a type. Given two type 46 | identifiers, they can be tested for {{!Id.provably_equal}equality} to 47 | prove they denote the same type. Note that: 48 | 49 | - Unequal identifiers do not imply unequal types: a given type can be 50 | denoted by more than one identifier. 51 | - Type identifiers can be marshalled, but they get a new, distinct, 52 | identity on unmarshalling, so the equalities are lost. *) 53 | module Id : sig 54 | 55 | (** {1:ids Type identifiers} *) 56 | 57 | type !'a t 58 | (** The type for identifiers for type ['a]. *) 59 | 60 | val make : unit -> 'a t 61 | (** [make ()] is a new type identifier. *) 62 | 63 | val uid : 'a t -> int 64 | (** [uid id] is a runtime unique identifier for [id]. *) 65 | 66 | val provably_equal : 'a t -> 'b t -> ('a, 'b) eq option 67 | (** [provably_equal i0 i1] is [Some Equal] if identifier [i0] is equal 68 | to [i1] and [None] otherwise. *) 69 | end 70 | 71 | (** Type gists. 72 | 73 | Type gists reflect the essence of your types as OCaml values of 74 | a given {{!Gist.type-t}representation type}. 75 | 76 | Type gists are useful to type the interface of your values at 77 | the boundaries of your program or to devise generic type indexed 78 | functions. 79 | 80 | See the {{!page-quick}quick start}. The {{!page-cookbook}cookbook} 81 | has simple description examples. Generic functions 82 | can be found in {!Fun.Generic} and this is 83 | a {{!page-cookbook.writing_generic}generic function template} 84 | to write your own. *) 85 | module Gist : sig 86 | 87 | (** {1:intf Interfaces} 88 | 89 | Interfaces allow to directly inject types that satisfy a given 90 | interface in the representation. *) 91 | 92 | (** {2:array_interface Arrays} *) 93 | 94 | (** Array interface. *) 95 | module type ARRAY = sig 96 | type t 97 | (** The type for arrays. *) 98 | 99 | type elt 100 | (** The type of elements of the array. *) 101 | 102 | val get : t -> int -> elt 103 | (** [get a i] is the [i]th zero-based element of [a]. *) 104 | 105 | val set : t -> int -> elt -> unit 106 | (** [set a i v] sets the [i]th zero-based element of [a] to [v]. *) 107 | 108 | val length : t -> int 109 | (** [length a] is the length of [a]. *) 110 | 111 | val init : int -> (int -> elt) -> t 112 | (** [init n f] is an array of length [n] with [get v i = f i]. *) 113 | 114 | val iter : (elt -> unit) -> t -> unit 115 | (** [iter] iterates over all elements of the array in increasing 116 | index order. *) 117 | 118 | val fold_left : ('a -> elt -> 'a) -> 'a -> t -> 'a 119 | (** [fold_left f init a] folds [f] over [a]'s elements in increasing 120 | index order starting with [init]. *) 121 | 122 | val type_name : string 123 | (** [type_name] is a type name for the array. *) 124 | end 125 | 126 | type ('elt, 'arr) array_module = 127 | (module ARRAY with type t = 'arr and type elt = 'elt) 128 | (** The type for representing array types of type ['a] with elements 129 | of type ['elt]. *) 130 | 131 | (** {2:map_interface Maps} *) 132 | 133 | (** Map interface. *) 134 | module type MAP = sig 135 | type t 136 | (** The type for maps. *) 137 | 138 | type key 139 | (** The type for map keys. *) 140 | 141 | type value 142 | (** The type for map values. *) 143 | 144 | val empty : t 145 | (** [empty] is an empty map. *) 146 | 147 | val mem : key -> t -> bool 148 | (** [mem k m] is [true] iff [m] has a binding for [k]. *) 149 | 150 | val add : key -> value -> t -> t 151 | (** [add k v m] is [m] with [k] binding to [v]. *) 152 | 153 | val remove : key -> t -> t 154 | (** [remove k m] is [m] without a binding for [k]. *) 155 | 156 | val find_opt : key -> t -> value option 157 | (** [find_opt k m] is the binding for key [k] in [m] (if any). *) 158 | 159 | val fold : (key -> value -> 'acc -> 'acc) -> t -> 'acc -> 'acc 160 | (** [fold f m init] folds over the bindings of [m] with [f] 161 | starting with [init]. *) 162 | 163 | val equal : t -> t -> bool 164 | (** [equal eq m0 m1] tests whether [m0] and [m1] contain 165 | equal keys and associate them with equal values. *) 166 | 167 | val compare : t -> t -> int 168 | (** [compare cmp m0 m1] totally order [m0] and [m1] with 169 | [cmp] used to compare the value of equal keys. *) 170 | 171 | val type_name : string 172 | (** [type_name] is a type name for the map. *) 173 | end 174 | 175 | type ('k, 'v, 'm) map_module = 176 | (module MAP with type t = 'm and type key = 'k and type value = 'v) 177 | (** The type for representing map types of type ['m] mapping keys of type 178 | ['k] to values of type ['v]. *) 179 | 180 | (** {1:type_representation Type representation} *) 181 | 182 | (** Gist metadata. 183 | 184 | Metadata, found throughout the description, allows to 185 | associate arbitrary type-dependent key-value data to the 186 | description. Processors can create and expose new keys to 187 | allow descriptions to influence their outputs. 188 | 189 | Since the key value can depend on the type of the type you 190 | describe the interface is slightly unusual compared 191 | to a classic heterogeneous dictionary. A key is the result of 192 | a functor instantiated with the data type of the value. For example: 193 | {[ 194 | type 'a fmt = Format.formatter -> 'a -> unit 195 | module Meta_fmt = Type.Gist.Meta.Key (struct type 'a t = 'f fmt end) 196 | module Meta_skip = Type.Gist.Meta.Key (struct type 'a t = bool end) 197 | ]} 198 | you can then use the module's {{!Meta.KEY}key interface} to test 199 | key membership, add and remove data for the key. For example: 200 | {[ 201 | let meta : int Meta.t = 202 | Type.Gist.Meta.empty |> Meta_fmt.add Format.pp_print_int 203 | 204 | let meta : string Meta.t = 205 | Type.Gist.Meta.empty |> Meta_fmt.add Format.pp_print_string 206 | ]}*) 207 | module Meta : sig 208 | type 'a t 209 | (** The type for metadata for types of type ['a]. Key values 210 | can depend on ['a]. *) 211 | 212 | val make : doc:string -> 'a t 213 | (** [make ~doc] is [Doc.add doc empty]. *) 214 | 215 | val empty : 'a t 216 | (** [empty] is the empty metadata. *) 217 | 218 | val is_empty : 'a t -> bool 219 | (** [is_empty m] is [iff] [m] has no bindings. *) 220 | 221 | (** Type signature to describe the type dependent value 222 | of a type. *) 223 | module type VALUE = sig 224 | type 'a t 225 | (** The type for the key value that depends on ['a]. *) 226 | end 227 | 228 | (** The type for key modules. 229 | 230 | A key module is a module that handles a specific key. *) 231 | module type KEY = sig 232 | type 'a meta := 'a t 233 | 234 | type 'a value 235 | (** The type for the key's value. *) 236 | 237 | val mem : 'a meta -> bool 238 | (** [mem m] is [true] iff [m] has a binding for the key. *) 239 | 240 | val add : 'a value -> 'a meta -> 'a meta 241 | (** [add v m] is [m] with the key bound to [v] *) 242 | 243 | val find : 'a meta -> 'a value option 244 | (** [find m] is the binding for the key (if any). *) 245 | 246 | val remove : 'a meta -> 'a meta 247 | (** [remove m] is [m] with the binding for the key removed (if 248 | bound). *) 249 | end 250 | 251 | (** [Key (V)] is a new key with values of type ['a V.t]. *) 252 | module Key (V : VALUE) : KEY with type 'a value = 'a V.t 253 | 254 | (** {1:std_keys Standard keys} *) 255 | 256 | (** [Doc] is a key for a doc string. *) 257 | module Doc : KEY with type 'a value = string 258 | 259 | (** [Ignore] is a key for specifying to ignore the description. *) 260 | module Ignore : KEY with type 'a value = bool 261 | end 262 | 263 | type type_name = string 264 | (** The type for type names as accessed from the top level scope. E.g 265 | [Buffer.t]. *) 266 | 267 | type case_name = string 268 | (** The type for case constructor names as accessed from the top level 269 | scope. E.g. [Either.Left]. *) 270 | 271 | type 'a scalar = 272 | | Unit : unit Meta.t -> unit scalar 273 | | Bool : bool Meta.t -> bool scalar 274 | | Char : char Meta.t -> char scalar 275 | | Uchar : Uchar.t Meta.t -> Uchar.t scalar 276 | | Int : int Meta.t -> int scalar 277 | | Int32 : int32 Meta.t -> int32 scalar 278 | | Int64 : int64 Meta.t -> int64 scalar 279 | | Nativeint : nativeint Meta.t -> nativeint scalar 280 | | Float : float Meta.t -> float scalar (** *) 281 | (** The type for representing scalar types of type ['a]. 282 | See {{!scalar_ops}scalars}. *) 283 | 284 | type bytes_encoding = [ `Bytes | `Utf_8 ] 285 | (** The type for specifying the two standard interpretations of 286 | OCaml [bytes] and [string] values. *) 287 | 288 | type ('elt, 'arr) arraylike = 289 | | String : string Meta.t * bytes_encoding -> (char, string) arraylike 290 | | Bytes : bytes Meta.t * bytes_encoding -> (char, bytes) arraylike 291 | | Array : 'elt array Meta.t * 'elt t -> ('elt, 'elt array) arraylike 292 | | Bigarray1 : 293 | ('elt, 'b, 'c) Bigarray.Array1.t Meta.t * 294 | ('elt, 'b) Bigarray.kind * 'c Bigarray.layout * 'elt t -> 295 | ('elt, ('elt, 'b, 'c) Bigarray.Array1.t) arraylike 296 | | Array_module : 297 | 'arr Meta.t * ('elt, 'arr) array_module * 'elt t -> 298 | ('elt, 'arr) arraylike 299 | (** *) 300 | (** The type for representing array types of type ['a] with 301 | elements of type ['elt]. See {{!arraylike_ops}arraylike}. *) 302 | 303 | and ('k, 'v, 'm) maplike = 304 | | Hashtbl : 305 | ('k, 'v) Hashtbl.t Meta.t * 'k t * 'v t -> 306 | ('k, 'v, ('k, 'v) Hashtbl.t) maplike 307 | | Map_module : 308 | 'm Meta.t * ('k, 'v, 'm) map_module * 'k t * 'v t -> 309 | ('k, 'v, 'm) maplike 310 | (** *) 311 | (** The type for representing map types of type ['m] mapping keys of 312 | type ['k] to values of type ['v]. 313 | See {{!maplike_ops}maplike}. *) 314 | 315 | and 'p product 316 | (** The type for representing product types of type ['p]. 317 | See {{!product_ops}products}. *) 318 | 319 | and 'r record = 'r product 320 | (** The type for representing record types of type ['r]. 321 | See {{!record_ops}records}. *) 322 | 323 | and 'v variant 324 | (** The type for representing variants of type ['v]. 325 | See {{!variant_ops}variants}. *) 326 | 327 | and 's sum = 328 | | Option : 'a option Meta.t * 'a t -> 'a option sum 329 | | Either : ('a, 'b) Either.t Meta.t * 'a t * 'b t -> ('a, 'b) Either.t sum 330 | | Result : ('a, 'b) result Meta.t * 'a t * 'b t -> ('a, 'b) result sum 331 | | List : 'a list Meta.t * 'a t -> 'a list sum 332 | | Variant : 'v variant -> 'v sum (** *) 333 | (** The type for representing sum types of type ['s]. See 334 | {{!sum_ops}sums}. *) 335 | 336 | and ('a, 'b) func 337 | (** The type for representing functions types ['a -> 'b]. 338 | See {{!function_ops}functions}. *) 339 | 340 | and 'a abstract 341 | (** The type for representing abstract types of type ['a]. 342 | See {{!abstract_ops}abstract types}. *) 343 | 344 | and 'a t = 345 | | Scalar : 'a scalar -> 'a t 346 | | Arraylike : ('elt, 'arr) arraylike -> 'arr t 347 | | Maplike : ('k, 'v, 'm) maplike -> 'm t 348 | | Product : 'p product -> 'p t 349 | | Record : 'r record -> 'r t 350 | | Sum : 's sum -> 's t 351 | | Func : ('a, 'b) func -> ('a -> 'b) t 352 | | Abstract : 'a abstract -> 'a t 353 | | Lazy : 'a lazy_t Meta.t * 'a t -> 'a lazy_t t 354 | | Ref : 'a ref Meta.t * 'a t -> 'a ref t 355 | | Rec : 'a t lazy_t -> 'a t (** Recursion *) 356 | (** The type for type gists. *) 357 | 358 | (** {1:constructors Constructors and operations} *) 359 | 360 | val todo : ?type_name:type_name -> unit -> 'a t 361 | (** [todo ~type_name ()] is a stub gist. Generic functions 362 | will raise [Invalid_argument] when they hit the stub. *) 363 | 364 | val ref : ?meta:'a ref Meta.t -> 'a t -> 'a ref t 365 | (** [ref g] is [Ref g]. *) 366 | 367 | val lazy' : ?meta:'a lazy_t Meta.t -> 'a t -> 'a lazy_t t 368 | (** [lazy' ~meta g] is [Lazy (meta, g)]. *) 369 | 370 | val rec' : 'a t lazy_t -> 'a t 371 | (** [rec' lg] is [Rec lg]. *) 372 | 373 | (** {2:scalar_ops Scalars} *) 374 | 375 | (** Operating on scalar types. *) 376 | module Scalar : sig 377 | 378 | type 'a t = 'a scalar 379 | (** The type for scalars of type ['a]. *) 380 | 381 | val meta : 'a scalar -> 'a Meta.t 382 | (** [meta s] is the meta of [s]. *) 383 | 384 | val zero : 'a scalar -> 'a 385 | (** [zero s] is a zero value for [s]. *) 386 | 387 | val type_name : 'a scalar -> type_name 388 | (** [type_name s] is the OCaml type name of the scalar of [s]. *) 389 | 390 | val with_meta : 'a Meta.t -> 'a scalar -> 'a scalar 391 | (** [with_meta meta s] is [s] with meta [meta]. *) 392 | 393 | val equal : 'a scalar -> 'a -> 'a -> bool 394 | (** [equal s v0 v1] is [true] iff [v0] and [v1] are the same 395 | value as per the Stdlib's corresponding [M.equal] function. *) 396 | 397 | val compare : 'a scalar -> 'a -> 'a -> int 398 | (** [equal s v0 v1] is [true] iff [v0] and [v1] are the same 399 | value as per the Stdlib's corresponding [M.compare] function. *) 400 | 401 | val pp : 'a scalar -> Format.formatter -> 'a -> unit 402 | (** [pp s] is a formatter for scalar [s] *) 403 | 404 | val to_string : 'a scalar -> 'a -> string 405 | (** [to_string s v] converts [v] to a string. This uses the 406 | Stdlib's corresponding [M.to_string] functions, except 407 | for: 408 | {ul 409 | {- [char], UTF-8 compatible characters are output as is, 410 | otherwise hex escaped. {b TODO.} 411 | What about simply interpreting the byte as a Unicode scalar 412 | value ? (that'd give a latin1 interpretation I think).} 413 | {- [Uchar.t], the UTF-8 encoding of the character is returned}} *) 414 | end 415 | 416 | val unit : unit t 417 | (** [unit] is [Scalar (Unit Meta.empty)]. *) 418 | 419 | val bool : bool t 420 | (** [bool] is [Scalar (Bool Meta.empty)]. *) 421 | 422 | val char : char t 423 | (** [char] is [Scalar (Char Meta.empty)]. *) 424 | 425 | val uchar : Uchar.t t 426 | (** [uchar] is [Scalar (Uchar Meta.empty)]. *) 427 | 428 | val int : int t 429 | (** [int] is [Scalar (Int Meta.empty)]. *) 430 | 431 | val int32 : int32 t 432 | (** [int32] is [Scalar (Int32 Meta.empty)]. *) 433 | 434 | val int64 : int64 t 435 | (** [int64] is [Scalar (Int64 Meta.empty)]. *) 436 | 437 | val nativeint : nativeint t 438 | (** [nativeint] is [Scalar (Nativeint Meta.empt)y]. *) 439 | 440 | val float : float t 441 | (** [float] is [Scalar (Float Meta.empty)]. *) 442 | 443 | (** {2:arraylike_ops Arraylike} 444 | 445 | The arraylike type gathers {{!type-array_module}generic linear arrays} 446 | and a few {{!type-arraylike}special cases} for linear array types 447 | of the standard library. The specialisation can be 448 | {{!Arraylike.to_array_module}converted} to generic linear arrays. *) 449 | 450 | (** Operating on arraylike types. *) 451 | module Arraylike : sig 452 | 453 | (** {1:arraylike Arraylikes} *) 454 | 455 | type 'a gist := 'a t 456 | 457 | type ('elt, 'arr) t = ('elt, 'arr) arraylike 458 | (** The type for representing arraylike types of type ['arr] 459 | with elements of type ['elt]. *) 460 | 461 | val meta : ('elt, 'arr) arraylike -> 'arr Meta.t 462 | (** [meta a] is the metadata of [a]. *) 463 | 464 | val type_name : ('elt, 'arr) arraylike -> type_name 465 | (** [type_name a] is the type name of [a]. *) 466 | 467 | val elt : ('elt, 'arr) t -> 'elt gist 468 | (** [elt a] is the representation of the elements of [a]. *) 469 | 470 | val with_meta : 471 | 'arr Meta.t -> ('elt, 'arr) arraylike -> ('elt, 'arr) arraylike 472 | (** [with_meta meta a] is [a] with meta [meta]. *) 473 | 474 | (** {1:generalizing Generalizing to array modules} *) 475 | 476 | val to_array_module : ('elt, 'arr) arraylike -> ('elt, 'arr) array_module 477 | (** [to_array_module a] is an array module for [a]. 478 | Note that if [a] is {!constructor-String}, the {!ARRAY.set} 479 | function raises [Invalid_argument] in the resulting module. *) 480 | end 481 | 482 | val string_as_bytes : string t 483 | (** [string_as_bytes] is [Arraylike (String (Meta.empty, `Bytes))]. *) 484 | 485 | val string_as_utf_8 : string t 486 | (** [string_as_utf_8] is [Arraylike (String (Meta.empty, `Utf_8))]. *) 487 | 488 | val bytes_as_bytes : bytes t 489 | (** [bytes_as_bytes] is [Arraylike (Bytes (Meta.empty, `Bytes))]. *) 490 | 491 | val bytes_as_utf_8 : bytes t 492 | (** [bytes_as_utf_8] is [Arraylike (Bytes (Meta.empty, `Utf_8))]. *) 493 | 494 | val array : ?meta:'elt array Meta.t -> 'elt t -> 'elt array t 495 | (** [array] represents arrays with elements of given representation. *) 496 | 497 | val bigarray1 : 498 | ?meta:('elt, 'b, 'c) Bigarray.Array1.t Meta.t -> 499 | ('elt, 'b) Bigarray.kind -> 'c Bigarray.layout -> 500 | 'elt t -> ('elt, 'b, 'c) Bigarray.Array1.t t 501 | (** [bigarray] represents bigarrays with elements of given 502 | representation. *) 503 | 504 | val array_module : ?meta:'arr Meta.t -> 505 | ('elt, 'arr) array_module -> 'elt t -> 'arr t 506 | (** [array_module] represents array modules with elements of the 507 | given representation. *) 508 | 509 | (** {2:maplike_ops Maplike} 510 | 511 | The maplike type gathers generic {{!MAP}functional key value 512 | maps} and a {{!type-maplike}special case} for hash tables. *) 513 | 514 | (** Operations on maplikes. *) 515 | module Maplike : sig 516 | 517 | (** {1:maplikes Maplikes} *) 518 | 519 | type 'a gist := 'a t 520 | 521 | type ('k, 'v, 'm) t = ('k, 'v, 'm) maplike 522 | (** The type for representing maplike types of type ['m] 523 | with keys of type ['k] and values of type ['v]. *) 524 | 525 | val meta : ('k, 'v, 'm) maplike -> 'm Meta.t 526 | (** [meta m] is the metadata of [m]. *) 527 | 528 | val type_name : ('k, 'v, 'm) maplike -> type_name 529 | (** [type_name m] is the type name of [m]. *) 530 | 531 | val key : ('k, 'v, 'm) maplike -> 'k gist 532 | (** [key m] is the representation of the keys of [m]. *) 533 | 534 | val value : ('k, 'v, 'm) maplike -> 'v gist 535 | (** [value m] is the representation of the values of [m]. *) 536 | 537 | val with_meta : 'm Meta.t -> ('k, 'v, 'm) maplike -> ('k, 'v, 'm) maplike 538 | (** [with_meta meta m] is [m] with meta [meta]. *) 539 | 540 | (** {1:map_modules Map modules from [Map.S] modules} *) 541 | 542 | (** The type for map values. *) 543 | module type VALUE = sig 544 | type t 545 | (** The type for map values. *) 546 | 547 | val equal : t -> t -> bool 548 | (** [equal] tests values for equality. *) 549 | 550 | val compare : t -> t -> int 551 | (** [compare] is a total order on values compatible with {!equal}. *) 552 | end 553 | 554 | module Map_module_of_map (V : VALUE) (M : Map.S) : MAP 555 | with type t = V.t M.t 556 | and type key = M.key 557 | and type value = V.t 558 | (** [Map_module_of_map (V) (M)] is a map module for standard 559 | library map [M] with value of type [V]. *) 560 | end 561 | 562 | val hashtbl : 563 | ?meta:('k, 'v) Hashtbl.t Meta.t -> 'k t -> 'v t -> 564 | ('k, 'v) Hashtbl.t t 565 | (** [hashtbl] represents hashtables with keys and values of 566 | given representations. *) 567 | 568 | val map_module : 569 | ?meta:'m Meta.t -> ('k, 'v, 'm) map_module -> 'k t -> 'v t -> 'm t 570 | (** [map_module m k v] represents map modules with keys and values 571 | of the given representations. See {{!Maplike.map_modules}here} 572 | create map modules from standard library maps. *) 573 | 574 | (** {2:product_ops Products} 575 | 576 | Products (tuples), records and variant cases are all products 577 | of types. The toplevel type representation distinguishes them in 578 | different cases but otherwise they share the same representation: a 579 | product of typed and possibly named fields. 580 | 581 | The {!type-field} type represents an individual field of a product. The 582 | {!type-fields} type represent the ordered sequence of fields and the 583 | way to construct the product from its fields with a constructor 584 | function. *) 585 | 586 | type ('p, 'f) field 587 | (** The type for representing the field of type ['f] of a product of 588 | type ['p]. See the {!Field} module. *) 589 | 590 | type ('p, _) fields = 591 | | Ctor : 'ctor -> ('p, 'ctor) fields 592 | | App : ('p, 'f -> 'a) fields * ('p, 'f) field -> ('p, 'a) fields (** *) 593 | (** The type for representing the fields of a product of type ['p] and 594 | its construction via a constructor function. See the {!Fields} module. 595 | 596 | When a fields value types with [('p, 'p) fields] we know how 597 | to project each field of product ['p] and how to construct a 598 | value from its fields. *) 599 | 600 | (** Operating on fields. 601 | 602 | Fields represent components of {{!module-Product}products} which are 603 | used to represent OCaml's tuples, records and variants 604 | cases. *) 605 | module Field : sig 606 | 607 | (** {1:fields Fields} *) 608 | 609 | type 'a gist := 'a t 610 | 611 | type ('p, 'f) t = ('p, 'f) field 612 | (** The type for representing the field of type ['f] of a product of 613 | type ['p]. *) 614 | 615 | val make : 616 | ?meta:('p, 'f) field Meta.t -> ?name:string -> 617 | ?inject:('p -> 'f -> 'p) -> ?set:('p -> 'f -> unit) -> 618 | ?default:'f -> 'f gist -> 619 | ('p -> 'f) -> ('p, 'f) field 620 | (** [v g project] is a field such that: 621 | {ul 622 | {- [g] is the type representation of the field.} 623 | {- [project] projects the field value from the product.} 624 | {- [meta] is the metadata (defaults to {!Meta.empty}).} 625 | {- [name] is the name for the field (defaults to [""]). For 626 | record fields this is the field name. For variant case this is 627 | the case name. For tuples this is the empty string or a 628 | name for a type abbreviation.} 629 | {- [inject] is an immutable update function to update the field 630 | of the prodcut (defaults to [None]).} 631 | {- [set] is a mutable update function to set the field of the 632 | product, for mutable record fields (defaults to [None]).} 633 | {- [default] is a default value for the dimension 634 | (defaults to [None]).}} *) 635 | 636 | val meta : ('p, 'f) field -> ('p, 'f) field Meta.t 637 | (** [meta f] is the meta of [f]. *) 638 | 639 | val name : ('p, 'f) field -> string 640 | (** [name f] is the name of [f] (if any). *) 641 | 642 | val gist : ('p, 'f) field -> 'f gist 643 | (** [gist f] is the gist of [f]. *) 644 | 645 | val project : ('p, 'f) field -> ('p -> 'f) 646 | (** [project f] is the projection function of [f]. *) 647 | 648 | val inject : ('p, 'f) field -> ('p -> 'f -> 'p) option 649 | (** [inject f] is the optional immutable function of [f]. *) 650 | 651 | val set : ('p, 'f) field -> ('p -> 'f -> unit) option 652 | (** [set f] is the optional mutable function of [f]. *) 653 | 654 | val default : ('p, 'f) field -> 'f option 655 | (** [default f] is a default value for the field. *) 656 | end 657 | 658 | (** Operating on sequences of fields. *) 659 | module Fields : sig 660 | 661 | (** {1:fields Fields} *) 662 | 663 | type ('p, 'a) t = ('p, 'a) fields 664 | (** The type for fields for a type of type ['p]. 665 | 666 | The ['a] represents the partial application of a constructor to 667 | the fields. Once ['a] is equal to ['p] we have a 668 | {{!module-Product}product}. *) 669 | 670 | val ctor : 'a -> ('p, 'a) fields 671 | (** [ctor f] is [Ctor f]. This lifts the constructor function [f] for 672 | the type ['p] in order to construct a list of fields with {!app} 673 | yielding a result of type ['p]. *) 674 | 675 | val app : ('p, 'f -> 'a) fields -> ('p, 'f) field -> ('p, 'a) fields 676 | (** [app fs f] is [App (fs, f)] *) 677 | 678 | val is_empty : ('p, 'a) fields -> bool 679 | (** [is_empty fs] is [true] if [fs] has no fields. *) 680 | 681 | val is_singleton : ('p, 'a) fields -> bool 682 | (** [is_singleton fs] is [true] if [fs] has a single field. *) 683 | end 684 | 685 | (** Operating on products. *) 686 | module Product : sig 687 | 688 | (** {1:products Products} *) 689 | 690 | type 'p t = 'p product 691 | (** The type for products. *) 692 | 693 | val make : 694 | ?meta:'p Meta.t -> ?name:string -> ('p, 'p) fields -> 'p product 695 | (** [make fields] is a product with: 696 | {ul 697 | {- [fields] the ordered sequence of fields of the product.} 698 | {- [meta] is the metadata (defaults to {!Meta.empty}).} 699 | {- [name] the name of the product (defaults to [""]). For records 700 | this is the {{!type_name}type name}. For variant cases this is 701 | the case constructor name. For products, if non empty, this is 702 | the {{!type_name}type name} of a type abbreviation.}} *) 703 | 704 | val meta : 'p product -> 'p Meta.t 705 | (** [meta p] is the metadata of [p]. *) 706 | 707 | val name : 'p product -> string 708 | (** [name p] is the name of [p] (if any). For records or products this 709 | is the {{!type_name}type name} for variant cases this is 710 | the {{!case_name}case name}. *) 711 | 712 | val fields : 'p product -> ('p, 'p) fields 713 | (** [fields p] are the fields of [p]. *) 714 | 715 | val is_empty : 'p product -> bool 716 | (** [is_empty p] is [true] if [p] has no fields. *) 717 | 718 | val is_singleton : 'p product -> bool 719 | (** [is_singleton p] is [true] if [p] has a single field. *) 720 | 721 | val rec_field_count : 'p product -> int 722 | (** [rec_field_count c] is the number of recursive fields 723 | in [c]. *) 724 | 725 | val with_meta : 'p Meta.t -> 'p product -> 'p product 726 | (** [with_meta meta p] is [p] with meta [meta]. *) 727 | 728 | (** {1:constructing Constructing description} 729 | 730 | This intermediate structure is used for constructing 731 | product descriptions. *) 732 | 733 | type ('p, 'ctor) cons 734 | (** The type for constructing product decriptions. *) 735 | 736 | end 737 | 738 | val field' : 739 | ('p, 'f) field -> ('p, 'f -> 'a) Product.cons -> ('p, 'a) Product.cons 740 | (** [field f p] adds [f] to the construction of [p]. *) 741 | 742 | val field : 743 | ?meta:('p, 'f) field Meta.t -> ?inject:('p -> 'f -> 'p) -> 744 | ?set:('p -> 'f -> unit) -> ?default:'f -> string -> 'f t -> 745 | ('p -> 'f) -> ('p, 'f -> 'a) Product.cons -> ('p, 'a) Product.cons 746 | (** [field name g project p] defines a named field for a product ['v]. 747 | This is combines {!Field.make} and {!field'}. *) 748 | 749 | val dim : 750 | ?meta:('p, 'd) field Meta.t -> ?inject:('p -> 'd -> 'p) -> 751 | ?default:'d -> 'd t -> ('p -> 'd) -> 752 | ('p, 'd -> 'a) Product.cons -> ('p, 'a) Product.cons 753 | (** [dim] is like {!field} but is a nameless field. *) 754 | 755 | val product : 756 | ?meta:'p Meta.t -> ?type_name:type_name -> 'ctor -> 757 | ('p, 'ctor) Product.cons 758 | (** [product ctor] is a product constructed with [ctor] to be satured 759 | with {!Type.Gist.field} or {!Type.Gist.dim}. *) 760 | 761 | val finish_product : ('p, 'p) Product.cons -> 'p t 762 | (** [finish_product p] finishes the product to yield 763 | a {!constructor-Product} gist value. *) 764 | 765 | val p2 : 766 | ?meta:('a * 'b) Meta.t -> ?type_name:type_name -> 'a t -> 'b t -> 767 | ('a * 'b) t 768 | (** [p2] represents pairs with given dimensions types. *) 769 | 770 | val p3 : 771 | ?meta:('a * 'b *'c) Meta.t -> ?type_name:type_name -> 772 | 'a t -> 'b t -> 'c t -> ('a * 'b * 'c) t 773 | (** [p3] represents triplets with given dimensions types. *) 774 | 775 | val p4 : 776 | ?meta:('a * 'b * 'c * 'd) Meta.t -> ?type_name:type_name -> 777 | 'a t -> 'b t -> 'c t -> 'd t -> ('a * 'b * 'c * 'd) t 778 | (** [p4] represents quadruplets with given dimensions types. *) 779 | 780 | (** {2:record_ops Records} 781 | 782 | A record is a {{!product_ops}product} of named fields named 783 | after the record type name and tagged by 784 | {!constructor-Record}. The following are convenience 785 | combinators to build them. See 786 | {{!page-cookbook.describing_records}an example}. *) 787 | 788 | val record : 789 | ?meta:'r Meta.t -> type_name -> 'ctor -> ('r, 'ctor) Product.cons 790 | (** [record type_name ctor] is a record constructed with [ctor] to be 791 | satured with {!Type.Gist.field}. [type_name] is the record 792 | {{!type_name}type name}. *) 793 | 794 | val finish_record : ('r, 'r) Product.cons -> 'r t 795 | (** [finish_record f] finishes the record to yield a {!constructor-Record} 796 | gist value. *) 797 | 798 | (** {2:variant_ops Variants} 799 | 800 | Variants are described by a list of cases and function that 801 | indicate how to select the case for a value. A case is a 802 | {{!product_ops}product} named after the case name. *) 803 | 804 | (** Operating on variants. *) 805 | module Variant : sig 806 | 807 | (** {1:variant_cases Variant cases} *) 808 | 809 | type 'v case = 'v product 810 | (** The type for representing variant cases of a variant of 811 | type ['v]. The {!Product.name} is the constructor name. *) 812 | 813 | (** {1:variants Variants} *) 814 | 815 | type 'a gist := 'a t 816 | 817 | type 'v t = 'v variant 818 | (** The type for representing variants of type ['v]. *) 819 | 820 | val make : 821 | ?meta:'v Meta.t -> string -> ('v -> 'v case) -> 822 | 'v case list -> 'v variant 823 | (** [v type_name project cases] is a variant with type name [type_name] 824 | with deconstructor [project] and case enumeration [cases]. *) 825 | 826 | val meta : 'v variant -> 'v Meta.t 827 | (** [meta v] is the metadata of [v]. *) 828 | 829 | val type_name : 'v variant -> type_name 830 | (** [type_name v] is the type name of [v]. *) 831 | 832 | val project : 'v variant -> 'v -> 'v case 833 | (** [project v] is the projection function (case selector) of [v]. *) 834 | 835 | val cases : 'v variant -> 'v case list 836 | (** [cases v] are the variant's cases. *) 837 | 838 | (** {1:std Stdlib variants as variants} 839 | 840 | The {!sum} type has specializations for these variants. You should 841 | like use that if appropriate in your descriptions, 842 | see {{!sum_ops}sums}. Consumers of the representation can always 843 | generalize with {!Sum.to_variant} which invokes these functions. *) 844 | 845 | val of_option : ?meta:'a option Meta.t -> 'a gist -> 'a option variant 846 | (** [of_option] represents options of the given representation type 847 | as a variant. *) 848 | 849 | val of_either : 850 | ?meta:('a, 'b) Either.t Meta.t -> 'a gist -> 'b gist -> 851 | ('a, 'b) Either.t variant 852 | (** [of_option] represents eithers of the given representation type 853 | as a variant. *) 854 | 855 | val of_result : 856 | ?meta:('a, 'b) result Meta.t -> 'a gist -> 'b gist -> 857 | ('a, 'b) result variant 858 | (** [of_result] represents results of the given representation types 859 | as a variant. *) 860 | 861 | val of_list : ?meta:'a list Meta.t -> 'a gist -> 'a list variant 862 | (** [of_list] represents lists of the given representation type 863 | as a variant. *) 864 | end 865 | 866 | val case : 867 | ?meta:'v Meta.t -> case_name -> 'ctor -> ('v, 'ctor) Product.cons 868 | (** [case case_name ctor] is a variant case named [case_name] constructed 869 | with [ctor] to be satured with {!Type.Gist.dim} or 870 | {!Type.Gist.field} (for inline records). [name] is the 871 | OCaml constructor name of the case as accessed from the 872 | top level scope. E.g. ["Either.Left"]. *) 873 | 874 | val finish_case : ('v, 'v) Product.cons -> 'v Variant.case 875 | (** [finish_case f] finishes the case by giving the product 876 | to {!Variant.Case.make}. *) 877 | 878 | val case0 : ?meta:'v Meta.t -> string -> 'v -> 'v Variant.case 879 | (** [case0 name v] is [case name v |> finish_case]. *) 880 | 881 | val variant : 882 | ?meta:'v Meta.t -> case_name -> ('v -> 'v Variant.case) -> 883 | 'v Variant.case list -> 'v t 884 | (** [variant case_name project cases] is a variant decontructed by 885 | [project] and whose cases are enumerated in [cases]. 886 | [type_name] is the OCaml type name as accesed from the top 887 | level scope. This is {!Variant.make} wrapped in a 888 | {!constructor-Variant} and {!constructor-Sum} gist value. *) 889 | 890 | (** {2:sum_ops Sums} 891 | 892 | The sum type gathers {{!variant_ops}generic variants} and a few 893 | {{!type-sum}special cases} for variants of the standard library. 894 | The specialisation can be {{!Sum.to_variant}converted} to a generic 895 | variant. *) 896 | 897 | (** Operating on sums. *) 898 | module Sum : sig 899 | 900 | type 's t = 's sum 901 | (** The type for sum types of type ['s] *) 902 | 903 | val meta : 's sum -> 's Meta.t 904 | (** [meta s] is the meta of [s]. *) 905 | 906 | val type_name : 's sum -> string 907 | (** [type_name s] is the type name of [s]. *) 908 | 909 | val to_variant : 's sum -> 's variant 910 | (** [to_variant s] is [s] as a variant type representation. 911 | This generalizes the specialized {{!type-sum}[sum] cases} to the 912 | generic representation of variants. *) 913 | 914 | val with_meta : 's Meta.t -> 's sum -> 's sum 915 | (** [with_meta meta p] is [p] with meta [meta]. *) 916 | end 917 | 918 | val option : ?meta:'a option Meta.t -> 'a t -> 'a option t 919 | (** [option] represents options of the given representation type as 920 | an {!constructor-Option} wrapped in a {!constructor-Sum} gist value. *) 921 | 922 | val either : 923 | ?meta:('a, 'b) Either.t Meta.t -> 'a t -> 'b t -> ('a, 'b) Either.t t 924 | (** [either] represents eithers of the given representation types as 925 | an {!constructor-Either} wrapped in a {!constructor-Sum} gist value. *) 926 | 927 | val result : 928 | ?meta:('a, 'b) result Meta.t -> 'a t -> 'b t -> ('a, 'b) result t 929 | (** [result] represents results of the given representation types as 930 | an {!constructor-Result} wrapped in a {!constructor-Sum} gist value. *) 931 | 932 | val list : ?meta:'a list Meta.t -> 'a t -> 'a list t 933 | (** [list] represents lists of the given representation type as 934 | {!constructor-List} wrapped in a {!constructor-Sum} gist value. *) 935 | 936 | (** {2:function_ops Functions} *) 937 | 938 | (** Operating on functions. *) 939 | module Func : sig 940 | 941 | (** {1:functions Functions} *) 942 | 943 | type 'a gist := 'a t 944 | 945 | type ('a, 'b) t = ('a, 'b) func 946 | (** The type for representing functions from type ['a] to ['b]. *) 947 | 948 | val make : ?meta:('a -> 'b) Meta.t -> 'a gist -> 'b gist -> ('a, 'b) func 949 | (** [make d r] is a function with domain represented by [d] and 950 | range represented by [r]. *) 951 | 952 | val meta : ('a, 'b) func -> ('a -> 'b) Meta.t 953 | (** [meta f] is the metadata of [f]. *) 954 | 955 | val domain : ('a, 'b) func -> 'a gist 956 | (** [domain f] is representation of the domain of [f]. *) 957 | 958 | val range : ('a, 'b) func -> 'b gist 959 | (** [range f] is representation of the range of [f]. *) 960 | 961 | val with_meta : ('a -> 'b) Meta.t -> ('a, 'b) func -> ('a, 'b) func 962 | (** [with_meta meta f] is [f] with meta [meta]. *) 963 | end 964 | 965 | val func : ?meta:('a -> 'b) Meta.t -> 'a t -> 'b t -> ('a -> 'b) t 966 | (** [func ~meta d r] represents a function from domain [d] to 967 | range [r]. This is {!Func.make} wrapped in {!constructor-Func} 968 | gist value. *) 969 | 970 | val ( @-> ) : 'a t -> 'b t -> ('a -> 'b) t 971 | (** [d @-> r] is [func d r]. *) 972 | 973 | (** {2:abstract_ops Abstract types} 974 | 975 | Abstract types are represented by lists of versioned public 976 | {{!Abstract.module-Repr}representations} with which they can 977 | be converted. *) 978 | 979 | (** Operating on abstract types. *) 980 | module Abstract : sig 981 | 982 | (** Public representations. *) 983 | module Repr : sig 984 | type 't gist := 't t 985 | 986 | type ('a, 'repr) t 987 | (** The type for representing abtract types of type ['a] with 988 | public values of type ['repr]. *) 989 | 990 | val make : 991 | ?meta:'repr Meta.t -> version:string -> 'repr gist -> 992 | ('a -> 'repr) -> ('repr -> 'a) -> ('a, 'repr) t 993 | (** [make ~version r inject project] is a public representation 994 | for abstract type ['t] with: 995 | {ul 996 | {- [version] is a version name for the public representation. 997 | Intepretation is left to users, usually testing with 998 | string equality should be sufficient.} 999 | {- [r] is the representation representing the abstract type.} 1000 | {- [inject] injects abstract types in the public representation.} 1001 | {- [project] projects the public representation into the abstract 1002 | type.} 1003 | {- [meta] metadata for the representation.}} *) 1004 | 1005 | val meta : ('a, 'repr) t -> 'repr Meta.t 1006 | (** [meta r] is the metadata of [r]. *) 1007 | 1008 | val version : ('a, 'repr) t -> string 1009 | (** [version r] is a version name for the representation. *) 1010 | 1011 | val gist : ('a, 'repr) t -> 'repr gist 1012 | (** [gist r] is the public representation of [r]. *) 1013 | 1014 | val inject : ('a, 'repr) t -> 'a -> 'repr 1015 | (** [inject r] injects the abstract type into the public 1016 | type. *) 1017 | 1018 | val project : ('a, 'repr) t -> 'repr -> 'a 1019 | (** [project r] projects the public representation in the abstract 1020 | type. *) 1021 | 1022 | val with_meta : 'repr Meta.t -> ('a, 'repr) t -> ('a, 'repr) t 1023 | (** [with_meta meta r] is [r] with meta [meta]. *) 1024 | end 1025 | 1026 | type 't repr = Repr : ('t, 'rep) Repr.t -> 't repr 1027 | (** The type for existential abtract representation. *) 1028 | 1029 | val repr : 1030 | ?meta:'repr Meta.t -> version:string -> 'repr t -> 1031 | ('a -> 'repr) -> ('repr -> 'a) -> 'a repr 1032 | (** [repr ~version repr inject projet] is a public representation. 1033 | This is {!Repr.make} wrapped in {!constructor-Repr}. *) 1034 | 1035 | (** {1:abstract_types Abstract types} *) 1036 | 1037 | type 'a t = 'a abstract 1038 | (** The type for abstract types of type ['a]. *) 1039 | 1040 | val make : ?meta:'a Meta.t -> string -> reprs:'a repr list -> 'a abstract 1041 | (** [v ~meta name reprs] represents an abstract type named 1042 | [name] with public representations [reprs]. 1043 | 1044 | The first representation of [reprs] is assumed to be the 1045 | default one to use. Other representations can be used when 1046 | interfacing with systems that support representation 1047 | versioning. If [reprs] is empty, the type remains 1048 | abstract. *) 1049 | 1050 | val meta : 'a abstract -> 'a Meta.t 1051 | (** [meta a] is the metadata of [a]. *) 1052 | 1053 | val type_name : 'a abstract -> type_name 1054 | (** [type_name a] is the type name of [a]. *) 1055 | 1056 | val reprs : 'a abstract -> 'a repr list 1057 | (** [reprs a] are the public representations of [a]. The first 1058 | representation (if any) is the one to favour. *) 1059 | 1060 | val with_meta : 'a Meta.t -> 'a abstract -> 'a abstract 1061 | (** [with_meta meta a] is [a] with meta [meta]. *) 1062 | end 1063 | 1064 | val abstract : 1065 | ?meta:'a Meta.t -> type_name -> 'a Abstract.repr list -> 'a t 1066 | (** [abstract ~meta name reprs] represents an abstract type named 1067 | [type_name] with public representations [reprs]. This is 1068 | {!Abstract.make} wrapped in an {!constructor-Abstract} gist value. *) 1069 | 1070 | (** {2:gist_ops Gists} *) 1071 | 1072 | val meta : 'a t -> 'a Meta.t 1073 | (** [meta g] is [g]'s top meta. *) 1074 | 1075 | val with_meta : 'a Meta.t -> 'a t -> 'a t 1076 | (** [with_meta m g] is [g] with meta [meta]. *) 1077 | 1078 | val type_name : 'a t -> type_name 1079 | (** [type_name g] is [g]'s type name. *) 1080 | 1081 | val pp_type : Format.formatter -> 'a t -> unit 1082 | (** [pp_type g] formats a pseudo OCaml type expression for [g]. *) 1083 | end 1084 | end 1085 | 1086 | (** Function manipulation and generic functions. *) 1087 | module Fun : sig 1088 | 1089 | (** Generic functions. *) 1090 | module Generic :sig 1091 | 1092 | (** Generic function metadata keys. 1093 | 1094 | A few {!Type.Gist.Meta.t} keys to control the behaviour of generic 1095 | functions. *) 1096 | module Meta : sig 1097 | 1098 | (** Custom formatter key. 1099 | 1100 | The {!Fun.Generic.pp} function consults this key in the 1101 | metadata of a gist [g] before printing the value described 1102 | by the gist. If a formatter is found, the value is formatted 1103 | using that formatter instead. This can also be used to indicate 1104 | that you would not like to print a substructure by formatting 1105 | nothing, the {!Fmt.ignore} function does that. *) 1106 | module Fmt : sig 1107 | type 'a t = Format.formatter -> 'a -> unit 1108 | (** The type for custom value formatter of type ['a]. *) 1109 | 1110 | val ignore : 'a t 1111 | (** [ignore] formats nothing. *) 1112 | 1113 | include Type.Gist.Meta.KEY with type 'a value := 'a t (** @inline *) 1114 | end 1115 | 1116 | (** Custom equality key. 1117 | 1118 | The {!Fun.Generic.equal} function consults this key in the 1119 | metadata of a gist [g] before determining equality between 1120 | values described by the gist. If a function is found, the 1121 | values are compared with this function instead. 1122 | 1123 | This can also be used to indicate that you would not like to compare 1124 | a subtructure by always returning [true], the 1125 | {!Equal.ignore} function does that. *) 1126 | module Equal : sig 1127 | type 'a t = 'a -> 'a -> bool 1128 | (** The type for custom value equality of type ['a]. *) 1129 | 1130 | val ignore : 'a -> 'a -> bool 1131 | (** [ignore v0 v1] is [true]. *) 1132 | 1133 | include Type.Gist.Meta.KEY with type 'a value := 'a t (** @inline *) 1134 | end 1135 | 1136 | (** Custom comparison key. 1137 | 1138 | The {!Fun.Generic.compare} function consults this key in the 1139 | metadata of a gist [g] before comparing values described 1140 | by the gist. If a function is found, the values are compared 1141 | with this function instead. 1142 | 1143 | This can also be used to indicate that you would not like to 1144 | compare a substructure by always returning [0] (equal), the 1145 | {!Compare.ignore} function does that. *) 1146 | module Compare : sig 1147 | type 'a t = 'a -> 'a -> int 1148 | (** The type for custom value equality of type ['a]. *) 1149 | 1150 | val ignore : 'a -> 'a -> int 1151 | (** [ignore v0 v1] is [0]. *) 1152 | 1153 | include Type.Gist.Meta.KEY with type 'a value := 'a t (** @inline *) 1154 | end 1155 | 1156 | (** Custom random generator and random sizing. 1157 | 1158 | These keys influence the {!Fun.Generic.random} function. *) 1159 | module Random : sig 1160 | 1161 | (** Custom random generator. 1162 | 1163 | The {!Fun.Generic.random} function consults this key in the 1164 | metadata of a gist [g] before generating values described 1165 | by the gist. If a function is found, the values are generated 1166 | with this function instead. 1167 | 1168 | This can also be used to indicate that you would like a 1169 | substructure to remain constant. The {!Gen.const} function 1170 | does that. *) 1171 | module Gen : sig 1172 | 1173 | type 'a t = size:int -> Random.State.t -> bound:int -> 'a 1174 | (** The type for custom random generators. [bound] is a 1175 | bounding factor that depends on [size] for recursive data 1176 | structures when the bound reaches [0] you should no 1177 | longer recurse. *) 1178 | 1179 | val const : 'a -> 'a t 1180 | (** [const v] ignores the random generator and returns [v]. *) 1181 | 1182 | include Type.Gist.Meta.KEY with type 'a value := 'a t (** @inline *) 1183 | end 1184 | 1185 | (** Sizing factor alteration. 1186 | 1187 | The {!Fun.Generic.random} function consults this key in 1188 | the metadata of a gist [g] to determine the sizing factor 1189 | for generating a value described by the gist. *) 1190 | module Size : sig 1191 | type 'a t = int 1192 | include Type.Gist.Meta.KEY with type 'a value := 'a t (** @inline *) 1193 | end 1194 | end 1195 | end 1196 | 1197 | val pp : 'a Type.Gist.t -> Format.formatter -> 'a -> unit 1198 | (** [pp g ppf v] formats [v] as described by [g] on [ppf] with a pseudo 1199 | OCaml syntax similar to what you would see in the toplevel. 1200 | The function can be selectively overriden via the {!Meta.Fmt} 1201 | metadata key. Fields whose {!Type.Gist.Meta.Ignore} is [true] 1202 | are not printed. *) 1203 | 1204 | val equal : 'a Type.Gist.t -> 'a -> 'a -> bool 1205 | (** [equal g v0 v1] determines the equality of values [v0] and [v1] 1206 | as described by [g]. The process can be selectively overriden 1207 | via the {!Meta.Equal} metadata key. Fields whose 1208 | {!Type.Gist.Meta.Ignore} is [true] are ignored (are always equal). 1209 | 1210 | The function raises [Invalid_argument] on functional values and 1211 | abstract types without representation; you can ignore them by using 1212 | {!Meta.Equal.ignore} for their {!Meta.Equal} key. *) 1213 | 1214 | val compare : 'a Type.Gist.t -> 'a -> 'a -> int 1215 | (** [compare g v0 v1] compares values [v0] and [v1] as described by [g]. 1216 | The function can be selectively overriden via {!Meta.Compare} metadata 1217 | keys. Fields whose {!Type.Gist.Meta.Ignore} is [true] are ignored 1218 | (are always equal). 1219 | 1220 | The function raises [Invalid_argument] on function values and 1221 | abstract types without representation; you can ignore them 1222 | by using {!Meta.Compare.ignore} for their {!Meta.Compare} key. *) 1223 | 1224 | val random : 1225 | 'a Type.Gist.t -> ?size:int -> ?state:Random.State.t -> unit -> 'a 1226 | (** [random g ~state ()] generates a random value described by [g]. 1227 | [state] is the random state to use, defaults to 1228 | {!Random.get_state}[ ()]. 1229 | 1230 | FIXME do something with {!Type.Gist.Meta.Ignore}. 1231 | 1232 | [size] is an indicative strictly positive, size factor to let 1233 | users control an upper bound on the size and complexity of 1234 | generated values. It should be used by generators to 1235 | proportionally bound the length of sequences or the number of 1236 | nodes in trees. It can be altered by gists via the 1237 | {!Meta.Random.Size} key. 1238 | 1239 | The function raises [Invalid_argument] on functional values 1240 | (may be lifted in the future) and abstract types without 1241 | representation; you can represent them 1242 | by using a suitable {!Meta.Random.Gen.const} constant value for the 1243 | {!Meta.Random.Gen} key. *) 1244 | end 1245 | 1246 | include module type of Fun (** @closed *) 1247 | end 1248 | -------------------------------------------------------------------------------- /src/typegist.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2023 The typegist programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | module Type = struct 7 | 8 | (* As per Type module of OCaml 5.1 *) 9 | 10 | type (_, _) eq = Equal : ('a, 'a) eq 11 | module Id = struct 12 | type _ id = .. 13 | module type ID = sig type t type _ id += Id : t id end 14 | type 'a t = (module ID with type t = 'a) 15 | 16 | let make (type a) () : a t = 17 | (module struct type t = a type _ id += Id : t id end) 18 | 19 | let provably_equal 20 | (type a b) ((module A) : a t) ((module B) : b t) : (a, b) eq option 21 | = 22 | match A.Id with B.Id -> Some Equal | _ -> None 23 | 24 | let uid (type a) ((module A) : a t) = 25 | Obj.Extension_constructor.id (Obj.Extension_constructor.of_val A.Id) 26 | end 27 | 28 | (* Type gists *) 29 | 30 | module Gist = struct 31 | 32 | (* Metadata *) 33 | 34 | module Meta = struct 35 | (* Abstracting type constructors with one parameter. So that 36 | heterogeneous values in ['a Meta.t] can depend on ['a]. 37 | See Yallop and White Lightweight Higher-Kinded Polymorphism 38 | https://doi.org/10.1007/978-3-319-07151-0_8 *) 39 | module Higher = struct 40 | (* Snippet from https://github.com/yallop/higher 41 | MIT licensed Copyright (c) 2013 Leo White and Jeremy Yallop *) 42 | type ('a, 'f) app 43 | module Newtype1 (T : sig type 'a t end) = struct 44 | type 'a s = 'a T.t 45 | type t 46 | external inj : 'a -> 'b = "%identity" 47 | external prj : 'a -> 'b = "%identity" 48 | end 49 | end 50 | 51 | module M = Map.Make (Int) 52 | type 't key = 't Id.t 53 | type ('a, 't) value = ('a, 't) Higher.app 54 | type 'a binding = B : 't key * ('a, 't) value -> 'a binding 55 | type 'a t = 'a binding M.t 56 | let empty = M.empty 57 | let is_empty = M.is_empty 58 | 59 | module type VALUE = sig type 'a t end 60 | module type KEY = sig 61 | type 'a meta := 'a t 62 | type 'a value 63 | val mem : 'a meta -> bool 64 | val add : 'a value -> 'a meta -> 'a meta 65 | val find : 'a meta -> 'a value option 66 | val remove : 'a meta -> 'a meta 67 | end 68 | module Key (V : VALUE) = struct 69 | type 'a meta = 'a t 70 | module H = Higher.Newtype1 (V) 71 | type 'a value = 'a H.s 72 | type t = H.t 73 | let key = Id.make () 74 | let mem m = M.mem (Id.uid key) m 75 | let add v m = M.add (Id.uid key) (B (key, H.inj v)) m 76 | let remove m = M.remove (Id.uid key) m 77 | let find m = 78 | let find : type v a. v key -> a meta -> a value option = 79 | fun key m -> match M.find_opt (Id.uid key) m with 80 | | None -> None 81 | | Some B (k', v) -> 82 | match Id.provably_equal key k' with 83 | | None -> assert false | Some Equal -> Some (H.prj v) 84 | in 85 | find key m 86 | end 87 | module Doc = Key (struct type 'a t = string end) 88 | module Ignore = Key (struct type 'a t = bool end) 89 | let make ~doc = Doc.add doc M.empty 90 | end 91 | 92 | (* Interfaces *) 93 | 94 | module type ARRAY = sig 95 | type t 96 | type elt 97 | val get : t -> int -> elt 98 | val set : t -> int -> elt -> unit 99 | val length : t -> int 100 | val init : int -> (int -> elt) -> t 101 | val iter : (elt -> unit) -> t -> unit 102 | val fold_left : ('a -> elt -> 'a) -> 'a -> t -> 'a 103 | val type_name : string 104 | end 105 | 106 | type ('elt, 'arr) array_module = 107 | (module ARRAY with type t = 'arr and type elt = 'elt) 108 | 109 | module type MAP = sig 110 | type t 111 | type key 112 | type value 113 | val empty : t 114 | val mem : key -> t -> bool 115 | val add : key -> value -> t -> t 116 | val remove : key -> t -> t 117 | val find_opt : key -> t -> value option 118 | val fold : (key -> value -> 'acc -> 'acc) -> t -> 'acc -> 'acc 119 | val equal : t -> t -> bool 120 | val compare : t -> t -> int 121 | val type_name : string 122 | end 123 | 124 | type ('k, 'v, 'm) map_module = 125 | (module MAP with type t = 'm and type key = 'k and type value = 'v) 126 | 127 | (* Type representation *) 128 | 129 | type type_name = string 130 | type case_name = string 131 | 132 | type 'a scalar = 133 | | Unit : unit Meta.t -> unit scalar 134 | | Bool : bool Meta.t -> bool scalar 135 | | Char : char Meta.t -> char scalar 136 | | Uchar : Uchar.t Meta.t -> Uchar.t scalar 137 | | Int : int Meta.t -> int scalar 138 | | Int32 : int32 Meta.t -> int32 scalar 139 | | Int64 : int64 Meta.t -> int64 scalar 140 | | Nativeint : nativeint Meta.t -> nativeint scalar 141 | | Float : float Meta.t -> float scalar 142 | 143 | type bytes_encoding = [ `Bytes | `Utf_8 ] 144 | 145 | type ('elt, 'a) arraylike = 146 | | String : string Meta.t * bytes_encoding -> (char, string) arraylike 147 | | Bytes : bytes Meta.t * bytes_encoding -> (char, bytes) arraylike 148 | | Array : 'elt array Meta.t * 'elt t -> ('elt, 'elt array) arraylike 149 | | Bigarray1 : 150 | ('elt, 'b, 'c) Bigarray.Array1.t Meta.t * 151 | ('elt, 'b) Bigarray.kind * 'c Bigarray.layout * 'elt t -> 152 | ('elt, ('elt, 'b, 'c) Bigarray.Array1.t) arraylike 153 | | Array_module : 154 | 'arr Meta.t * ('elt, 'arr) array_module * 'elt t -> 155 | ('elt, 'arr) arraylike 156 | 157 | and ('k, 'v, 'm) maplike = 158 | | Hashtbl : 159 | ('k, 'v) Hashtbl.t Meta.t * 'k t * 'v t -> 160 | ('k, 'v, ('k, 'v) Hashtbl.t) maplike 161 | | Map_module : 162 | 'm Meta.t * ('k, 'v, 'm) map_module * 'k t * 'v t -> 163 | ('k, 'v, 'm) maplike 164 | 165 | and ('p, 'f) field = 166 | { meta : ('p, 'f) field Meta.t; 167 | name : string; 168 | gist : 'f t; 169 | project : ('p -> 'f); 170 | inject : ('p -> 'f -> 'p) option; 171 | set : ('p -> 'f -> unit) option; 172 | default : 'f option; } 173 | 174 | and ('t, _) fields = 175 | | Ctor : 'a -> ('t, 'a) fields 176 | | App : ('t, 'f -> 'a) fields * ('t, 'f) field -> ('t, 'a) fields 177 | 178 | and 'p product = 179 | { meta : 'p Meta.t; 180 | name : string; 181 | fields : ('p, 'p) fields } 182 | 183 | and 'r record = 'r product 184 | and 'v variant = 185 | { meta : 'v Meta.t; 186 | type_name : string; 187 | project : 'v -> 'v product; 188 | cases : 'v product list; } 189 | 190 | and 's sum = 191 | | Option : 'a option Meta.t * 'a t -> 'a option sum 192 | | Either : ('a, 'b) Either.t Meta.t * 'a t * 'b t -> ('a, 'b) Either.t sum 193 | | Result : ('a, 'b) result Meta.t * 'a t * 'b t -> ('a, 'b) result sum 194 | | List : 'a list Meta.t * 'a t -> 'a list sum 195 | | Variant : 'v variant -> 'v sum 196 | 197 | and ('a, 'b) func = 198 | { meta : ('a -> 'b) Meta.t; 199 | domain : 'a t; 200 | range : 'b t } 201 | 202 | and ('a, 'repr) abstract_repr = 203 | { meta : 'repr Meta.t; 204 | version : string; 205 | gist : 'repr t; 206 | inject : 'a -> 'repr; 207 | project : 'repr -> 'a; } 208 | 209 | and 'a abstract_repr_exists = 210 | | Repr : ('a, 'repr) abstract_repr -> 'a abstract_repr_exists 211 | 212 | and 'a abstract = 213 | { meta : 'a Meta.t; 214 | type_name : string; 215 | reprs : 'a abstract_repr_exists list; } 216 | 217 | and 'a t = 218 | | Scalar : 'a scalar -> 'a t 219 | | Arraylike : ('elt, 'arr) arraylike -> 'arr t 220 | | Maplike : ('k, 'v, 'm) maplike -> 'm t 221 | | Product : 'p product -> 'p t 222 | | Record : 'r record -> 'r t 223 | | Sum : 's sum -> 's t 224 | | Func : ('a, 'b) func -> ('a -> 'b) t 225 | | Abstract : 'a abstract -> 'a t 226 | | Lazy : 'a lazy_t Meta.t * 'a t -> 'a lazy_t t 227 | | Ref : 'a ref Meta.t * 'a t -> 'a ref t 228 | | Rec : 'a t lazy_t -> 'a t 229 | 230 | (* Constructors and helpers *) 231 | 232 | let todo ?(type_name = "") () = 233 | Rec (lazy (invalid_arg ("TODO: " ^ type_name ^ " gist"))) 234 | 235 | let rec' lg = Rec lg 236 | let ref ?(meta = Meta.empty) g = Ref (meta, g) 237 | let lazy' ?(meta = Meta.empty) g = Lazy (meta, g) 238 | 239 | (* Scalars *) 240 | 241 | module Scalar = struct 242 | type 'a t = 'a scalar 243 | let meta : type a. a t -> a Meta.t = function 244 | | Unit m -> m | Bool m -> m | Char m -> m | Uchar m -> m | Int m -> m 245 | | Int32 m -> m | Int64 m -> m | Nativeint m -> m | Float m -> m 246 | 247 | let zero : type a. a t -> a = function 248 | | Unit _ -> () | Bool _ -> false | Char _ -> '\x00' 249 | | Uchar _ -> Uchar.of_int 0x0000 | Int _ -> 0 | Int32 _ -> 0l 250 | | Int64 _ -> 0L | Nativeint _ -> 0n | Float _ -> 0.0 251 | 252 | let type_name : type a. a t -> string = function 253 | | Unit _ -> "unit" | Bool _ -> "bool" | Char _ -> "char" 254 | | Uchar _ -> "Uchar.t" | Int _ -> "int" | Int32 _ -> "int32" 255 | | Int64 _ -> "int64" | Nativeint _ -> "nativeint" | Float _ -> "float" 256 | 257 | let equal : type a. a t -> a -> a -> bool = function 258 | | Unit _ -> Unit.equal | Bool _ -> Bool.equal | Char _ -> Char.equal 259 | | Uchar _ -> Uchar.equal | Int _ -> Int.equal 260 | | Int32 _ -> Int32.equal | Int64 _ -> Int64.equal 261 | | Nativeint _ -> Nativeint.equal | Float _ -> Float.equal 262 | 263 | let compare : type a. a t -> a -> a -> int = function 264 | | Unit _ -> Unit.compare | Bool _ -> Bool.compare | Char _ -> Char.compare 265 | | Uchar _ -> Uchar.compare | Int _ -> Int.compare 266 | | Int32 _ -> Int32.compare | Int64 _ -> Int64.compare 267 | | Nativeint _ -> Nativeint.compare | Float _ -> Float.compare 268 | 269 | let char_to_string c = (* TODO should we rather interpret as latin1 ? *) 270 | if Char.code c <= 0x7F then String.make 1 c else 271 | Printf.sprintf "\\x%02x" (Char.code c) 272 | 273 | let uchar_to_string u = 274 | let b = Bytes.create (Uchar.utf_8_byte_length u) in 275 | ignore (Bytes.set_utf_8_uchar b 0 u); 276 | Bytes.unsafe_to_string b 277 | 278 | let to_string : type a. a t -> a -> string = function 279 | | Unit _ -> Unit.to_string | Bool _ -> Bool.to_string 280 | | Char _ -> char_to_string | Uchar _ -> uchar_to_string 281 | | Int _ -> Int.to_string | Int32 _ -> Int32.to_string 282 | | Int64 _ -> Int64.to_string | Nativeint _ -> Nativeint.to_string 283 | | Float _ -> Float.to_string 284 | 285 | let pp : type a. a t -> Format.formatter -> a -> unit = 286 | fun g -> match g with 287 | | Unit _ -> fun ppf _ -> Format.pp_print_string ppf "()" 288 | | Bool _ -> Format.pp_print_bool 289 | | Char _ -> Format.pp_print_char 290 | | Uchar _ -> fun ppf v -> Format.fprintf ppf "@<1>%s" (uchar_to_string v) 291 | | Int _ -> Format.pp_print_int 292 | | Int32 _ -> fun ppf v -> Format.fprintf ppf "%ld" v 293 | | Int64 _ -> fun ppf v -> Format.fprintf ppf "%Ld" v 294 | | Nativeint _ -> fun ppf v -> Format.fprintf ppf "%nd" v 295 | | Float _ -> fun ppf v -> Format.fprintf ppf "%g" v 296 | 297 | let with_meta : type a. a Meta.t -> a t -> a t = fun m s -> match s with 298 | | Unit _ -> Unit m | Bool _ -> Bool m | Char _ -> Char m 299 | | Uchar _ -> Uchar m | Int _ -> Int m | Int32 _ -> Int32 m 300 | | Int64 _ -> Int64 m | Nativeint _ -> Nativeint m | Float _ -> Float m 301 | end 302 | 303 | let unit = Scalar (Unit Meta.empty) 304 | let bool = Scalar (Bool Meta.empty) 305 | let char = Scalar (Char Meta.empty) 306 | let uchar = Scalar (Uchar Meta.empty) 307 | let int = Scalar (Int Meta.empty) 308 | let int32 = Scalar (Int32 Meta.empty) 309 | let int64 = Scalar (Int64 Meta.empty) 310 | let nativeint = Scalar (Nativeint Meta.empty) 311 | let float = Scalar (Float Meta.empty) 312 | 313 | (* Arraylike *) 314 | 315 | module Arraylike = struct 316 | type 'a gist = 'a t 317 | type ('elt, 'arr) t = ('elt, 'arr) arraylike 318 | let meta : type elt arr. (elt, arr) arraylike -> arr Meta.t = function 319 | | String (m, _) -> m | Bytes (m, _) -> m | Array (m, _) -> m 320 | | Bigarray1 (m, _, _, _) -> m | Array_module (m, _, _) -> m 321 | 322 | let type_name : type elt arr. (elt, arr) arraylike -> string = function 323 | | String (_, _) -> "string" | Bytes (_, _) -> "bytes" 324 | | Array (_, _) -> "array" | Bigarray1 (_, _, _, _) -> "bigarray1" 325 | | Array_module (_, (module A), _) -> A.type_name 326 | 327 | let elt : type elt arr. (elt, arr) arraylike -> elt gist = function 328 | | String (_, _) -> char | Bytes (_, _) -> char 329 | | Array (_, elt) -> elt | Bigarray1 (_, _, _, elt) -> elt 330 | | Array_module (_, _, elt) -> elt 331 | 332 | let with_meta : 333 | type elt arr. arr Meta.t -> (elt, arr) arraylike -> 334 | (elt, arr) arraylike 335 | = 336 | fun m a -> match a with 337 | | String (_, e) -> String (m, e) 338 | | Bytes (_, e) -> Bytes (m, e) 339 | | Array (_, elt) -> Array (m, elt) 340 | | Bigarray1 (_, k, l, elt) -> Bigarray1 (m, k, l, elt) 341 | | Array_module (_, a, elt) -> Array_module (m, a, elt) 342 | 343 | (* Generic array modules for the specialisation. *) 344 | 345 | module String_array_module = struct 346 | include String 347 | type t = string 348 | type elt = char 349 | let set s i elt = invalid_arg "Strings are immutable" 350 | let type_name = "string" 351 | end 352 | 353 | module Bytes_array_module = struct 354 | include Bytes 355 | type t = bytes 356 | type elt = char 357 | let type_name = "bytes" 358 | end 359 | 360 | let array_array_module : 361 | type elt. elt gist -> (elt, elt array) array_module 362 | = 363 | fun elt -> 364 | let module Array_module = struct 365 | include Array 366 | type t = elt array 367 | type nonrec elt = elt 368 | let type_name = "array" 369 | end 370 | in 371 | (module Array_module) 372 | 373 | let ba_iter f a = 374 | for i = 0 to Bigarray.Array1.dim a - 1 do 375 | f (Bigarray.Array1.unsafe_get a i) 376 | done 377 | 378 | let ba_fold_left f init a = 379 | let acc = Stdlib.ref init in 380 | for i = 0 to Bigarray.Array1.dim a - 1 do 381 | acc := (f !acc (Bigarray.Array1.unsafe_get a i)) 382 | done; 383 | !acc 384 | 385 | let bigarray1_array_module : 386 | type elt a b. 387 | (elt, a) Bigarray.kind -> b Bigarray.layout -> 388 | elt gist -> (elt, (elt, a, b) Bigarray.Array1.t) array_module 389 | = 390 | fun kind layout elt -> 391 | let module Array_module = struct 392 | type t = (elt, a, b) Bigarray.Array1.t 393 | type nonrec elt = elt 394 | let get = Bigarray.Array1.get 395 | let set = Bigarray.Array1.set 396 | let length = Bigarray.Array1.dim 397 | let init = Bigarray.Array1.init kind layout 398 | let iter = ba_iter 399 | let fold_left = ba_fold_left 400 | let type_name = "array" 401 | end 402 | in 403 | (module Array_module) 404 | 405 | let to_array_module : 406 | type elt arr. (elt, arr) arraylike -> (elt, arr) array_module = 407 | function 408 | | Array_module (_, m, _) -> m 409 | | String (_, _) -> (module String_array_module) 410 | | Bytes (_, _) -> (module Bytes_array_module) 411 | | Array (_, elt) -> array_array_module elt 412 | | Bigarray1 (_, k, l, elt) -> bigarray1_array_module k l elt 413 | end 414 | 415 | let string_as_bytes = Arraylike (String (Meta.empty, `Bytes)) 416 | let string_as_utf_8 = Arraylike (String (Meta.empty, `Utf_8)) 417 | let bytes_as_bytes = Arraylike (Bytes (Meta.empty, `Bytes)) 418 | let bytes_as_utf_8 = Arraylike (Bytes (Meta.empty, `Utf_8)) 419 | let array ?(meta = Meta.empty) g = Arraylike (Array (meta, g)) 420 | let bigarray1 ?(meta = Meta.empty) kind layout g = 421 | Arraylike (Bigarray1 (meta, kind, layout, g)) 422 | 423 | let array_module ?(meta = Meta.empty) m g = 424 | Arraylike (Array_module (meta, m, g)) 425 | 426 | (* Maplike *) 427 | 428 | module Maplike = struct 429 | type 'a gist = 'a t 430 | type ('k, 'v, 'm) t = ('k, 'v, 'm) maplike 431 | let meta : type k v m. (k, v, m) maplike -> m Meta.t = function 432 | | Hashtbl (m, _, _) -> m | Map_module (m, _, _, _) -> m 433 | 434 | let type_name : type k v m. (k, v, m) maplike -> string = function 435 | | Hashtbl (m, _, _) -> "Hashtbl.t" 436 | | Map_module (_, (module M), _, _) -> M.type_name 437 | 438 | let key : type k v m. (k, v, m) maplike -> k gist = function 439 | | Hashtbl (_, k, _) | Map_module (_, _, k, _) -> k 440 | 441 | let value : type k v m. (k, v, m) maplike -> v gist = function 442 | | Hashtbl (_, _, v) | Map_module (_, _, _, v) -> v 443 | 444 | let with_meta : 445 | type k v m. m Meta.t -> (k, v, m) maplike -> (k, v, m) maplike 446 | = 447 | fun m map -> match map with 448 | | Hashtbl (m, k, v) -> Hashtbl (m, k, v) 449 | | Map_module (m, map, k, v) -> Map_module (m, map, k, v) 450 | 451 | module type VALUE = sig 452 | type t 453 | val equal : t -> t -> bool 454 | val compare : t -> t -> int 455 | end 456 | module Map_module_of_map (V : VALUE) (M : Map.S) : MAP 457 | with type t = V.t M.t 458 | and type key = M.key 459 | and type value = V.t = 460 | struct 461 | type t = V.t M.t 462 | type key = M.key 463 | type value = V.t 464 | let empty = M.empty 465 | let mem = M.mem 466 | let add = M.add 467 | let remove = M.remove 468 | let find_opt = M.find_opt 469 | let fold = M.fold 470 | let equal = M.equal V.equal 471 | let compare = M.compare V.compare 472 | let type_name = "Map.t" 473 | end 474 | end 475 | 476 | let hashtbl ?(meta = Meta.empty) k v = Maplike (Hashtbl (meta, k, v)) 477 | let map_module ?(meta = Meta.empty) m k v = 478 | Maplike (Map_module (meta, m, k, v)) 479 | 480 | (* Fields *) 481 | 482 | module Field = struct 483 | type ('t, 'f) t = ('t, 'f) field 484 | let make 485 | ?(meta = Meta.empty) ?(name = "") ?inject ?set ?default gist project 486 | = 487 | { meta; name; gist; project; inject; set; default } 488 | 489 | let meta f = f.meta 490 | let name f = f.name 491 | let gist f = f.gist 492 | let project f = f.project 493 | let inject f = f.inject 494 | let set f = f.set 495 | let default f = f.default 496 | end 497 | 498 | module Fields = struct 499 | type ('p, 'a) t = ('p, 'a) fields 500 | let ctor f = Ctor f 501 | let app f args = App (f, args) 502 | let is_empty = function Ctor _ -> true | _ -> false 503 | let is_singleton = function App (Ctor _, _) -> true | _ -> false 504 | end 505 | 506 | (* Products *) 507 | 508 | module Product = struct 509 | type 'p t = 'p product 510 | let make ?(meta = Meta.empty) ?(name = "") fields = 511 | { meta; name; fields } 512 | let meta (p : 'p t) = p.meta 513 | let name (p : 'p t) = p.name 514 | let fields (p : 'p t) = p.fields 515 | let is_empty (p : 'v t) = Fields.is_empty p.fields 516 | let is_singleton (p : 'v t) = Fields.is_singleton p.fields 517 | let with_meta meta (p : 'v t) = { p with meta } 518 | let rec_field_count (c : 'v t) = 519 | let rec loop : type p a. int -> (p, a) fields -> int = 520 | fun acc fs -> match fs with 521 | | Ctor _ -> acc 522 | | App (c, f) -> loop (acc + match f.gist with Rec _ -> 1 | _ -> 0) c 523 | in 524 | loop 0 c.fields 525 | 526 | type ('p, 'ctor) cons = 527 | { meta : 'p Meta.t; type_name : string; fields : ('p, 'ctor) fields } 528 | 529 | let cons ?(meta = Meta.empty) ?(type_name = "") ctor = 530 | { meta; type_name; fields = Ctor ctor } 531 | 532 | let finish cons = make ~meta:cons.meta ~name:cons.type_name cons.fields 533 | end 534 | 535 | let field' f (p : ('p, 'ctor) Product.cons) = 536 | { p with Product.fields = App (p.fields, f) } 537 | 538 | let field ?meta ?inject ?set ?default name gist project p = 539 | field' (Field.make ?meta ?inject ?set ?default ~name gist project) p 540 | 541 | let dim ?meta ?inject ?default gist project p = 542 | field' (Field.make ?meta ?inject ?default gist project) p 543 | 544 | let product ?meta ?type_name ctor = Product.cons ?meta ?type_name ctor 545 | let finish_product p = Product (Product.finish p) 546 | 547 | let p2 ?meta ?type_name g0 g1 = 548 | product ?meta ?type_name (fun v0 v1 -> v0, v1) 549 | |> dim g0 fst 550 | |> dim g1 snd 551 | |> finish_product 552 | 553 | let p3 ?meta ?type_name g0 g1 g2 = 554 | product ?meta ?type_name (fun v0 v1 v2 -> v0, v1, v2) 555 | |> dim g0 (fun (v, _, _) -> v) 556 | |> dim g1 (fun (_, v, _) -> v) 557 | |> dim g2 (fun (_, _, v) -> v) 558 | |> finish_product 559 | 560 | let p4 ?meta ?type_name g0 g1 g2 g3 = 561 | product ?meta ?type_name (fun v0 v1 v2 v3 -> v0, v1, v2, v3) 562 | |> dim g0 (fun (v, _, _, _) -> v) 563 | |> dim g1 (fun (_, v, _, _) -> v) 564 | |> dim g2 (fun (_, _, v, _) -> v) 565 | |> dim g3 (fun (_, _, _, v) -> v) 566 | |> finish_product 567 | 568 | (* Records *) 569 | 570 | let record ?meta type_name ctor = Product.cons ?meta ~type_name ctor 571 | let finish_record r = Record (Product.finish r) 572 | 573 | (* Variants *) 574 | 575 | module Variant = struct 576 | type 'v case = 'v product 577 | let case ?meta name ctor = Product.cons ?meta ~type_name:name ctor 578 | let finish_case = Product.finish 579 | 580 | type 'v t = 'v variant 581 | 582 | let make ?(meta = Meta.empty) type_name project cases = 583 | { meta; type_name; project; cases } 584 | 585 | let meta (v : 'v t) = v.meta 586 | let type_name (v : 'v t) = v.type_name 587 | let project (v : 'v t) = v.project 588 | let cases (v : 'v t) = v.cases 589 | let case_count (v : 'v t) = List.length v.cases 590 | let get (v : 'v t) i = List.nth v.cases i 591 | 592 | (* Generalizes the specific cases of sum to variant descriptions. 593 | TODO add the parameter names in the resulting type names ? *) 594 | 595 | let none_case = { meta = Meta.empty; name = "None"; fields = Ctor None } 596 | let of_option ?meta a = 597 | let some_ctor v = Some v in 598 | let some_proj = function Some v -> v | _ -> assert false in 599 | let some_case = 600 | case "Some" some_ctor |> dim a some_proj |> finish_case 601 | in 602 | let option_proj = function None -> none_case | Some _ -> some_case in 603 | make ?meta "option" option_proj [none_case; some_case] 604 | 605 | let of_either ?meta l r = 606 | let left_ctor v = Either.Left v in 607 | let left_proj = function Either.Left v -> v | _ -> assert false in 608 | let left_case = 609 | case "Either.Left" left_ctor |> dim l left_proj |> finish_case 610 | in 611 | let right_ctor v = Either.Right v in 612 | let right_proj = function Either.Right v -> v | _ -> assert false in 613 | let right_case = 614 | case "Either.Right" right_ctor |> dim r right_proj |> finish_case 615 | in 616 | let either_proj = function 617 | | Either.Left _ -> left_case | Right _ -> right_case 618 | in 619 | make ?meta "Either.t" either_proj [left_case; right_case] 620 | 621 | let of_result ?meta a b = 622 | let ok_ctor v = Ok v in 623 | let ok_proj = function Ok v -> v | _ -> assert false in 624 | let ok_case = case "Ok" ok_ctor |> dim a ok_proj |> finish_case in 625 | let error_ctor e = Error e in 626 | let error_proj = function Error v -> v | _ -> assert false in 627 | let error_case = 628 | case "Error" error_ctor |> dim b error_proj |> finish_case 629 | in 630 | let result_proj = function Ok _ -> ok_case | Error _ -> error_case in 631 | make ?meta "result" result_proj [ok_case; error_case] 632 | 633 | let empty_case = { meta = Meta.empty; name = "[]"; fields = Ctor [] } 634 | let of_list = fun ?meta a -> 635 | let rec g = lazy begin 636 | let cons_ctor x xs = x :: xs in 637 | let cons_head = function x :: _ -> x | _ -> assert false in 638 | let cons_tail = function _ :: xs -> xs | _ -> assert false in 639 | let cons_hdim = dim a cons_head in 640 | let self = Rec (lazy (Sum (Variant (Lazy.force g)))) in 641 | let cons_tdim = dim self cons_tail in 642 | let cons_case = 643 | case "::" cons_ctor |> cons_hdim |> cons_tdim |> finish_case 644 | in 645 | let list_proj = function [] -> empty_case | _ -> cons_case in 646 | make ?meta "list" list_proj [empty_case; cons_case] 647 | end 648 | in 649 | Lazy.force g 650 | end 651 | 652 | let case = Variant.case 653 | let case0 ?(meta = Meta.empty) name v = { meta; name; fields = Ctor v } 654 | let finish_case = Variant.finish_case 655 | let variant ?(meta = Meta.empty) type_name project cases = 656 | Sum (Variant { meta; type_name; project; cases }) 657 | 658 | (* Sums *) 659 | 660 | module Sum = struct 661 | type 's t = 's sum 662 | 663 | let meta : type s. s sum -> s Meta.t = function 664 | | Option (m, _) -> m 665 | | Either (m, _, _) -> m 666 | | Result (m, _, _) -> m 667 | | List (m, _) -> m 668 | | Variant v -> Variant.meta v 669 | 670 | let type_name : type s. s sum -> string = function 671 | | Option (_, _) -> "option" | Either (_, _, _) -> "Either.t" 672 | | Result (_, _, _) -> "result" | List (_, _) -> "list" 673 | | Variant v -> Variant.type_name v 674 | 675 | let to_variant : type s. s sum -> s variant = function 676 | | Option (meta, a) -> Variant.of_option ~meta a 677 | | Either (meta, l, r) -> Variant.of_either ~meta l r 678 | | Result (meta, a, b) -> Variant.of_result ~meta a b 679 | | List (meta, a) -> Variant.of_list ~meta a 680 | | Variant v -> v 681 | 682 | let with_meta : type s. s Meta.t -> s sum -> s sum = fun meta s -> 683 | match s with 684 | | Option (_, v) -> Option (meta, v) 685 | | Either (_, l, r) -> Either (meta, l, r) 686 | | Result (_, a, b) -> Result (meta, a, b) 687 | | List (_, a) -> List (meta, a) 688 | | Variant v -> Variant { v with meta } 689 | end 690 | 691 | let option ?(meta = Meta.empty) v = Sum (Option (meta, v)) 692 | let either ?(meta = Meta.empty) l r = Sum (Either (meta, l, r)) 693 | let result ?(meta = Meta.empty) v e = Sum (Result (meta, v, e)) 694 | let list ?(meta = Meta.empty) v = Sum (List (meta, v)) 695 | 696 | (* Functions *) 697 | 698 | module Func = struct 699 | type ('a, 'b) t = ('a, 'b) func 700 | let make ?(meta = Meta.empty) domain range = { meta; domain; range } 701 | let meta (f : ('a, 'b) t) = f.meta 702 | let domain f = f.domain 703 | let range f = f.range 704 | let with_meta meta (f : ('a, 'b) t) = { f with meta } 705 | end 706 | 707 | let func ?meta d r = Func (Func.make ?meta d r) 708 | let ( @-> ) d r = func d r 709 | 710 | (* Abstract *) 711 | 712 | module Abstract = struct 713 | module Repr = struct 714 | type ('a, 'repr) t = ('a, 'repr) abstract_repr 715 | let make ?(meta = Meta.empty) ~version gist inject project = 716 | { meta; version; gist; inject; project } 717 | 718 | let meta (r : ('a, 'repr) t) = r.meta 719 | let version r = r.version 720 | let gist (r : ('a, 'repr) t) = r.gist 721 | let inject (r : ('a, 'repr) t) = r.inject 722 | let project (r : ('a, 'repr) t) = r.project 723 | let with_meta meta (r : ('a, 'repr) t) = { r with meta} 724 | end 725 | 726 | type 'a repr = 'a abstract_repr_exists = 727 | | Repr : ('a, 'repr) Repr.t -> 'a repr 728 | 729 | let repr ?meta ~version gist inject project = 730 | Repr (Repr.make ?meta ~version gist inject project) 731 | 732 | type 'a t = 'a abstract 733 | let make ?(meta = Meta.empty) type_name ~reprs = 734 | { meta; type_name; reprs } 735 | 736 | let meta (a : 'a t) = a.meta 737 | let type_name (a : 'a t) = a.type_name 738 | let reprs (a : 'a t) = a.reprs 739 | let with_meta meta (a : 'a t) = { a with meta } 740 | end 741 | 742 | let abstract ?meta name reprs = Abstract (Abstract.make ?meta name ~reprs) 743 | 744 | (* Gists *) 745 | 746 | let rec meta : type a. a t -> a Meta.t = function 747 | | Scalar s -> Scalar.meta s | Arraylike a -> Arraylike.meta a 748 | | Maplike m -> Maplike.meta m | Product p -> Product.meta p 749 | | Record r -> Product.meta r | Sum s -> Sum.meta s | Func f -> Func.meta f 750 | | Abstract a -> Abstract.meta a 751 | | Lazy (m, l) -> m | Ref (m, r) -> m 752 | | Rec r -> meta (Lazy.force r) 753 | 754 | let rec with_meta : type a. a Meta.t -> a t -> a t = fun m g -> match g with 755 | | Scalar s -> Scalar (Scalar.with_meta m s) 756 | | Arraylike a -> Arraylike (Arraylike.with_meta m a) 757 | | Maplike map -> Maplike (Maplike.with_meta m map) 758 | | Product p -> Product (Product.with_meta m p) 759 | | Record r -> Record (Product.with_meta m r) 760 | | Sum s -> Sum (Sum.with_meta m s) 761 | | Func f -> Func (Func.with_meta m f) 762 | | Abstract a -> Abstract (Abstract.with_meta m a) 763 | | Lazy (_, l) -> Lazy (m, l) | Ref (m, r) -> Ref (m, r) 764 | | Rec r -> with_meta m (Lazy.force r) 765 | 766 | let rec type_name : type a. a t -> string = function 767 | | Scalar s -> Scalar.type_name s | Arraylike a -> Arraylike.type_name a 768 | | Maplike m -> Maplike.type_name m 769 | | Product p -> Product.name p 770 | | Record r -> Product.name r 771 | | Sum s -> Sum.type_name s 772 | | Func f -> "" (* XXX fixme *) 773 | | Abstract a -> Abstract.type_name a 774 | | Lazy (_, l) -> type_name l ^ "_lazy" | Ref (m, r) -> type_name r ^ "_ref" 775 | | Rec r -> type_name (Lazy.force r) 776 | 777 | type 'a fmt = Format.formatter -> 'a -> unit 778 | let pf = Format.fprintf 779 | let pp_string = Format.pp_print_string 780 | let pp_type ppf g = 781 | (* FIXME The ref naming scheme should likely be improved and spelled 782 | out in the docs. *) 783 | let rec arraylike : type a elt. ref:bool -> (a, elt) arraylike fmt = 784 | fun ~ref ppf -> function 785 | | String (_, _) -> pp_string ppf "string" 786 | | Bytes (_, _) -> pp_string ppf "bytes" 787 | | Array (_, elt) -> pf ppf "@[@[%a@] array@]" (pp ~ref:true) elt 788 | | Bigarray1 (_, _, _, elt) -> 789 | pf ppf "@[@[%a@] Bigarray.Array1.t@]" (pp ~ref:true) elt 790 | | Array_module (_, (module A), elt) -> 791 | pf ppf "@[@[%a@] %s@]" (pp ~ref:true) elt A.type_name 792 | 793 | and maplike : type m k v. ref:bool -> (m, k, v) maplike fmt = 794 | fun ~ref ppf -> function 795 | | Hashtbl (m, k, v) -> 796 | let pp_k = pp ~ref:true and pp_v = pp ~ref:true in 797 | pf ppf "@[@[<1>(%a,@ %a)@] Hasthbl.t@]" pp_k k pp_v v 798 | | Map_module (_, (module M), k, v) -> 799 | let pp_k = pp ~ref:true and pp_v = pp ~ref:true in 800 | pf ppf "@[@[<1>(%a,@ %a)@] %s@]" pp_k k pp_v v M.type_name 801 | 802 | and product : type p. ref:bool -> paren:bool -> p product fmt = 803 | fun ~ref ~paren ppf p -> 804 | let field ppf f = pf ppf "@[%a@]" (pp ~ref:true) (Field.gist f) in 805 | let rec fields : type p a. (p, a) fields fmt = fun ppf fs -> 806 | match fs with 807 | | Ctor _ -> () | App (Ctor _, f) -> field ppf f 808 | | App (fs, f) -> fields ppf fs; pf ppf " *@ %a" field f 809 | in 810 | if ref && Product.name p <> "" then pf ppf "%s" (Product.name p) else 811 | if paren 812 | then pf ppf "@[<1>(%a)@]" fields (Product.fields p) 813 | else pf ppf "@[<1>%a@]" fields (Product.fields p) 814 | 815 | and record : type r. ref:bool -> r record fmt = fun ~ref ppf r -> 816 | let field ppf f = 817 | pf ppf "@[%s :@ %a@]" (Field.name f) (pp ~ref:true) (Field.gist f) 818 | in 819 | let rec fields : type p a. (p, a) fields fmt = fun ppf fs -> 820 | match fs with 821 | | Ctor _ -> () | App (Ctor _, f) -> field ppf f 822 | | App (fs, f) -> fields ppf fs; pf ppf ";@,%a" field f 823 | in 824 | if ref && Product.name r <> "" then pf ppf "%s" (Product.name r) else 825 | pf ppf "@[{ %a@] }" fields (Product.fields r) 826 | 827 | and sum : type a. ref:bool -> a sum fmt = fun ~ref ppf s -> match s with 828 | | Option (m, a) -> pf ppf "%a option" (pp ~ref:true) a 829 | | Either (m, a, b) -> 830 | let pp_a = pp ~ref:true and pp_b = pp ~ref:true in 831 | pf ppf "@[@[<1>(%a,@ %a)@] Either.t@]" pp_a a pp_b b 832 | | Result (m, a, b) -> 833 | let pp_a = pp ~ref:true and pp_b = pp ~ref:true in 834 | pf ppf "@[@[<1>(%a,@ %a)@] result@]" pp_a a pp_b b 835 | | List (m, a) -> 836 | pf ppf "%a list" (pp ~ref:true) a 837 | | Variant v -> 838 | if ref && Variant.type_name v <> "" 839 | then pf ppf "%s" (Variant.type_name v) else 840 | let pp_case ppf c = match Product.is_empty c with 841 | | true -> pf ppf "@[<2>| %s@]" (Product.name c) 842 | | false -> 843 | let pp_prod = product ~ref:false ~paren:false in 844 | pf ppf "@[<2>| %s of %a@]" (Product.name c) pp_prod c 845 | in 846 | pf ppf "@[%a@]" (Format.pp_print_list pp_case) (Variant.cases v) 847 | 848 | and func : type a b. ref:bool -> (a, b) func fmt = fun ~ref ppf f -> 849 | let d = Func.domain f and r = Func.range f in 850 | pf ppf "@[%a ->@ %a@]" (pp ~ref:true) d (pp ~ref:true) r 851 | 852 | and pp : type a. ref:bool -> a t fmt = fun ~ref ppf g -> match g with 853 | | Scalar s -> Format.pp_print_string ppf (Scalar.type_name s) 854 | | Arraylike a -> arraylike ~ref ppf a 855 | | Maplike m -> maplike ~ref ppf m 856 | | Product p -> product ~ref ~paren:true ppf p 857 | | Record r -> record ~ref ppf r 858 | | Sum s -> sum ~ref ppf s 859 | | Func f -> func ~ref ppf f 860 | | Abstract a -> pp_string ppf (Abstract.type_name a) 861 | | Lazy (_, l) -> pf ppf "@[@[%a@] lazy_t@]" (pp ~ref:true) l 862 | | Ref (_, r) -> pf ppf "@[@[%a@] ref@]" (pp ~ref:true) r 863 | | Rec r -> pp ppf ~ref:true (Lazy.force r) 864 | in 865 | pp ~ref:false ppf g 866 | end 867 | end 868 | 869 | module Fun = struct 870 | include Stdlib.Fun 871 | 872 | module Generic = struct 873 | module Meta = struct 874 | module Fmt = struct 875 | module V = struct type 'a t = Format.formatter -> 'a -> unit end 876 | include V 877 | let ignore _ _ = () 878 | include (Type.Gist.Meta.Key (V) : Type.Gist.Meta.KEY (* no mli ! *) 879 | with type 'a value = 'a t) 880 | end 881 | module Equal = struct 882 | module V = struct type 'a t = 'a -> 'a -> bool end 883 | include V 884 | let ignore _ _ = true 885 | include (Type.Gist.Meta.Key (V) : Type.Gist.Meta.KEY (* no mli ! *) 886 | with type 'a value = 'a t) 887 | end 888 | module Compare = struct 889 | module V = struct type 'a t = 'a -> 'a -> int end 890 | include V 891 | let ignore _ _ = 0 892 | include (Type.Gist.Meta.Key (V) : Type.Gist.Meta.KEY (* no mli ! *) 893 | with type 'a value = 'a t) 894 | end 895 | 896 | module Random = struct 897 | module Gen = struct 898 | module V = struct 899 | type 'a t = size:int -> Random.State.t -> bound:int -> 'a 900 | end 901 | include V 902 | let const v = fun ~size:_ _ ~bound:_ -> v 903 | include (Type.Gist.Meta.Key (V) : Type.Gist.Meta.KEY (* no mli ! *) 904 | with type 'a value = 'a t) 905 | end 906 | module Size = struct 907 | module V = struct type 'a t = int end 908 | include V 909 | include (Type.Gist.Meta.Key (V) : Type.Gist.Meta.KEY (* no mli ! *) 910 | with type 'a value = 'a t) 911 | end 912 | end 913 | end 914 | 915 | module Gfmt = struct 916 | type 'a fmt = Format.formatter -> 'a -> unit 917 | let pf = Format.fprintf 918 | let pp_string = Format.pp_print_string 919 | let pp_list = Format.pp_print_list 920 | let pp_comma ppf () = pf ppf ",@ " 921 | let pp_semi ppf () = pf ppf ";@ " 922 | let pp_semi_cut ppf () = pf ppf ";@," 923 | let pp_iter ?(pp_sep = Format.pp_print_cut) iter pp_v ppf v = 924 | let is_first = ref true in 925 | let pp_v v = 926 | (if !is_first then is_first := false else pp_sep ppf ()); pp_v ppf v 927 | in 928 | iter pp_v v 929 | 930 | let pp_text ppf s = pf ppf "%S" (* FIXME use the B0_std.Fmt stuff *) 931 | let pp_hex ppf s = 932 | let pp_sep ppf () = () in 933 | let pp_v ppf c = pf ppf "\\x%02x" (Char.code c) in 934 | Format.pp_print_char ppf '\"'; 935 | pp_iter ~pp_sep String.iter pp_v ppf s; 936 | Format.pp_print_char ppf '\"' 937 | 938 | let pp_array ~kind iter pp_elt ppf a = 939 | pf ppf "@[<2>[%s|%a|]@]" kind (pp_iter iter ~pp_sep:pp_semi pp_elt) a 940 | 941 | let pp_map ~kind iter pp_k pp_v ppf m = 942 | let is_first = ref true in 943 | let pp_binding ppf k v = 944 | (if !is_first then is_first := false else pp_semi ppf ()); 945 | pf ppf "@[@[%a@] @<1>%s@ @[%a@]@]" pp_k k "\u{2192}" pp_v v 946 | in 947 | let pp_map ppf m = iter (pp_binding ppf) m in 948 | pf ppf "@[<2><%s: %a>@]" kind pp_map m 949 | 950 | let rec pp_arraylike : type elt a. (elt, a) Type.Gist.arraylike -> a fmt = 951 | fun a ppf v -> match a with 952 | | Bytes (_, `Utf_8) -> pf ppf "%S" (Bytes.unsafe_to_string v) 953 | | Bytes (_, `Bytes) -> pp_hex ppf (Bytes.unsafe_to_string v) 954 | | String (_,`Utf_8) -> pf ppf "%S" v 955 | | String (_, `Bytes) -> pp_hex ppf v 956 | | Array (_, g) -> pp_array ~kind:"" Array.iter (pp g) ppf v 957 | | Bigarray1 (_, _, _, g) -> 958 | pp_array ~kind:"ba" Type.Gist.Arraylike.ba_iter (pp g) ppf v 959 | | Array_module (_, (module A), g) -> 960 | pp_array ~kind:A.type_name A.iter (pp g) ppf v 961 | 962 | and pp_maplike : type k v m. (k, v, m) Type.Gist.maplike -> m fmt = 963 | fun m ppf v -> match m with 964 | | Hashtbl (_, gk, gv) -> 965 | pp_map ~kind:"Hashtbl.t" Hashtbl.iter (pp gk) (pp gv) ppf v 966 | | Map_module (_, (module M), gk, gv) -> 967 | let iter f m = M.fold (fun k v () -> f k v) m () in 968 | pp_map ~kind:M.type_name iter (pp gk) (pp gv) ppf v 969 | 970 | and pp_product : type p. p Type.Gist.product -> p fmt = fun p ppf v -> 971 | let pp_dim ~sep dim ppf p = 972 | match Type.Gist.Meta.Ignore.find (Type.Gist.Field.meta dim) with 973 | | Some true -> () (* avoid sep *) 974 | | Some false | None -> 975 | let g = Type.Gist.Field.gist dim in 976 | let v = Type.Gist.Field.project dim p in 977 | (if sep then pp_comma ppf ()); pp g ppf v 978 | in 979 | let rec pp_dims : type p a. (p, a) Type.Gist.fields -> p fmt = 980 | fun dims ppf v -> match dims with 981 | | Ctor _ -> () 982 | | App (Ctor _, dim) -> pp_dim ~sep:false dim ppf v 983 | | App (dims, dim) -> pp_dims dims ppf v; pp_dim ~sep:true dim ppf v 984 | in 985 | match Type.Gist.Product.fields p with 986 | | Ctor _ -> () 987 | | App (Ctor _, dim) -> pp_dim ~sep:false dim ppf v 988 | | _ -> pf ppf "@[<1>(%a)@]" (pp_dims (Type.Gist.Product.fields p)) v 989 | 990 | and pp_record : type r a. r Type.Gist.record -> r fmt = fun r ppf v -> 991 | let pp_field ~sep f ppf v = 992 | match Type.Gist.Meta.Ignore.find (Type.Gist.Field.meta f) with 993 | | Some true -> () (* avoid sep *) 994 | | Some false | None -> 995 | let g = Type.Gist.Field.gist f in 996 | let v = Type.Gist.Field.project f v in 997 | (if sep then pp_semi_cut ppf ()); 998 | pf ppf "@[%s =@ @[%a@]@]" (Type.Gist.Field.name f) (pp g) v 999 | in 1000 | let rec pp_fields : type p a. (p, a) Type.Gist.fields -> p fmt = 1001 | fun fs ppf v -> match fs with 1002 | | Ctor _ -> () 1003 | | App (Ctor _, f) -> pp_field ~sep:false f ppf v 1004 | | App (fs, f) -> pp_fields fs ppf v; pp_field ~sep:true f ppf v 1005 | in 1006 | pf ppf "@[{ %a@] }" (pp_fields (Type.Gist.Product.fields r)) v 1007 | 1008 | and pp_abstract : type a. a Type.Gist.abstract -> a fmt = fun a ppf v -> 1009 | match Type.Gist.Abstract.reprs a with 1010 | | [] -> pf ppf "" 1011 | | (Repr r) :: _ -> 1012 | let v = Type.Gist.Abstract.Repr.inject r v in 1013 | let g = Type.Gist.Abstract.Repr.gist r in 1014 | pf ppf "@[<1>@]" (pp g) v 1015 | 1016 | and pp_sum : type a. a Type.Gist.sum -> a fmt = 1017 | fun s ppf v -> match s with 1018 | | List (_, a) -> pf ppf "@[<1>[%a]@]" (pp_list ~pp_sep:pp_semi (pp a)) v 1019 | | sum -> 1020 | let variant = Type.Gist.Sum.to_variant sum in 1021 | let case = Type.Gist.Variant.project variant v in 1022 | let name = Type.Gist.Product.name case in 1023 | if Type.Gist.Product.is_empty case 1024 | then pp_string ppf name 1025 | else pf ppf "%s %a" name (pp_product case) v 1026 | 1027 | and pp_func : type a b. (a -> b) Type.Gist.t fmt = fun ppf g -> 1028 | pf ppf "" Type.Gist.pp_type g 1029 | 1030 | and pp : type a. a Type.Gist.t -> a fmt = fun g ppf v -> 1031 | (* N.B. Shifting the lookup in each case could be more efficient. *) 1032 | match Meta.Fmt.find (Type.Gist.meta g) with 1033 | | Some pp -> pp ppf v 1034 | | None -> 1035 | match g with 1036 | | Scalar s -> Type.Gist.Scalar.pp s ppf v 1037 | | Arraylike a -> pp_arraylike a ppf v 1038 | | Maplike m -> pp_maplike m ppf v 1039 | | Product p -> pp_product p ppf v 1040 | | Record r -> pp_record r ppf v 1041 | | Sum s -> pp_sum s ppf v 1042 | | Func _ as g -> pp_func ppf g 1043 | | Abstract a -> pp_abstract a ppf v 1044 | | Lazy (_, g) -> pp g ppf (Lazy.force v) 1045 | | Ref (_, g) -> pp g ppf (!v) 1046 | | Rec g -> pp (Lazy.force g) ppf v 1047 | end 1048 | 1049 | module Gequal = struct 1050 | type 'a eq = 'a -> 'a -> bool 1051 | 1052 | let invalid_arg fmt = 1053 | Format.ksprintf invalid_arg ("Fun.Generic.equal: " ^^ fmt) 1054 | 1055 | let equal_hashtbl eq_v h0 h1 = (* Stdlib could have something… *) 1056 | if Hashtbl.length h0 <> Hashtbl.length h1 then false else 1057 | let rec loop = function 1058 | | Seq.Nil -> true 1059 | | Seq.Cons (k, keys) -> 1060 | let l0 = Hashtbl.find_all h0 k in 1061 | let l1 = Hashtbl.find_all h1 k in 1062 | if List.equal eq_v l0 l1 then loop (keys ()) else false 1063 | in 1064 | loop ((Hashtbl.to_seq_keys h0) ()) 1065 | 1066 | let rec equal_arraylike : 1067 | type elt arr. (elt, arr) Type.Gist.arraylike -> arr eq = fun a v0 v1 -> 1068 | match a with 1069 | | String (_, _) -> String.equal v0 v1 1070 | | Bytes (_, _) -> Bytes.equal v0 v1 1071 | | a -> 1072 | (* FIXME there's room for improvement and clarifications 1073 | here, e.g. for using the bare bigarrays comparison *) 1074 | let (module A) = Type.Gist.Arraylike.to_array_module a in 1075 | let elt = Type.Gist.Arraylike.elt a in 1076 | let eq = equal elt in 1077 | let v0_len = A.length v0 in 1078 | let v1_len = A.length v1 in 1079 | if v0_len <> v1_len then false else 1080 | try 1081 | for i = 0 to v0_len - 1 do 1082 | if eq (A.get v0 i) (A.get v1 i) then () else raise_notrace Exit 1083 | done; 1084 | true 1085 | with Exit -> false 1086 | 1087 | and equal_maplike : 1088 | type k v m. (k, v, m) Type.Gist.maplike -> m eq = fun m v0 v1 -> 1089 | match m with 1090 | | Hashtbl (_, k, v) -> equal_hashtbl (equal v) v0 v1 1091 | | Map_module (_, (module M), k, v) -> M.equal v0 v1 1092 | 1093 | and equal_product : type p. p Type.Gist.product -> p eq = fun p v0 v1 -> 1094 | let rec loop : type p a. (p, a) Type.Gist.fields -> p eq = 1095 | fun fs v0 v1 -> match fs with 1096 | | Ctor _ -> true 1097 | | App (fs, f) -> 1098 | loop fs v0 v1 && 1099 | let v0 = Type.Gist.Field.project f v0 in 1100 | let v1 = Type.Gist.Field.project f v1 in 1101 | equal (Type.Gist.Field.gist f) v0 v1 1102 | (* TODO I think it makes sense to comment this but review 1103 | match Meta.Equal.find (Type.Gist.Field.meta f) with 1104 | | None -> 1105 | | Some equal -> equal v0 v1 1106 | *) 1107 | in 1108 | loop (Type.Gist.Product.fields p) v0 v1 1109 | 1110 | and equal_sum : type s. s Type.Gist.sum -> s eq = fun s v0 v1 -> 1111 | match s with 1112 | | Option (_, a) -> Option.equal (equal a) v0 v1 1113 | | Either (_,l,r) -> Either.equal ~left:(equal l) ~right:(equal r) v0 v1 1114 | | Result (_, o, e) -> Result.equal ~ok:(equal o) ~error:(equal e) v0 v1 1115 | | List (_, a) -> List.equal (equal a) v0 v1 1116 | | Variant v -> 1117 | let v0_case = Type.Gist.Variant.project v v0 in 1118 | let v1_case = Type.Gist.Variant.project v v1 in 1119 | if v0_case != v1_case then false else 1120 | equal_product v0_case v0 v1 1121 | 1122 | and equal_func : type d r. (d, r) Type.Gist.func -> (d -> r) eq = 1123 | fun f _ _ -> invalid_arg "functional value" 1124 | 1125 | and equal_abstract : type a. a Type.Gist.abstract -> a eq = fun a v0 v1 -> 1126 | match Type.Gist.Abstract.reprs a with 1127 | | [] -> 1128 | let n = Type.Gist.Abstract.type_name a in 1129 | invalid_arg "%s: abstract type exposes no representation" n 1130 | | (Repr r) :: _ -> 1131 | let v0 = Type.Gist.Abstract.Repr.inject r v0 in 1132 | let v1 = Type.Gist.Abstract.Repr.inject r v1 in 1133 | let g = Type.Gist.Abstract.Repr.gist r in 1134 | equal g v0 v1 1135 | 1136 | and equal : type a. a Type.Gist.t -> a eq = fun g v0 v1 -> 1137 | (* N.B. Shifting the lookup in each case could be more efficient. *) 1138 | match Meta.Equal.find (Type.Gist.meta g) with 1139 | | Some eq -> eq v0 v1 1140 | | None -> 1141 | match g with 1142 | | Scalar s -> Type.Gist.Scalar.equal s v0 v1 1143 | | Arraylike a -> equal_arraylike a v0 v1 1144 | | Maplike m -> equal_maplike m v0 v1 1145 | | Product p -> equal_product p v0 v1 1146 | | Record r -> equal_product r v0 v1 1147 | | Sum s -> equal_sum s v0 v1 1148 | | Func f -> equal_func f v0 v1 1149 | | Abstract a -> equal_abstract a v0 v1 1150 | | Lazy (_, g) -> equal g (Lazy.force v0) (Lazy.force v1) 1151 | | Ref (_, g) -> equal g !v0 !v1 1152 | | Rec g -> equal (Lazy.force g) v0 v1 1153 | end 1154 | 1155 | module Gcompare = struct 1156 | type 'a cmp = 'a -> 'a -> int 1157 | 1158 | let invalid_arg fmt = 1159 | Format.ksprintf invalid_arg ("Fun.Generic.compare: " ^^ fmt) 1160 | 1161 | let compare_hashtbl cmp_k cmp_v h0 h1 = 1162 | (* Stdlib could have something… This is not so great but the 1163 | API gives no ordering guarantees (likely because of the 1164 | hash randomization) Also it's highly unclear what users 1165 | expect from a notion of equality on hashtables. *) 1166 | let bcmp (k0, _) (k1, _) = cmp_k k0 k1 in (* we keep insert order *) 1167 | let kv0 = List.stable_sort bcmp (List.of_seq (Hashtbl.to_seq h0)) in 1168 | let kv1 = List.stable_sort bcmp (List.of_seq (Hashtbl.to_seq h1)) in 1169 | let cmp_kv (k0, v0) (k1, v1) = 1170 | let cmp = cmp_k k0 k1 in if cmp <> 0 then cmp else cmp_v v0 v1 1171 | in 1172 | List.compare cmp_kv kv0 kv1 1173 | 1174 | let rec compare_arraylike : 1175 | type elt arr. (elt, arr) Type.Gist.arraylike -> arr cmp = fun a v0 v1 -> 1176 | match a with 1177 | | String (_, _) -> String.compare v0 v1 1178 | | Bytes (_, _) -> Bytes.compare v0 v1 1179 | | a -> 1180 | (* FIXME there's room for improvement and clarifications 1181 | here, e.g. for using the bare bigarrays comparison *) 1182 | let (module A) = Type.Gist.Arraylike.to_array_module a in 1183 | let max = Int.min (A.length v0) (A.length v1) - 1 in 1184 | let rec loop compare i max v0 v1 = 1185 | if i > max then Int.compare (A.length v0) (A.length v1) else 1186 | let cmp = compare (A.get v0 i) (A.get v1 i) in 1187 | if cmp <> 0 then cmp else loop compare (i + 1) max v0 v1 1188 | in 1189 | loop (compare (Type.Gist.Arraylike.elt a)) 0 max v0 v1 1190 | 1191 | and compare_maplike : 1192 | type k v m. (k, v, m) Type.Gist.maplike -> m cmp = fun m v0 v1 -> 1193 | match m with 1194 | | Hashtbl (_, k, v) -> compare_hashtbl (compare k) (compare v) v0 v1 1195 | | Map_module (_, (module M), k, v) -> M.compare v0 v1 1196 | 1197 | and compare_product : type p. p Type.Gist.product -> p cmp = 1198 | fun p v0 v1 -> 1199 | let rec loop : type p a. (p, a) Type.Gist.fields -> p cmp = 1200 | fun fs v0 v1 -> match fs with 1201 | | Ctor _ -> 0 1202 | | App (fs, f) -> 1203 | let cmp = loop fs v0 v1 in 1204 | if cmp <> 0 then cmp else 1205 | let v0 = Type.Gist.Field.project f v0 in 1206 | let v1 = Type.Gist.Field.project f v1 in 1207 | compare (Type.Gist.Field.gist f) v0 v1 1208 | (* TODO 1209 | match Meta.Compare.find (Type.Gist.Field.meta f) with 1210 | | None -> 1211 | | Some compare -> compare v0 v1 *) 1212 | in 1213 | loop (Type.Gist.Product.fields p) v0 v1 1214 | 1215 | and compare_sum : type s. s Type.Gist.sum -> s cmp = fun s v0 v1 -> 1216 | match s with 1217 | | Option (_, a) -> 1218 | Option.compare (compare a) v0 v1 1219 | | Either (_,l,r) -> 1220 | Either.compare ~left:(compare l) ~right:(compare r) v0 v1 1221 | | Result (_, o, e) -> 1222 | Result.compare ~ok:(compare o) ~error:(compare e) v0 v1 1223 | | List (_, a) -> 1224 | List.compare (compare a) v0 v1 1225 | | Variant v -> 1226 | let v0_case = Type.Gist.Variant.project v v0 in 1227 | let v1_case = Type.Gist.Variant.project v v1 in 1228 | if v0_case == v1_case then compare_product v0_case v0 v1 else 1229 | (* FIXME maybe we need a better representation of variants here 1230 | or at least a better internal data structure which associates 1231 | a tag with each variant. Can also be useful for binary codecs. *) 1232 | let rec loop v0c v1c = function 1233 | | [] -> 1234 | let n = Type.Gist.Variant.type_name v in 1235 | invalid_arg "%s: inconsistent variant definition" n 1236 | | c :: cs -> 1237 | if c == v0c then -1 else 1238 | if c == v1c then 1 else loop v0c v1c cs 1239 | in 1240 | loop v0_case v1_case (Type.Gist.Variant.cases v) 1241 | 1242 | and compare_func : type d r. (d, r) Type.Gist.func -> (d -> r) cmp = 1243 | fun f _ _ -> invalid_arg "functional value" 1244 | 1245 | and compare_abstract : type a. a Type.Gist.abstract -> a cmp = 1246 | fun a v0 v1 -> match Type.Gist.Abstract.reprs a with 1247 | | [] -> 1248 | let n = Type.Gist.Abstract.type_name a in 1249 | invalid_arg "%s: abstract type exposes no representation" n 1250 | | (Repr r) :: _ -> 1251 | let v0 = Type.Gist.Abstract.Repr.inject r v0 in 1252 | let v1 = Type.Gist.Abstract.Repr.inject r v1 in 1253 | let g = Type.Gist.Abstract.Repr.gist r in 1254 | compare g v0 v1 1255 | 1256 | and compare : type a. a Type.Gist.t -> a cmp = fun g v0 v1 -> 1257 | (* N.B. Shifting the lookup in each case could be more efficient. *) 1258 | match Meta.Compare.find (Type.Gist.meta g) with 1259 | | Some compare -> compare v0 v1 1260 | | None -> 1261 | match g with 1262 | | Scalar s -> Type.Gist.Scalar.compare s v0 v1 1263 | | Arraylike a -> compare_arraylike a v0 v1 1264 | | Maplike m -> compare_maplike m v0 v1 1265 | | Product p -> compare_product p v0 v1 1266 | | Record r -> compare_product r v0 v1 1267 | | Sum s -> compare_sum s v0 v1 1268 | | Func f -> compare_func f v0 v1 1269 | | Abstract a -> compare_abstract a v0 v1 1270 | | Lazy (_, g) -> compare g (Lazy.force v0) (Lazy.force v1) 1271 | | Ref (_, g) -> compare g !v0 !v1 1272 | | Rec g -> compare (Lazy.force g) v0 v1 1273 | end 1274 | 1275 | module Grandom = struct 1276 | type 'a rand = size:int -> Random.State.t -> bound:int -> 'a 1277 | 1278 | let invalid_arg fmt = 1279 | Format.ksprintf invalid_arg ("Fun.Generic.random: " ^^ fmt) 1280 | 1281 | let sized_nat ~size st = Random.State.int st (size + 1) 1282 | 1283 | let uchar_surrogate_count = 0xDFFF - 0xD800 + 1 1284 | let uchar_count = Uchar.to_int Uchar.max + 1 - uchar_surrogate_count 1285 | let random_uchar st = 1286 | let u = Random.State.int st uchar_count in 1287 | let u = if u < 0xD800 then u else u + uchar_surrogate_count in 1288 | Uchar.unsafe_of_int u 1289 | 1290 | let div_round_up x y = (x + y - 1) / y 1291 | let rbits = 30 (* number of bits returned by Random.State.bits. *) 1292 | let rbits_calls = div_round_up Sys.int_size rbits 1293 | let random_int st = 1294 | let r = ref 0 in 1295 | for i = 1 to rbits_calls do 1296 | let bits = Random.State.bits st in r := (!r lsl rbits) lor bits 1297 | done; 1298 | !r 1299 | 1300 | let rec rand_scalar : 1301 | type a. a Type.Gist.scalar -> a rand = fun s ~size st ~bound -> 1302 | match s with 1303 | | Unit _ -> () 1304 | | Bool _ -> Random.State.bool st 1305 | | Char _ -> Char.chr (Random.State.int st 256) 1306 | | Uchar _ -> random_uchar st 1307 | | Int _ -> random_int st 1308 | | Int32 _ -> Random.State.bits32 st 1309 | | Int64 _ -> Random.State.bits64 st 1310 | | Nativeint _ -> Random.State.nativebits st 1311 | | Float _ -> Int64.to_float (Random.State.bits64 st) 1312 | 1313 | and rand_arraylike : 1314 | type elt arr. (elt, arr) Type.Gist.arraylike -> arr rand = 1315 | fun a ~size st ~bound -> 1316 | let (module A) = Type.Gist.Arraylike.to_array_module a in 1317 | let elt = Type.Gist.Arraylike.elt a in 1318 | A.init (sized_nat ~size st) (fun _ -> rand elt ~size st ~bound) 1319 | 1320 | and rand_maplike : 1321 | type k v m. (k, v, m) Type.Gist.maplike -> m rand = 1322 | fun m ~size st ~bound -> 1323 | let bcount = sized_nat ~size st in 1324 | let (empty, add, k, v) : 1325 | m * (k -> v -> m -> m) * k Type.Gist.t * v Type.Gist.t = 1326 | match m with 1327 | | Hashtbl (_, k, v) -> 1328 | let add k v h = Hashtbl.replace h k v; h in 1329 | Hashtbl.create bcount, add, k, v 1330 | | Map_module (_, (module M), k, v) -> 1331 | M.empty, M.add, k, v 1332 | in 1333 | let rkey = rand (Type.Gist.Maplike.key m) in 1334 | let rvalue = rand (Type.Gist.Maplike.value m) in 1335 | let rec loop count m = 1336 | if count <= 0 then m else 1337 | let k = rkey ~size st ~bound and v = rvalue ~size st ~bound in 1338 | loop (count - 1) (add k v m) 1339 | in 1340 | loop bcount empty 1341 | 1342 | and rand_product : type p. p Type.Gist.product -> p rand = 1343 | fun p ~size st ~bound -> 1344 | let rec rand_fields : type p a. (p, a) Type.Gist.fields -> a = 1345 | function 1346 | | Ctor f -> f 1347 | | App (fs, field) -> 1348 | let f = rand_fields fs in 1349 | let v = rand (Type.Gist.Field.gist field) ~size st ~bound in 1350 | f v 1351 | in 1352 | rand_fields (Type.Gist.Product.fields p) 1353 | 1354 | and rand_variant_case : type p. p Type.Gist.Variant.case -> p rand = 1355 | fun c ~size st ~bound -> 1356 | let rec rand_fields : type p a. (p, a) Type.Gist.fields -> a = 1357 | function 1358 | | Ctor f -> f 1359 | | App (fs, field) -> 1360 | let f = rand_fields fs in 1361 | let v = match Type.Gist.Field.gist field with 1362 | | Rec _ -> 1363 | rand (Type.Gist.Field.gist field) ~size st ~bound 1364 | | _ -> 1365 | rand (Type.Gist.Field.gist field) ~size st ~bound:size 1366 | in 1367 | f v 1368 | in 1369 | rand_fields (Type.Gist.Product.fields c) 1370 | 1371 | and rand_sum : type s. s Type.Gist.sum -> s rand = 1372 | fun s ~size st ~bound -> match s with 1373 | | List (_, elt) -> 1374 | List.init (sized_nat ~size st) (fun _ -> rand elt ~size st ~bound) 1375 | | s -> 1376 | let v = Type.Gist.Sum.to_variant s in 1377 | let cases = Type.Gist.Variant.cases v in 1378 | let rec case_distrib count acc = function 1379 | | [] -> count, acc 1380 | | c :: cs -> 1381 | match Type.Gist.Product.rec_field_count c with 1382 | | 0 -> case_distrib (count + 1) ((bound, c) :: acc) cs 1383 | | n when bound <= 0 -> case_distrib count acc cs (* no rec *) 1384 | | n -> 1385 | let bound = bound / n in 1386 | let c = bound, c in 1387 | (* more frequently, can we have a principle here rather 1388 | than a magic number ? *) 1389 | let acc = c :: c :: acc in 1390 | case_distrib (count + 2) acc cs 1391 | in 1392 | let count, case_distrib = case_distrib 0 [] cases in 1393 | let i = Random.State.int st count in 1394 | let bound, case = List.nth case_distrib i in 1395 | rand_variant_case case ~size st ~bound 1396 | 1397 | and rand_func : 1398 | type d r. (d, r) Type.Gist.func -> (d -> r) rand = fun f ~size st -> 1399 | (* TODO we could do something here but see §3.3 of the quickcheck 1400 | paper. Also on 5.0 we have splitting which could help. *) 1401 | invalid_arg "functional value" 1402 | 1403 | and rand_abstract : 1404 | type a. a Type.Gist.abstract -> a rand = fun a ~size st ~bound -> 1405 | match Type.Gist.Abstract.reprs a with 1406 | | [] -> 1407 | let n = Type.Gist.Abstract.type_name a in 1408 | invalid_arg "%s: abstract type exposes no representation" n 1409 | | (Repr r) :: _ -> 1410 | let g = Type.Gist.Abstract.Repr.gist r in 1411 | let v = rand g ~size st ~bound in 1412 | Type.Gist.Abstract.Repr.project r v 1413 | 1414 | and rand : type a. a Type.Gist.t -> a rand = fun g ~size st ~bound -> 1415 | (* N.B. Shifting the lookup in each case could be more efficient. 1416 | Also maybe we should merge Gen and Size into a single structure. *) 1417 | let meta = Type.Gist.meta g in 1418 | let size = Option.value ~default:size (Meta.Random.Size.find meta) in 1419 | match Meta.Random.Gen.find (Type.Gist.meta g) with 1420 | | Some rand -> rand ~size st ~bound 1421 | | None -> 1422 | match g with 1423 | | Scalar s -> rand_scalar s ~size st ~bound 1424 | | Arraylike a -> rand_arraylike a ~size st ~bound 1425 | | Maplike m -> rand_maplike m ~size st ~bound 1426 | | Product p -> rand_product p ~size st ~bound 1427 | | Record r -> rand_product r ~size st ~bound 1428 | | Sum s -> rand_sum s ~size st ~bound 1429 | | Func f -> rand_func f ~size st ~bound 1430 | | Abstract a -> rand_abstract a ~size st ~bound 1431 | | Lazy (_, g) -> lazy (rand g ~size st ~bound) 1432 | | Ref (_, g) -> ref (rand g ~size st ~bound) 1433 | | Rec g -> rand (Lazy.force g) ~size st ~bound 1434 | 1435 | let random g ?(size = 23) ?state () = 1436 | let st = match state with None -> Random.get_state () | Some s -> s in 1437 | let v = rand g ~size st ~bound:size in 1438 | Random.set_state st; 1439 | v 1440 | end 1441 | 1442 | let pp = Gfmt.pp 1443 | let equal = Gequal.equal 1444 | let compare = Gcompare.compare 1445 | let random = Grandom.random 1446 | end 1447 | end 1448 | --------------------------------------------------------------------------------