├── .gitignore ├── README.md ├── dune-project ├── ppx_deriving_tpf.opam ├── src-ext ├── dune ├── index.mld ├── tpf_cmdliner.ml ├── tpf_cmdliner.mli ├── tpf_crowbar.ml ├── tpf_crowbar.mli ├── tpf_fmt.ml ├── tpf_fmt.mli ├── tpf_json.ml ├── tpf_json.mli ├── tpf_qcheck.ml ├── tpf_qcheck.mli ├── tpf_sexplib.ml └── tpf_sexplib.mli ├── src-ppx-deriving ├── dune ├── index.mld ├── ppx_deriving_tpf.ml └── ppx_deriving_tpf.mli ├── src ├── dune ├── index.mld ├── tpf.ml ├── tpf.mli ├── tpf_std.ml └── tpf_std.mli ├── tpf-ext.opam └── tpf.opam /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | .merlin 3 | *.install 4 | 5 | tmp 6 | *~ 7 | \.\#* 8 | \#*# 9 | 10 | rondom 11 | *.json 12 | TEXT.md 13 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Tpf — minimalist datatype-generic programming 2 | 3 | %%VERSION%% 4 | 5 | Tagless/trivial polytypic functions (Tpf) is a simple and idiomatic library for 6 | datatype-generic programming in OCaml. 7 | 8 | *Generic* programming is all about not writing the same old `equal` again. 9 | 10 | *Datatype-generic* (or polytypic) programming is solving this at the language 11 | level. 12 | 13 | Tpf allows you to write functions that work on a wide range of unrelated data 14 | types. Such functions require only the base language, need no runtime, and 15 | seamlessly interoperate with the rest of OCaml. Tpf works in the same stage as 16 | the rest of your program, and doesn't rely on meta-programming. 17 | 18 | Tpf is closely related to other well-known datatype-generic approaches. It 19 | shares the underlying data model with [SYB][syb], and uses the 20 | [spiny][syb-reloaded] encoding. This is a manifest representation, like the one 21 | [GHC.Generics][ghc-generics] use. It arises as an adaptation of approaches like 22 | these to a language without overloading, giving it an idiomatic flavor, and 23 | lending the name. 24 | 25 | Tpf has no dependencies and is distributed under the ISC license. 26 | 27 | [syb]: https://wiki.haskell.org/Scrap_your_boilerplate 28 | [syb-reloaded]: https://www.cs.ox.ac.uk/bruno.oliveira/SYB0.pdf 29 | [ghc-generics]: https://wiki.haskell.org/GHC.Generics 30 | 31 | ## Installation 32 | 33 | Tpf can be installed with `opam`: 34 | 35 | opam install tpf 36 | opam install tpf-ext # Install the optional support for third-party libs 37 | opam install tpf-deriving # Install the optional PPX deriver 38 | 39 | If you don't use `opam` consult the [`tpf.opam`](tpf.opam) file for build 40 | instructions. 41 | 42 | ## Documentation 43 | 44 | The documentation and API reference is automatically generated by `odoc` from 45 | the interfaces. It can be consulted [online][doc]. 46 | 47 | [doc]: https://pqwy.github.io/tpf/doc 48 | 49 | ## Library layout 50 | 51 | Tpf contains several optional libraries and sub-libraries: 52 | 53 | - opam package `tpf` contains the [core library][doc-tpf]. 54 | - opam package `tpf-ext` adds support for various [third-party libs][doc-tpf-ext]. 55 | - opam package `tpf-deriving` contains the generic deriver. 56 | It is worth pointing out that Tpf can be used without PPX. 57 | 58 | [doc-tpf]: https://pqwy.github.io/tpf/doc/tpf/index.html 59 | [doc-tpf-ext]: https://pqwy.github.io/tpf/doc/tpf-ext/index.html 60 | 61 | ## Quick start 62 | 63 | Consult the [quick start][quick_start] section of the documentation. 64 | 65 | [quick_start]: https://pqwy.github.io/tpf/doc/tpf/index.html#quick_start 66 | 67 | ## Performance 68 | 69 | ### Tpf is glacially slow... 70 | 71 | You can write a generic function that, for example, counts the number of 72 | recursive occurrences, and use this function to measure the length of a list. 73 | 74 | It takes about 5x the time it takes `List.length`. 75 | 76 | Of course it does. `List.length` compiles to a 4-instruction loop. The Tpf 77 | version reconstructs the entire list (albeit lazily), and explores every field 78 | of every block in it. 79 | 80 | ### ... and Tpf is lightning fast! 81 | 82 | If you use the industry-leading PPX-based Sexplib deriver, 83 | [ppx_sexp_conv][ppx-sexp-conv], and compare the performance of derived 84 | conversion functions (`sexp_of_tweedledum` / `tweedledum_of_sexp`) to the 85 | performance of a Tpf-based generic version, the ratio is about 1.25. Generic 86 | version is 25% slower. 87 | 88 | If you compose these conversion functions with something that interacts with the 89 | actual bytes, the overall performance hit of using generics drops to just below 90 | 10%. 91 | 92 | Incidentally, most attempts at writing a generic printer will end up being 93 | *faster* than hand-written printers, as `CamlinternalFormat.make_printf` is 94 | a formidable opponent. 95 | 96 | [ppx-sexp-conv]: https://github.com/janestreet/ppx_sexp_conv 97 | 98 | ### Tpf is usable. 99 | 100 | Clearly, whether the overhead introduced by generic functions is *significant* 101 | depends entirely on what they are doing. And whether this ends up being 102 | *prohibitive*, depends entirely on your use-case. 103 | 104 | It doesn't cost much to try. 105 | 106 | ## Compared to alternatives 107 | 108 | ### PPX deriving 109 | 110 | The use cases of [ppx_deriving][ppx_deriving] overlap with those of Tpf, even if 111 | the two approaches are meant to do different things. 112 | 113 | - Tpf is generally slower, especially when consuming values. 114 | - Tpf is less flexible, as it can not extend the language. 115 | - Tpf does not care about hygiene. 116 | - Tpf requires no tooling or external support. 117 | - Tpf makes it infinitely easier to write generic functions. 118 | 119 | ### OCaml SYB 120 | 121 | (As seen [here][ocaml-syb].) 122 | 123 | - Tpf does not require a patched compiler. 124 | - Tpf has no concept of overloading, so the user is responsible for manually 125 | specifying what to do at contained types. 126 | - Tpf is faster because the manifest representations and internalized recursion 127 | turn out to be. 128 | - Tpf is typically easier to write generic functions for. But their 129 | expressivity is still exactly the same. 130 | 131 | ### Generic programming in OCaml 132 | 133 | (As seen [here][generic-programming-in-ocaml].) 134 | 135 | Tpf is *tagless*. It strictly avoids type reflection, which leads to a number of 136 | differences that make Tpf feel more natural to an OCaml programmer. 137 | 138 | - Tpf generic functions are parametrically polymorphic. 139 | - Tpf does not essentially depend on PPX extension points. 140 | - Tpf does not import its private overloading semantics into your programs. 141 | - Tpf does not hide the fact that a particular function is not implemented at a 142 | particular type from the type checker. 143 | - Tpf is decidedly minimalist. 144 | 145 | [ppx_deriving]: https://github.com/ocaml-ppx/ppx_deriving 146 | [ocaml-syb]: https://github.com/yallop/ocaml-syb 147 | [generic-programming-in-ocaml]: https://arxiv.org/pdf/1812.11665.pdf 148 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 1.9) 2 | (name tpf) 3 | (version %%VERSION_NUM%%) 4 | (allow_approximate_merlin) 5 | -------------------------------------------------------------------------------- /ppx_deriving_tpf.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | homepage: "https://github.com/pqwy/tpf" 3 | dev-repo: "git+https://github.com/pqwy/tpf.git" 4 | bug-reports: "https://github.com/pqwy/tpf/issues" 5 | doc: "http://pqwy.github.io/tpf/doc" 6 | author: "David Kaloper Meršinjak " 7 | maintainer: "David Kaloper Meršinjak " 8 | license: "ISC" 9 | synopsis: "Minimalist datatype-generic programming" 10 | description: "[@@deriving tpf]" 11 | 12 | build: [[ "dune" "subst" ] {pinned} 13 | [ "dune" "build" "-p" name "-j" jobs ]] 14 | depends: [ 15 | "ocaml" {>= "4.05.0"} 16 | "dune" {build & >= "1.8"} 17 | "tpf" 18 | "ppx_deriving" 19 | ] 20 | -------------------------------------------------------------------------------- /src-ext/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (public_name tpf-ext.fmt) 3 | (name tpf_fmt) 4 | (synopsis "Generic pretty-printers") 5 | (wrapped false) 6 | (modules tpf_fmt) 7 | (optional) 8 | (libraries tpf fmt)) 9 | 10 | (library 11 | (public_name tpf-ext.sexplib) 12 | (name tpf_sexplib) 13 | (synopsis "Generic sexps") 14 | (wrapped false) 15 | (modules tpf_sexplib) 16 | (optional) 17 | (libraries tpf sexplib0)) 18 | 19 | (library 20 | (public_name tpf-ext.cmdliner) 21 | (name tpf_cmdliner) 22 | (synopsis "Generic command lines") 23 | (wrapped false) 24 | (modules tpf_cmdliner) 25 | (optional) 26 | (libraries tpf cmdliner)) 27 | 28 | (library 29 | (public_name tpf-ext.qcheck) 30 | (name tpf_qcheck) 31 | (synopsis "Generic QCheck") 32 | (wrapped false) 33 | (modules tpf_qcheck) 34 | (optional) 35 | (libraries tpf tpf-ext.fmt qcheck-core)) 36 | 37 | (library 38 | (public_name tpf-ext.crowbar) 39 | (name tpf_crowbar) 40 | (synopsis "Generic Crowbar") 41 | (wrapped false) 42 | (modules tpf_crowbar) 43 | (optional) 44 | (libraries tpf tpf-ext.fmt crowbar)) 45 | 46 | (library 47 | (public_name tpf-ext.json) 48 | (name tpf_json) 49 | (synopsis "Generic generic json") 50 | (wrapped false) 51 | (modules tpf_json) 52 | (optional) 53 | (libraries tpf)) 54 | 55 | (documentation 56 | (package tpf-ext) 57 | (mld_files index)) 58 | -------------------------------------------------------------------------------- /src-ext/index.mld: -------------------------------------------------------------------------------- 1 | {0 Tpf extensions} 2 | 3 | {!modules: Tpf_json} 4 | 5 | Collection of modules that expose various existing libraries as Tpf generic 6 | functions: 7 | 8 | {!modules: Tpf_cmdliner Tpf_crowbar Tpf_fmt Tpf_sexplib Tpf_qcheck} 9 | -------------------------------------------------------------------------------- /src-ext/tpf_cmdliner.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (c) 2019 David Kaloper Meršinjak. All rights reserved. 2 | See LICENSE.md. *) 3 | 4 | open Tpf 5 | open Cmdliner 6 | 7 | let invalid_arg fmt = Format.kasprintf invalid_arg fmt 8 | let err_recursive () = 9 | invalid_arg "Tpf_cmdliner: recursive types are not supported" 10 | let err_no_labels = 11 | invalid_arg "Tpf_cmdliner: `%a': not a record" pp_meta 12 | let err_not_singleton () = 13 | invalid_arg "Tpf_cmdliner: expecting a type with one constructor." 14 | 15 | module G = Generic (struct type 'a q = 'a Arg.conv end) 16 | open G 17 | 18 | include G.P 19 | 20 | module Opt = struct 21 | open S 22 | let g = function 23 | | [s, m] -> 24 | let rec term: 'a. _ -> ('a, _, _) spine -> 'a Term.t = fun i -> function 25 | | K k -> Term.const k 26 | | R _ -> err_recursive () 27 | | A (s, a) -> 28 | let nfo = Arg.info [label m i] in 29 | let arg = Arg.(required @@ opt (some !:a) None nfo) in 30 | Term.(term (i - 1) s $ arg) in 31 | term (labels m - 1) s 32 | | _ -> err_not_singleton () 33 | include Schema (struct type 'a r = 'a Term.t let gfun = g end) 34 | end 35 | 36 | module Opt_def = struct 37 | open V 38 | let g v x = 39 | let m = meta v x in 40 | match labels m with 41 | | 0 -> err_no_labels m 42 | | _ -> 43 | let rec term: 'a. _ -> ('a, _, _) spine -> 'a Term.t = fun i -> function 44 | | K k -> Term.const k 45 | | R _ -> err_recursive () 46 | | A (s, a, f) -> 47 | let nfo = Arg.info [label m i] in 48 | Term.(term (i - 1) s $ Arg.(value @@ opt !:f a nfo)) in 49 | term (labels m - 1) (spine v x) 50 | include View (struct type 'a r = 'a -> 'a Term.t let gfun = g end) 51 | end 52 | 53 | module Pos = struct 54 | open S 55 | let g = function 56 | | [s, _] -> 57 | fun i -> 58 | let rec term: 'a. ('a, _, _) spine -> 'a Term.t * _ = function 59 | | K k -> Term.const k, i 60 | | R _ -> err_recursive () 61 | | A (s, a) -> 62 | let t, i = term s in 63 | Term.(t $ Arg.(required @@ pos i (some !:a) None @@ info [])), i + 1 64 | in 65 | term s 66 | | _ -> err_not_singleton () 67 | include Schema (struct type 'a r = int -> 'a Term.t * int let gfun = g end) 68 | end 69 | 70 | module Pos_def = struct 71 | open V 72 | let g v x i = 73 | let rec term: 'a. ('a, _, _) spine -> 'a Term.t * _ = function 74 | | K k -> Term.const k, i 75 | | R _ -> err_recursive () 76 | | A (s, a, f) -> 77 | let t, i = term s in 78 | Term.(t $ Arg.(value @@ pos i !:f a @@ info [])), i + 1 in 79 | term (spine v x) 80 | include View (struct 81 | type 'a r = 'a -> int -> 'a Term.t * int 82 | let gfun = g 83 | end) 84 | end 85 | -------------------------------------------------------------------------------- /src-ext/tpf_cmdliner.mli: -------------------------------------------------------------------------------- 1 | (* Copyright (c) 2019 David Kaloper Meršinjak. All rights reserved. 2 | See LICENSE.md. *) 3 | 4 | (** Generic command-line arguments. 5 | 6 | This modules depends on [cmdliner]. *) 7 | 8 | open Tpf 9 | open Cmdliner 10 | 11 | include P with type 'a q := 'a Arg.conv 12 | 13 | module Opt: sig 14 | val g : ('a, p) schema -> 'a Term.t 15 | include Data with 16 | type 'a r := 'a Term.t and type 'a q := 'a Arg.conv 17 | end 18 | 19 | module Opt_def: sig 20 | val g : ('a, p) view -> 'a -> 'a Term.t 21 | include Data with 22 | type 'a r := 'a -> 'a Term.t and type 'a q := 'a Arg.conv 23 | end 24 | 25 | module Pos: sig 26 | val g : ('a, p) schema -> int -> 'a Term.t * int 27 | include Data with 28 | type 'a r := int -> 'a Term.t * int and type 'a q := 'a Arg.conv 29 | end 30 | 31 | module Pos_def: sig 32 | val g : ('a, p) view -> 'a -> int -> 'a Term.t * int 33 | include Data with 34 | type 'a r := 'a -> int -> 'a Term.t * int and type 'a q := 'a Arg.conv 35 | end 36 | -------------------------------------------------------------------------------- /src-ext/tpf_crowbar.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (c) 2019 David Kaloper Meršinjak. All rights reserved. 2 | See LICENSE.md. *) 3 | 4 | open Crowbar 5 | 6 | include Tpf_std.AppS (struct 7 | type 'a t = 'a gen 8 | let pure = const 9 | let app f a = map [f; a] (@@) 10 | let retract = unlazy 11 | let gfun gens = choose (List.map (fun (g, _) -> unlazy g) gens) 12 | end) 13 | let g_gen = gfun 14 | -------------------------------------------------------------------------------- /src-ext/tpf_crowbar.mli: -------------------------------------------------------------------------------- 1 | (* Copyright (c) 2019 David Kaloper Meršinjak. All rights reserved. 2 | See LICENSE.md. *) 3 | 4 | (** Generic Crowbar. 5 | 6 | This module provides generic {!Crowbar.gen} and depends on [crowbar]. 7 | 8 | It combines nicely with with {{!Tpf_fmt}generic printing} and 9 | {{!Tpf_std.Eq}generic equality}. *) 10 | 11 | open Tpf 12 | 13 | (** {1 Generic [gen]} *) 14 | include P with type 'a q := 'a Crowbar.gen 15 | val g_gen : ('a, p) schema -> 'a Crowbar.gen 16 | 17 | (** {1 [data] interface} *) 18 | include Data with type 'a q := 'a Crowbar.gen and type 'a r := 'a Crowbar.gen 19 | -------------------------------------------------------------------------------- /src-ext/tpf_fmt.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (c) 2019 David Kaloper Meršinjak. All rights reserved. 2 | See LICENSE.md. *) 3 | 4 | open Tpf 5 | 6 | module G = Generic (struct type 'a q = 'a Fmt.t end) 7 | open G 8 | open V 9 | 10 | let pp_pp ppf pp = pp ppf () 11 | let sum name ppf = function 12 | | [] -> Fmt.string ppf name 13 | | [x] -> Fmt.pf ppf "@[<1>%s@ %a@]" name x () 14 | | xs -> Fmt.(pf ppf "@[<1>%s@ (%a)@]" name (list ~sep:comma pp_pp) xs) 15 | 16 | let record name ppf xs = 17 | let pp_kv ppf (label, pp) = Fmt.pf ppf "@[<1>%s =@ %a@]" label pp () in 18 | match name with 19 | | Some n -> Fmt.(pf ppf "@[<1>%s@ {%a}@]" n (list ~sep:semi pp_kv) xs) 20 | | None -> Fmt.(pf ppf "@[<1>{%a}@]" (list ~sep:semi pp_kv) xs) 21 | 22 | let rec g_pp ?(sum = sum) ?(record = record) v ppf x = 23 | let goto10 = g_pp ~sum ~record v in 24 | let rec go_v: 'a. ('a, _, _) spine -> _ = fun s acc -> match s with 25 | | K _ -> acc 26 | | A (s, a, af) -> go_v s (Fmt.const !:af a :: acc) 27 | | R (s, a) -> go_v s (Fmt.const goto10 a :: acc) in 28 | let rec go_r: 'a. ('a, _, _) spine -> _ = fun s m i acc -> match s with 29 | | K _ -> acc 30 | | A (s, a, af) -> go_r s m (i - 1) ((label m i, Fmt.const !:af a) :: acc) 31 | | R (s, a) -> go_r s m (i - 1) ((label m i, Fmt.const goto10 a) :: acc) in 32 | let m = meta v x in 33 | match spine v x, labels m, name m with 34 | | K _, _, name -> sum name ppf [] 35 | | s , 0, name -> sum name ppf (go_v s []) 36 | | s , _, "" -> record None ppf (go_r s m (labels m - 1) []) 37 | | s , _, name -> record (Some name) ppf (go_r s m (labels m - 1) []) 38 | 39 | type sum = string -> unit Fmt.t list Fmt.t 40 | type record = string option -> (string * unit Fmt.t) list Fmt.t 41 | 42 | include P 43 | 44 | let data0 ?sum ?record (d: _ data0) = app0 (g_pp ?sum ?record) d.view 45 | let data1 ?sum ?record (d: _ data1) = app1 (g_pp ?sum ?record) d.view 46 | let data2 ?sum ?record (d: _ data2) = app2 (g_pp ?sum ?record) d.view 47 | let data3 ?sum ?record (d: _ data3) = app3 (g_pp ?sum ?record) d.view 48 | let data4 ?sum ?record (d: _ data4) = app4 (g_pp ?sum ?record) d.view 49 | let data5 ?sum ?record (d: _ data5) = app5 (g_pp ?sum ?record) d.view 50 | let data6 ?sum ?record (d: _ data6) = app6 (g_pp ?sum ?record) d.view 51 | let data7 ?sum ?record (d: _ data7) = app7 (g_pp ?sum ?record) d.view 52 | let data8 ?sum ?record (d: _ data8) = app8 (g_pp ?sum ?record) d.view 53 | let data9 ?sum ?record (d: _ data9) = app9 (g_pp ?sum ?record) d.view 54 | 55 | 56 | (* let sep_by pp = *) 57 | (* let first = ref true in *) 58 | (* fun ppf () -> if !first then first := false else pp ppf () *) 59 | 60 | (* let parens pp ppf x = Fmt.(string ppf "("; pp ppf x; string ppf ")") *) 61 | 62 | (* let rec g_pp: 'a. ('a, _) view -> 'a Fmt.t = fun v ppf x -> *) 63 | (* let variant ppf s = *) 64 | (* let sep = sep_by Fmt.comma in *) 65 | (* let rec go: 'a. ('a, _, _) spine Fmt.t = fun ppf -> function *) 66 | (* | K _ -> () *) 67 | (* | A (s, a, f) -> go ppf s; sep ppf (); !:f ppf a *) 68 | (* | R (s, a) -> go ppf s; sep ppf (); g_pp v ppf a in *) 69 | (* match s with *) 70 | (* | A (K _, a, f) -> !:f ppf a *) 71 | (* | R (K _, a) -> g_pp v ppf a *) 72 | (* | s -> parens go ppf s *) 73 | (* and record m ppf s = *) 74 | (* let sep = sep_by Fmt.semi in *) 75 | (* let field ppf i pp_x x = *) 76 | (* sep ppf (); Fmt.pf ppf "@[<1>%s =@ %a@]" (field m i) pp_x x in *) 77 | (* let rec go: 'a. _ -> _ -> ('a, _, _) spine -> _ = *) 78 | (* fun i ppf -> function *) 79 | (* | K _ -> () *) 80 | (* | A (s, a, f) -> go (i - 1) ppf s; field ppf i !:f a *) 81 | (* | R (s, a) -> go (i - 1) ppf s; field ppf i (g_pp v) a in *) 82 | (* let pp_s ppf s = go (fields m - 1) ppf s in *) 83 | (* pp_s ppf s in *) 84 | (* let m = meta v x in *) 85 | (* match spine v x, fields m, name m with *) 86 | (* | K _, _, name -> Fmt.string ppf name *) 87 | (* | s , 0, name -> Fmt.pf ppf "@[<1>%s@ %a@]" name variant s *) 88 | (* | s , _, "" -> Fmt.pf ppf "@[<1>{%a}@]" (record m) s *) 89 | (* | s , _, name -> Fmt.pf ppf "@[<1>%s@ %a@]" name (record m) s *) 90 | 91 | (* include P *) 92 | (* include View (struct type 'a r = 'a Fmt.t let gfun = g_pp end) *) 93 | -------------------------------------------------------------------------------- /src-ext/tpf_fmt.mli: -------------------------------------------------------------------------------- 1 | (* Copyright (c) 2019 David Kaloper Meršinjak. All rights reserved. 2 | See LICENSE.md. *) 3 | 4 | (** Generic printers. 5 | 6 | This modules depends on [fmt]. *) 7 | 8 | open Tpf 9 | 10 | (** {1 Generic printer} *) 11 | 12 | type sum = string -> unit Fmt.t list Fmt.t 13 | (** [sum name args] formats a variant with constructor [name] and 14 | argument formatters [args]. *) 15 | 16 | type record = string option -> (string * unit Fmt.t) list Fmt.t 17 | (** [record None fields] formats a plain constructorless record; 18 | [record (Some name) fields] formats an inline record with constructor 19 | [name]. [args] are argument formatters paired with field names. *) 20 | 21 | include P with type 'a q := 'a Fmt.t 22 | 23 | val g_pp : ?sum:sum -> ?record:record -> ('a, p) view -> 'a Fmt.t 24 | (** [g_pp ~sum ~record v ppf x] uses [v] to view [x] and pretty-print it on 25 | [ppf]. 26 | 27 | [sum] controls the formatting of plain variants, [record] of records. 28 | Defaults match the way toplevel prints values. *) 29 | 30 | (** {1 [data] interface} *) 31 | 32 | (* Note - this blaaargh can be replaced by including 33 | [Data with type 'a r := ?sum -> ?record -> 'a Fmt.t] but we pull the optional 34 | arguments to the beginning for a nicer API. *) 35 | 36 | val data0 : ?sum:sum -> ?record:record -> 37 | 'a data0 -> 38 | 'a Fmt.t 39 | val data1 : ?sum:sum -> ?record:record -> 40 | ('a, 'b) data1 -> 41 | 'a Fmt.t -> 'b Fmt.t 42 | val data2 : ?sum:sum -> ?record:record -> 43 | ('a, 'b, 'c) data2 -> 44 | 'a Fmt.t -> 'b Fmt.t -> 'c Fmt.t 45 | val data3 : ?sum:sum -> ?record:record -> 46 | ('a, 'b, 'c, 'd) data3 -> 47 | 'a Fmt.t -> 'b Fmt.t -> 'c Fmt.t -> 'd Fmt.t 48 | val data4 : ?sum:sum -> ?record:record -> 49 | ('a, 'b, 'c, 'd, 'e) data4 -> 50 | 'a Fmt.t -> 'b Fmt.t -> 'c Fmt.t -> 'd Fmt.t -> 'e Fmt.t 51 | val data5 : ?sum:sum -> ?record:record -> 52 | ('a, 'b, 'c, 'd, 'e, 'f) data5 -> 53 | 'a Fmt.t -> 'b Fmt.t -> 'c Fmt.t -> 'd Fmt.t -> 'e Fmt.t -> 'f Fmt.t 54 | val data6 : ?sum:sum -> ?record:record -> 55 | ('a, 'b, 'c, 'd, 'e, 'f, 'g) data6 -> 56 | 'a Fmt.t -> 'b Fmt.t -> 'c Fmt.t -> 'd Fmt.t -> 'e Fmt.t -> 57 | 'f Fmt.t -> 'g Fmt.t 58 | val data7 : ?sum:sum -> ?record:record -> 59 | ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) data7 -> 60 | 'a Fmt.t -> 'b Fmt.t -> 'c Fmt.t -> 'd Fmt.t -> 'e Fmt.t -> 61 | 'f Fmt.t -> 'g Fmt.t -> 'h Fmt.t 62 | val data8 : ?sum:sum -> ?record:record -> 63 | ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h, 'i) data8 -> 64 | 'a Fmt.t -> 'b Fmt.t -> 'c Fmt.t -> 'd Fmt.t -> 'e Fmt.t -> 65 | 'f Fmt.t -> 'g Fmt.t -> 'h Fmt.t -> 'i Fmt.t 66 | val data9 : ?sum:sum -> ?record:record -> 67 | ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h, 'i, 'j) data9 -> 68 | 'a Fmt.t -> 'b Fmt.t -> 'c Fmt.t -> 'd Fmt.t -> 'e Fmt.t -> 69 | 'f Fmt.t -> 'g Fmt.t -> 'h Fmt.t -> 'i Fmt.t -> 'j Fmt.t 70 | -------------------------------------------------------------------------------- /src-ext/tpf_json.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (c) 2019 David Kaloper Meršinjak. All rights reserved. 2 | See LICENSE.md. *) 3 | 4 | open Tpf 5 | 6 | type json = 7 | [ `Null | `Bool of bool | `Int of int | `Float of float| `String of string 8 | | `List of json list | `Assoc of (string * json) list ] 9 | 10 | type error = [`Msg of string] 11 | type 'a e = 'a -> json 12 | type 'a d = json -> ('a, error) result 13 | 14 | let pf ppf fmt = Format.fprintf ppf fmt 15 | let kstrf = Format.kasprintf 16 | let pp_error ppf (`Msg err) = pf ppf "%s" err 17 | 18 | module Enc = struct 19 | 20 | module G = Generic (struct type 'a q = 'a e end) 21 | open G 22 | open V 23 | 24 | type sum = string -> json list -> json 25 | let arr name xs = `List (`String name :: xs) 26 | let obj ?(tag = "tag") ?(values = "values") name xs = 27 | `Assoc [tag, `String name; values, `List xs] 28 | 29 | let rec g_to_json ?(sum = arr) (spine, meta as v) x = 30 | let m = meta x in 31 | let rec go_v: 'a. ('a, _, _) spine -> _ = fun s acc -> match s with 32 | | K _ -> acc 33 | | A (s, a, af) -> go_v s (!:af a :: acc) 34 | | R (s, a) -> go_v s (g_to_json ~sum v a :: acc) in 35 | let rec go_r: 'a. ('a, _, _) spine -> _ = fun s i acc -> match s with 36 | | K _ -> acc 37 | | A (s, a, af) -> go_r s (i - 1) ((label m i, !:af a) :: acc) 38 | | R (s, a) -> go_r s (i - 1) ((label m i, g_to_json ~sum v a) :: acc) in 39 | match spine x, labels m, name m with 40 | | K _, _, name -> `String name 41 | | s , n, "" -> `Assoc (go_r s (n - 1) []) 42 | | s , 0, name -> sum name (go_v s []) 43 | | s , n, name -> sum name [`Assoc (go_r s (n - 1) [])] 44 | 45 | include P 46 | 47 | let data0 ?sum (d: _ data0) = app0 (g_to_json ?sum) d.view 48 | let data1 ?sum (d: _ data1) = app1 (g_to_json ?sum) d.view 49 | let data2 ?sum (d: _ data2) = app2 (g_to_json ?sum) d.view 50 | let data3 ?sum (d: _ data3) = app3 (g_to_json ?sum) d.view 51 | let data4 ?sum (d: _ data4) = app4 (g_to_json ?sum) d.view 52 | let data5 ?sum (d: _ data5) = app5 (g_to_json ?sum) d.view 53 | let data6 ?sum (d: _ data6) = app6 (g_to_json ?sum) d.view 54 | let data7 ?sum (d: _ data7) = app7 (g_to_json ?sum) d.view 55 | let data8 ?sum (d: _ data8) = app8 (g_to_json ?sum) d.view 56 | let data9 ?sum (d: _ data9) = app9 (g_to_json ?sum) d.view 57 | end 58 | 59 | module Smap = Map.Make (struct 60 | type t = string 61 | let compare (a: string) b = compare a b 62 | end) 63 | let of_list xs = List.fold_left (fun m (k, v) -> Smap.add k v m) Smap.empty xs 64 | 65 | module Dec = struct 66 | 67 | type sum = (string * json list) d 68 | module G = Generic (struct type 'a q = 'a d end) 69 | open G 70 | open S 71 | 72 | let error_msg fmt = kstrf (fun err -> Error (`Msg err)) fmt 73 | 74 | exception Whoops of error 75 | let to_exn = function Ok x -> x | Error e -> raise (Whoops e) 76 | 77 | let raise_msg fmt = kstrf (fun err -> raise (Whoops (`Msg err))) fmt 78 | let err_arity () = raise_msg "variant arity mismatch" 79 | let err_missing_label x = raise_msg "missing record element: %s" x 80 | let err_extra_labels meta map = 81 | let pp ppf f _ = if not (has_label meta f) then pf ppf " %s" f in 82 | raise_msg "extra fields:%a" (fun ppf -> Smap.iter (pp ppf)) map 83 | let err_expect_obj () = raise_msg "expecting object" 84 | let err_expect_single_obj () = raise_msg "expecting single-object array" 85 | 86 | let err_expect_arr = error_msg "expecting array" 87 | let err_expect_sum_obj = error_msg "expecting {%S: \"\", %S: []}" 88 | let err_tag = error_msg "unexpected variant" 89 | 90 | let refl f json = !:f json |> to_exn 91 | 92 | let of_variant goto10 s = 93 | let rec go: 'a. ('a, _, _) spine -> ('a -> _) -> _ = fun s k -> match s with 94 | | K c -> fun json -> k c json 95 | | A (A (A (s, af), bf), cf) -> 96 | go s (fun f -> function 97 | | x0::x1::x2::xs -> k (f (refl af x0) (refl bf x1) (refl cf x2)) xs 98 | | _ -> err_arity ()) 99 | | A (A (s, af), bf) -> 100 | go s (fun f -> function 101 | | x0::x1::xs -> k (f (refl af x0) (refl bf x1)) xs 102 | | _ -> err_arity ()) 103 | | A (s, af) -> 104 | go s (fun f -> function 105 | | x::xs -> k (refl af x |> f) xs 106 | | _ -> err_arity ()) 107 | | R s -> 108 | go s (fun f -> function 109 | | [] -> err_arity () 110 | | x::xs -> k (goto10 x |> f) xs) in 111 | go s (fun x -> function [] -> x | _ -> err_arity ()) 112 | 113 | let get label map = match Smap.find_opt label map with 114 | | Some json -> json | _ -> err_missing_label label 115 | let refl f label map = match Smap.find_opt label map with 116 | | None -> err_missing_label label 117 | | Some json -> !:f json |> to_exn 118 | 119 | let of_record goto10 s m = 120 | let rec go: 'a. _ -> ('a, _, _) spine -> _ -> 'a = fun i -> function 121 | | K c -> fun _ -> c 122 | | A (A (A (s, af), bf), cf) -> 123 | let f = go (i - 3) s in fun map -> 124 | let k0 = label m (i - 2) and k1 = label m (i - 1) and k2 = label m i in 125 | f map (refl af k0 map) (refl bf k1 map) (refl cf k2 map) 126 | | A (A (s, af), bf) -> 127 | let f = go (i - 2) s 128 | and k0 = label m (i - 1) and k1 = label m i in 129 | fun map -> f map (refl af k0 map) (refl bf k1 map) 130 | | A (s, af) -> 131 | let f = go (i - 1) s and k = label m i in 132 | fun map -> f map (refl af k map) 133 | | R s -> 134 | let f = go (i - 1) s and k = label m i in 135 | fun map -> f map (goto10 (get k map)) in 136 | let n = labels m in 137 | let f = go (n - 1) s in function 138 | | `Assoc xs -> 139 | let map = of_list xs in 140 | if Smap.cardinal map <= n then f map else err_extra_labels m map 141 | | _ -> err_expect_obj () 142 | 143 | let arr = function 144 | | `List (`String name::jsons) -> Ok (name, jsons) 145 | | _ -> err_expect_arr 146 | let obj ?(tag = "tag") ?(values = "values") = function 147 | | `Assoc [f0, `String name; f1, `List jsons] 148 | | `Assoc [f1, `List jsons; f0, `String name] 149 | when f0 = tag && f1 = values -> Ok (name, jsons) 150 | | _ -> err_expect_sum_obj tag values 151 | 152 | let g_of_json ?(sum = arr) (type a) (schema: (a, p) schema) = 153 | let of_json = Tpf_std.fix @@ fun goto10 -> match schema with 154 | | [s, m] when name m = "" -> of_record goto10 s m 155 | | ss -> 156 | let to_f s m = match labels m with 157 | | 0 -> of_variant goto10 s 158 | | _ -> 159 | let f = of_record goto10 s m in 160 | function [xs] -> f xs | _ -> err_expect_single_obj () in 161 | let map = 162 | of_list @@ List.map (fun (s, m) -> name m, lazy (to_f s m)) ss in 163 | function 164 | | `String name -> Lazy.force (Smap.find name map) [] 165 | | json -> 166 | let (name, jsons) = sum json |> to_exn in 167 | Lazy.force (Smap.find name map) jsons in 168 | fun json -> try Ok (of_json json) with 169 | | Whoops err -> Error err 170 | | Not_found -> err_tag 171 | 172 | include P 173 | 174 | let data0 ?sum (d: _ data0) = app0 (g_of_json ?sum) d.schema 175 | let data1 ?sum (d: _ data1) = app1 (g_of_json ?sum) d.schema 176 | let data2 ?sum (d: _ data2) = app2 (g_of_json ?sum) d.schema 177 | let data3 ?sum (d: _ data3) = app3 (g_of_json ?sum) d.schema 178 | let data4 ?sum (d: _ data4) = app4 (g_of_json ?sum) d.schema 179 | let data5 ?sum (d: _ data5) = app5 (g_of_json ?sum) d.schema 180 | let data6 ?sum (d: _ data6) = app6 (g_of_json ?sum) d.schema 181 | let data7 ?sum (d: _ data7) = app7 (g_of_json ?sum) d.schema 182 | let data8 ?sum (d: _ data8) = app8 (g_of_json ?sum) d.schema 183 | let data9 ?sum (d: _ data9) = app9 (g_of_json ?sum) d.schema 184 | end 185 | -------------------------------------------------------------------------------- /src-ext/tpf_json.mli: -------------------------------------------------------------------------------- 1 | (* Copyright (c) 2019 David Kaloper Meršinjak. All rights reserved. 2 | See LICENSE.md. *) 3 | 4 | (** Generic JSON converters. 5 | 6 | Generic {{!Enc}injections} / {{!Dec}projections} between a type and a 7 | general purpose {{!json}JSON tree}. 8 | 9 | The tree type is non-generative, so it works with any underlying library for 10 | (de-)serialization. Howerver, the particular tree shape was chosen for 11 | compatibility with {{:https://github.com/ocaml-community/yojson}Joyson}. *) 12 | 13 | open Tpf 14 | 15 | type json = 16 | [ `Null | `Bool of bool | `Int of int | `Float of float| `String of string 17 | | `List of json list | `Assoc of (string * json) list ] 18 | (** JSON trees. 19 | 20 | {e Note.} This is {! Yojson.Basic.t}. *) 21 | 22 | type error = [`Msg of string] 23 | (** Decoder error. *) 24 | 25 | val pp_error : Format.formatter -> error -> unit 26 | (** [pp_error ppf e] pretty-prints [e] on [ppf]. *) 27 | 28 | (** {1 Encoders} *) 29 | 30 | type 'a e = 'a -> json 31 | (** Encoder type. *) 32 | 33 | (** Generic JSON encoder. 34 | 35 | Records are represented as JSON objects, and constant constructors are 36 | represented as JSON strings. 37 | 38 | The representation of variants is determined by the {{!sum}[~sum]} argument 39 | (default {!arr}). *) 40 | module Enc : sig 41 | 42 | (** {1 Generic function} *) 43 | 44 | include P with type 'a q := 'a e 45 | 46 | type sum = string -> json list -> json 47 | (** Sum-formatting functions. [f name args] is the JSON encoding of 48 | constructor named [name], with arguments [args]. *) 49 | 50 | val arr : sum 51 | (** Formats [K (a0, a1, ...)] as [["K", a0, a1, ...]]. *) 52 | 53 | val obj : ?tag:string -> ?values:string -> sum 54 | (** Formats [K (a0, a1, ...)] as [{ tag: "K", values: [a0, a1, ...]}]. 55 | 56 | [tag] defaults to ["tag"] and [values] defaults to ["values"]. *) 57 | 58 | val g_to_json : ?sum:sum -> ('a, p) view -> 'a e 59 | 60 | (** {1 [data] interface} *) 61 | 62 | val data0 : ?sum:sum -> 'x data0 -> 63 | 'x e 64 | val data1 : ?sum:sum -> ('a, 'x) data1 -> 65 | 'a e -> 'x e 66 | val data2 : ?sum:sum -> ('a, 'b, 'x) data2 -> 67 | 'a e -> 'b e -> 'x e 68 | val data3 : ?sum:sum -> ('a, 'b, 'c, 'x) data3 -> 69 | 'a e -> 'b e -> 'c e -> 'x e 70 | val data4 : ?sum:sum -> ('a, 'b, 'c, 'd, 'x) data4 -> 71 | 'a e -> 'b e -> 'c e -> 'd e -> 'x e 72 | val data5 : ?sum:sum -> ('a, 'b, 'c, 'd, 'e, 'x) data5 -> 73 | 'a e -> 'b e -> 'c e -> 'd e -> 'e e -> 'x e 74 | val data6 : ?sum:sum -> ('a, 'b, 'c, 'd, 'e, 'f, 'x) data6 -> 75 | 'a e -> 'b e -> 'c e -> 'd e -> 'e e -> 'f e -> 'x e 76 | val data7 : ?sum:sum -> ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'x) data7 -> 77 | 'a e -> 'b e -> 'c e -> 'd e -> 'e e -> 'f e -> 'g e -> 'x e 78 | val data8 : ?sum:sum -> ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h, 'x) data8 -> 79 | 'a e -> 'b e -> 'c e -> 'd e -> 'e e -> 'f e -> 'g e -> 'h e -> 'x e 80 | val data9 : ?sum:sum -> ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h, 'i, 'x) data9 -> 81 | 'a e -> 'b e -> 'c e -> 'd e -> 'e e -> 'f e -> 'g e -> 'h e -> 'i e -> 'x e 82 | end 83 | 84 | (** {1 Decoders} *) 85 | 86 | type 'a d = json -> ('a, error) result 87 | (** Decoder type. *) 88 | 89 | (** Generic JSON decoder. 90 | 91 | Records are expected as JSON objects, and constant constructors are expected 92 | as JSON strings. 93 | 94 | The representation of variants is determined by the {{!sum}[~sum]} argument 95 | (default {!arr}). *) 96 | module Dec: sig 97 | 98 | (** {1 Generic function} *) 99 | 100 | include P with type 'a q := 'a d 101 | 102 | type sum = (string * json list) d 103 | (** Sum-destructuring functions. [f json] is [Ok (name, args)] when [json] 104 | encodes a constructor named [name] with arguments [args], or [Error _] 105 | otherwise. *) 106 | 107 | val arr : sum 108 | (** Destructures [K (a0, a1, ...)] from [["K", a0, a1, ...]]. *) 109 | 110 | val obj : ?tag:string -> ?values:string -> sum 111 | (** Destructures [K (a0, a1, ...)] from [{ tag: "K", values: [a0, a1, ...]}]. 112 | 113 | [tag] defaults to ["tag"] and [values] defaults to ["values"]. *) 114 | 115 | val g_of_json : ?sum:sum -> ('a, p) schema -> 'a d 116 | 117 | (** {1 [data] interface} *) 118 | 119 | val data0 : ?sum:sum -> 'x data0 -> 120 | 'x d 121 | val data1 : ?sum:sum -> ('a, 'x) data1 -> 122 | 'a d -> 'x d 123 | val data2 : ?sum:sum -> ('a, 'b, 'x) data2 -> 124 | 'a d -> 'b d -> 'x d 125 | val data3 : ?sum:sum -> ('a, 'b, 'c, 'x) data3 -> 126 | 'a d -> 'b d -> 'c d -> 'x d 127 | val data4 : ?sum:sum -> ('a, 'b, 'c, 'd, 'x) data4 -> 128 | 'a d -> 'b d -> 'c d -> 'd d -> 'x d 129 | val data5 : ?sum:sum -> ('a, 'b, 'c, 'd, 'e, 'x) data5 -> 130 | 'a d -> 'b d -> 'c d -> 'd d -> 'e d -> 'x d 131 | val data6 : ?sum:sum -> ('a, 'b, 'c, 'd, 'e, 'f, 'x) data6 -> 132 | 'a d -> 'b d -> 'c d -> 'd d -> 'e d -> 'f d -> 'x d 133 | val data7 : ?sum:sum -> ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'x) data7 -> 134 | 'a d -> 'b d -> 'c d -> 'd d -> 'e d -> 'f d -> 'g d -> 'x d 135 | val data8 : ?sum:sum -> ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h, 'x) data8 -> 136 | 'a d -> 'b d -> 'c d -> 'd d -> 'e d -> 'f d -> 'g d -> 'h d -> 'x d 137 | val data9 : ?sum:sum -> ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h, 'i, 'x) data9 -> 138 | 'a d -> 'b d -> 'c d -> 'd d -> 'e d -> 'f d -> 'g d -> 'h d -> 'i d -> 'x d 139 | end 140 | -------------------------------------------------------------------------------- /src-ext/tpf_qcheck.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (c) 2019 David Kaloper Meršinjak. All rights reserved. 2 | See LICENSE.md. *) 3 | 4 | open Tpf 5 | open QCheck 6 | 7 | module G = Generic (struct type 'a q = 'a arbitrary end) 8 | open G 9 | 10 | let small (vf, _) x = 11 | let small arb a = match arb.small with Some f -> f a | _ -> 1 in 12 | let rec go: 'a. ('a, _, _) V.spine -> _ = function 13 | | K _ -> 1 14 | | A (s, a, f) -> go s + small !:f a 15 | | R (s, a) -> go s + go (vf a) in 16 | go (vf x) 17 | 18 | let g_shrink (vf, _) x i = 19 | let shrink arb a i = match arb.shrink with Some f -> f a i | _ -> i a in 20 | let rec go: 'a. ('a, _, _) V.spine -> 'a Iter.t = fun s i -> match s with 21 | | V.K x -> i x 22 | | V.A (s, a, f) -> go s (fun x -> shrink !:f a (fun a -> i (x a))) 23 | | R (s, a) -> go s (fun x -> go (vf a) (fun a -> i (x a))) in 24 | go (vf x) i 25 | 26 | let gen s = 27 | Tpf_std.(Random.(g_gen (smap { nat = fun arb -> !(!:arb.gen) } s))) 28 | 29 | let pp v = 30 | let to_string arb a = match arb.print with Some f -> f a | _ -> "" in 31 | let nat arb = Tpf_fmt.(!(fun ppf v -> Fmt.string ppf (to_string !:arb v))) in 32 | Tpf_fmt.g_pp (Tpf_std.vmap { nat } v) 33 | 34 | let g_arb v schema ?base size = 35 | make (gen schema ?base size) 36 | ~small:(small v) ~shrink:(g_shrink v) 37 | ~print:(pp v |> Fmt.to_to_string) 38 | 39 | include P 40 | 41 | let data0 (data: _ data0) = 42 | g_arb data.view data.schema 43 | let data1 (data: _ data1) a = 44 | g_arb (data.view !a) (data.schema !a) 45 | let data2 (data: _ data2) a b = 46 | g_arb (data.view !a !b) (data.schema !a !b) 47 | let data3 (data: _ data3) a b c = 48 | g_arb (data.view !a !b !c) (data.schema !a !b !c) 49 | let data4 (data: _ data4) a b c d = 50 | g_arb (data.view !a !b !c !d) (data.schema !a !b !c !d) 51 | let data5 (data: _ data5) a b c d e = 52 | g_arb (data.view !a !b !c !d !e) (data.schema !a !b !c !d !e) 53 | let data6 (data: _ data6) a b c d e f = 54 | g_arb (data.view !a !b !c !d !e !f) (data.schema !a !b !c !d !e !f) 55 | let data7 (data: _ data7) a b c d e f g = 56 | g_arb (data.view !a !b !c !d !e !f !g) (data.schema !a !b !c !d !e !f !g) 57 | let data8 (data: _ data8) a b c d e f g h = 58 | g_arb (data.view !a !b !c !d !e !f !g !h) (data.schema !a !b !c !d !e !f !g !h) 59 | let data9 (data: _ data9) a b c d e f g h i = 60 | g_arb (data.view !a !b !c !d !e !f !g !h !i) (data.schema !a !b !c !d !e !f !g !h !i) 61 | -------------------------------------------------------------------------------- /src-ext/tpf_qcheck.mli: -------------------------------------------------------------------------------- 1 | (* Copyright (c) 2019 David Kaloper Meršinjak. All rights reserved. 2 | See LICENSE.md. *) 3 | 4 | (** Generic QCheck.arbitrary. 5 | 6 | Note that if your type has interesting recursion, this will probably not 7 | work as it is not possible to fixpoint through {!arbitrary}. 8 | 9 | Most of the work here is being done by {!Tpf_std.Random} and {!Tpf_fmt}, 10 | which you can use directly if this is the case. *) 11 | 12 | open Tpf 13 | open QCheck 14 | 15 | (** {1 Generic [arbitrary]} *) 16 | include P with type 'a q := 'a arbitrary 17 | val g_arb : ('a, p) view -> ('a, p) schema -> ?base:'a -> int -> 'a arbitrary 18 | (** [g_arb view schema ~base size] is the {!arbitrary} instance over ['a]. 19 | 20 | [base] and [size] are used by {!Tpf_std.Random.g_gen} to bound the recursion 21 | depth. *) 22 | 23 | (** {1 [data] interface} *) 24 | include Data 25 | with type 'a q := 'a arbitrary 26 | and type 'a r := ?base:'a -> int -> 'a arbitrary 27 | -------------------------------------------------------------------------------- /src-ext/tpf_sexplib.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (c) 2019 David Kaloper Meršinjak. All rights reserved. 2 | See LICENSE.md. *) 3 | 4 | open Tpf 5 | 6 | let pf = Format.fprintf 7 | let failwith fmt = Format.kasprintf failwith fmt 8 | 9 | type 'a e = 'a -> Sexplib0.Sexp.t 10 | type 'a d = Sexplib0.Sexp.t -> 'a 11 | 12 | module Enc = struct 13 | 14 | module G = Generic (struct type 'a q = 'a e end) 15 | 16 | open G 17 | open V 18 | open Sexplib0.Sexp 19 | 20 | let field m i x = List [Atom (label m i); x] 21 | 22 | let rec g_to_sexp: 'a. ('a, _) view -> 'a e = fun v x -> 23 | let rec variant: 'a. _ -> _ -> ('a, _, _) spine -> _ = fun v0 acc -> function 24 | | K _ -> acc 25 | | A (s, a, f) -> variant v0 (!:f a :: acc) s 26 | | R (s, a) -> variant v0 (g_to_sexp v0 a :: acc) s in 27 | let rec record: 'a. _ -> _ -> _ -> _ -> ('a, _, _) spine -> _ = 28 | fun v0 acc m i -> function 29 | | K _ -> acc 30 | | A (s, a, f) -> record v0 (field m i (!:f a) :: acc) m (i - 1) s 31 | | R (s, a) -> record v0 (field m i (g_to_sexp v0 a) :: acc) m (i - 1) s in 32 | let m = meta v x in 33 | match spine v x, labels m, name m with 34 | | K _, _, name -> Atom name 35 | | s , 0, name -> List (Atom name :: variant v [] s) 36 | | s , _, "" -> List (record v [] m (labels m - 1) s) 37 | | s , _, name -> List (Atom name :: record v [] m (labels m - 1) s) 38 | 39 | include G.P 40 | include G.View (struct type 'a r = 'a e let gfun = g_to_sexp end) 41 | end 42 | 43 | module Smap = Map.Make (struct 44 | type t = string 45 | let compare (a: string) b = compare a b 46 | end) 47 | 48 | module Dec = struct 49 | 50 | module G = Generic (struct type 'a q = 'a d end) 51 | 52 | open G 53 | open S 54 | open Sexplib0.Sexp 55 | 56 | let err_tagged_form () = failwith "expecting atom or list with a head atom" 57 | let err_arity () = failwith "variant arity mismatch" 58 | let err_record_form () = failwith "expecting a list of record components" 59 | let err_missing_field = failwith "missing record element: %s" 60 | let err_duplicate_field = failwith "duplicate field: %s" 61 | let err_extra_fields meta = 62 | let pp ppf l _ = if not (has_label meta l) then pf ppf " %s" l in 63 | failwith "extra fields:%a" (fun ppf -> Smap.iter (pp ppf)) 64 | let of_sexp_error err sexp = 65 | raise (Of_sexp_error (Failure ("Tpf_sexplib.g_of_sexp: " ^ err), sexp)) 66 | let err_tag sexp = of_sexp_error "unexpected variant" sexp 67 | let err_record_component = 68 | of_sexp_error "bad record element: expecting ( )" 69 | 70 | (* Anamorphisms have a couple of unrolled steps to shrink the closure 71 | chains. But adding too much costs time. *) 72 | 73 | let variant goto10 s = 74 | let rec go: 'a. ('a, _, _) spine -> ('a -> _) -> _ = 75 | fun s k -> match s with 76 | | K v -> fun xs -> k v xs 77 | | A (A (A (s, a), b), c) -> 78 | go s (fun f -> function 79 | | x0::x1::x2::xs -> k (f (!:a x0) (!:b x1) (!:c x2)) xs 80 | | _ -> err_arity ()) 81 | | A (A (s, a), b) -> 82 | go s (fun f -> function 83 | | x0::x1::xs -> k (f (!:a x0) (!:b x1)) xs 84 | | _ -> err_arity ()) 85 | | A (s, a) -> 86 | go s (fun f -> function 87 | | x::xs -> k (f (!:a x)) xs 88 | | _ -> err_arity ()) 89 | | R s -> 90 | go s (fun f -> function 91 | | x::xs -> k (f (goto10 x)) xs 92 | | _ -> err_arity ()) in 93 | go s (fun x -> function [] -> x | _ -> err_arity ()) 94 | 95 | let field_map_of_sexp xs = 96 | let f map = function 97 | | List [Atom field; xs] -> 98 | if Smap.mem field map then err_duplicate_field field 99 | else Smap.add field xs map 100 | | sexp -> err_record_component sexp in 101 | List.fold_left f Smap.empty xs 102 | 103 | let get_field m i map = 104 | let f = label m i in 105 | match Smap.find_opt f map with 106 | Some x -> x | _ -> err_missing_field f 107 | 108 | let record goto10 m s = 109 | let rec go: 'a. ('a, _, _) spine -> _ -> ('a -> _) -> _ = 110 | fun s i k -> match s with 111 | | K c -> fun map -> k c map 112 | | A (A (A (s, a), b), c) -> 113 | go s (i - 3) (fun f map -> 114 | k (f (!:a (get_field m (i - 2) map)) 115 | (!:b (get_field m (i - 1) map)) 116 | (!:c (get_field m i map))) 117 | map) 118 | | A (A (s, a), b) -> 119 | go s (i - 2) (fun f map -> 120 | k (f (!:a (get_field m (i - 1) map)) 121 | (!:b (get_field m i map))) 122 | map) 123 | | A (s, a) -> go s (i - 1) (fun f map -> k (f (!:a (get_field m i map))) map) 124 | | R s -> go s (i - 1) (fun f map -> k (f (goto10 (get_field m i map))) map) 125 | in 126 | let n = labels m in 127 | let extract = go s (n - 1) (fun x _ -> x) in 128 | fun xs -> 129 | let map = field_map_of_sexp xs in 130 | if Smap.cardinal map <= n then extract map else err_extra_fields m map 131 | 132 | let g_of_sexp = function 133 | | [s, m] when name m = "" -> 134 | let rec goto10 sexp = 135 | try match sexp with 136 | | List sexps -> Lazy.force f sexps 137 | | _ -> err_record_form () 138 | with Failure err -> of_sexp_error err sexp 139 | and f = lazy (record goto10 m s) in 140 | goto10 141 | | ss -> 142 | let rec map = 143 | let f map (s, m) = 144 | Smap.add (name m) 145 | (lazy (if labels m = 0 then variant goto10 s else record goto10 m s)) 146 | map in 147 | lazy (List.fold_left f Smap.empty ss) 148 | and goto10 sexp = 149 | try match sexp with 150 | | Atom name -> 151 | Lazy.(force (Smap.find name (force map))) [] 152 | | List (Atom name :: sexp) -> 153 | Lazy.(force (Smap.find name (force map))) sexp 154 | | _ -> err_tagged_form () 155 | with | Failure err -> of_sexp_error err sexp 156 | | Not_found -> err_tag sexp in 157 | goto10 158 | 159 | include G.P 160 | include Schema (struct type 'a r = 'a d let gfun = g_of_sexp end) 161 | end 162 | 163 | let data_sexp: _ data2 = 164 | let open Sexplib0.Sexp in 165 | let atom x = Atom x and list xs = List xs in 166 | let m0 = variant 0 "Atom" 167 | and m1 = variant 0 "List" 168 | and k0 = V.K atom and k1 = V.K list in 169 | { view = (fun s sx -> 170 | V.(function Atom a -> A (k0, a, s) | List xs -> A (k1, xs, sx)), 171 | (function Atom _ -> m0 | List _ -> m1)) 172 | ; schema = S.(fun s sx -> [A (K atom, s), m0; A (K list, sx), m1]) } 173 | 174 | -------------------------------------------------------------------------------- /src-ext/tpf_sexplib.mli: -------------------------------------------------------------------------------- 1 | (* Copyright (c) 2019 David Kaloper Meršinjak. All rights reserved. 2 | See LICENSE.md. *) 3 | 4 | (** Generic Sexplib converters. 5 | 6 | Generic {{!Enc}injections} / {{!Dec}projections} between a type and 7 | {{: https://github.com/janestreet/sexplib0}Sexplib}'s {! Sexplib0.Sexp.t}. 8 | 9 | Types are mapped to S-expressions in Sexplib-compatible way. *) 10 | 11 | open Tpf 12 | open Sexplib0 13 | 14 | (** {1 Encoders} *) 15 | 16 | type 'a e = 'a -> Sexp.t 17 | (** Encoder type. *) 18 | 19 | (** Generic Sexp encoder. *) 20 | module Enc : sig 21 | include P with type 'a q := 'a e 22 | val g_to_sexp : ('a, p) view -> 'a e 23 | include Data with type 'a q := 'a e and type 'a r := 'a e 24 | end 25 | 26 | (** {1 Decoders} *) 27 | 28 | type 'a d = Sexp.t -> 'a 29 | (** Decoder type. *) 30 | 31 | (** Generic Sexp decoder. *) 32 | module Dec : sig 33 | include P with type 'a q := 'a d 34 | val g_of_sexp : ('a, p) schema -> 'a d 35 | include Data with type 'a q := 'a d and type 'a r := 'a d 36 | end 37 | 38 | (** {1 Sexp as generic objects} *) 39 | 40 | val data_sexp: (string, Sexp.t list, Sexp.t) data2 41 | (** Generic representation of {! Sexplib0.Sexp.t} itself. *) 42 | 43 | -------------------------------------------------------------------------------- /src-ppx-deriving/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (public_name ppx_deriving_tpf) 3 | (name ppx_deriving_tpf) 4 | (synopsis "[@@deriving tpf]") 5 | (modules ppx_deriving_tpf) 6 | (libraries ppx_deriving.api) 7 | (kind ppx_deriver)) 8 | 9 | (documentation 10 | (package ppx_deriving_tpf) 11 | (mld_files index)) 12 | -------------------------------------------------------------------------------- /src-ppx-deriving/index.mld: -------------------------------------------------------------------------------- 1 | {0 PPX deriving Tpf} 2 | 3 | This is a {{:https://github.com/ocaml-ppx/ppx_deriving}Ppx_deriving} plugin, 4 | deriving Tpf [data[n]] generic representations. 5 | 6 | If the type is called [t], derived representation is called [data]. Otherwise, 7 | it is called [data_TYPENAME]. 8 | 9 | For example: 10 | 11 | {v 12 | type 'a t = 13 | | K1 of int 14 | | K2 of 'a 15 | [@@deriving tpf] 16 | 17 | type ('a, 'b) tree = 18 | | Leaf of 'a 19 | | Node of ('a, 'b) tree * 'b * ('a, 'b) tree 20 | [@@deriving tpf] 21 | v} 22 | 23 | yields 24 | 25 | {v 26 | val data : (int, 'a, 'a t) Tpf.data2 27 | val data_tree : ('a, 'b, ('a, 'b) tree) Tpf.data2 28 | v} 29 | -------------------------------------------------------------------------------- /src-ppx-deriving/ppx_deriving_tpf.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (c) 2019 David Kaloper Meršinjak. All rights reserved. 2 | See LICENSE.md. *) 3 | 4 | open Longident 5 | open Asttypes 6 | open Parsetree 7 | open Ast_helper 8 | 9 | [@@@ocaml.warning "-9"] 10 | 11 | let raise_errorf = Ppx_deriving.raise_errorf 12 | let (%) f g x = f (g x) 13 | 14 | module Cmp = struct 15 | let lex cmp v1 v2 = function 0 -> cmp v1 v2 | r -> r 16 | let rec list cmp xs ys = match xs, ys with 17 | | x::xs, y::ys -> cmp x y |> lex (list cmp) xs ys 18 | | [], [] -> 0 | [], _ -> -1 | _, [] -> 1 19 | let rec core_type t1 t2 = 20 | let fv1 = Ppx_deriving.free_vars_in_core_type t1 21 | and fv2 = Ppx_deriving.free_vars_in_core_type t2 in 22 | let c = compare (List.length fv1) (List.length fv2) in 23 | if c <> 0 then c else 24 | match t1.ptyp_desc, t2.ptyp_desc with 25 | | Ptyp_object _, _ | _, Ptyp_object _ 26 | | Ptyp_class _, _ | _, Ptyp_class _ 27 | | Ptyp_variant _, _ | _, Ptyp_variant _ 28 | | Ptyp_poly _, _ | _, Ptyp_poly _ 29 | | Ptyp_package _, _ | _, Ptyp_package _ 30 | | Ptyp_extension _, _ | _, Ptyp_extension _ -> 31 | invalid_arg "FIXME: add support" 32 | | Ptyp_any, Ptyp_any -> 0 33 | | Ptyp_any, _ -> -1 34 | | Ptyp_var v1, Ptyp_var v2 -> compare v1 v2 35 | | Ptyp_var _, Ptyp_any -> 1 36 | | Ptyp_var _, _ -> -1 37 | | Ptyp_arrow (l1, a1, b1), Ptyp_arrow (l2, a2, b2) -> 38 | compare l1 l2 |> lex core_type a1 a2 |> lex core_type b1 b2 39 | | Ptyp_arrow _, (Ptyp_any | Ptyp_var _) -> 1 40 | | Ptyp_arrow _, _ -> -1 41 | | Ptyp_tuple t1, Ptyp_tuple t2 -> list core_type t1 t2 42 | | Ptyp_tuple _, (Ptyp_any | Ptyp_var _ | Ptyp_arrow _) -> 1 43 | | Ptyp_tuple _, _ -> -1 44 | | Ptyp_constr (id1, xs), Ptyp_constr (id2, ys) -> 45 | compare id1.txt id2.txt |> lex (list core_type) xs ys 46 | | Ptyp_constr _, (Ptyp_any | Ptyp_var _ | Ptyp_arrow _ | Ptyp_tuple _) -> 1 47 | | Ptyp_constr _, _ -> -1 48 | | Ptyp_alias (t1, _), Ptyp_alias (t2, _) -> core_type t1 t2 49 | | Ptyp_alias _, 50 | (Ptyp_any | Ptyp_var _ | Ptyp_arrow _ | Ptyp_tuple _ | Ptyp_constr _) -> 1 51 | end 52 | 53 | let lid ?(path = []) str = 54 | let txt = match path @ [str] with 55 | | x::xs -> List.fold_left (fun lid x -> Ldot (lid, x)) (Lident x) xs 56 | | [] -> assert false in 57 | { loc = !Ast_helper.default_loc; txt } 58 | let sid str = { txt = str; loc = !Ast_helper.default_loc } 59 | let to_lid sid = { txt = Lident sid.txt; loc = !Ast_helper.default_loc } 60 | 61 | module Smap = Map.Make (struct type t = string let compare = String.compare end) 62 | let sym_cnt = ref Smap.empty 63 | let sym ?(root = "x") () = 64 | let i = match Smap.find_opt root !sym_cnt with Some i -> i | _ -> 0 in 65 | sym_cnt := Smap.add root (i + 1) !sym_cnt; 66 | root ^ "_" ^ string_of_int i |> sid 67 | 68 | let cons fcons ftup ident = function 69 | | [] -> fcons ident None 70 | | [x] -> fcons ident (Some x) 71 | | xs -> fcons ident (Some (ftup xs)) 72 | let construct = cons Exp.construct Exp.tuple 73 | let pconstruct = cons Pat.construct Pat.tuple 74 | let const_s = Exp.constant % Const.string 75 | let const_i = Exp.constant % Const.int 76 | let rec fun_ vars expr = match vars with 77 | | [] -> expr 78 | | v::vs -> Exp.fun_ Nolabel None (Pat.var v) (fun_ vs expr) 79 | 80 | let const_list xs = 81 | let nil = lid "[]" and cons = lid "::" in 82 | List.fold_right (fun x xs -> construct cons [x; xs]) xs (construct nil []) 83 | 84 | let structure f = 85 | let defs = ref [] in 86 | let g ?(gen = true) var expr = 87 | let id = if gen then sym ~root:var () else sid var in 88 | defs := Str.value Nonrecursive [Vb.mk (Pat.var id) expr] :: !defs; 89 | Exp.ident (to_lid id) in 90 | let () = f g in 91 | List.rev !defs 92 | 93 | let iter_core_types f = function 94 | | { ptype_kind = Ptype_variant consn } -> 95 | consn |> List.iter (function 96 | | { pcd_args = Pcstr_tuple cdecls } -> 97 | List.iter f cdecls 98 | | { pcd_args = Pcstr_record ldecls } -> 99 | List.iter (fun l -> f l.pld_type) ldecls) 100 | | { ptype_kind = Ptype_record ldecls } -> 101 | List.iter (fun l -> f l.pld_type) ldecls 102 | | { ptype_kind = (Ptype_abstract | Ptype_open) } -> () 103 | 104 | let troot = function 105 | | { ptyp_desc = Ptyp_var v } -> v 106 | | { ptyp_desc = Ptyp_constr ({ txt = (Lident v|Ldot (_, v)) }, _) } -> v 107 | | _ -> "type" 108 | 109 | module Tmap = Map.Make (struct type t = core_type let compare = Cmp.core_type end) 110 | 111 | let core_types_in tdecl = 112 | let name = tdecl.ptype_name.txt 113 | and args = List.map fst tdecl.ptype_params in 114 | let recurs = function 115 | | { ptyp_desc = Ptyp_constr ({ txt = Lident name1 }, args1) } -> 116 | name = name1 && Cmp.(list core_type) args args1 = 0 117 | | _ -> false in 118 | let map = ref Tmap.empty in 119 | iter_core_types (fun t -> 120 | if not (recurs t || Tmap.mem t !map) then 121 | map := Tmap.add t (sym ~root:(troot t) ()) !map 122 | ) tdecl; 123 | let pick t = 124 | if recurs t then `Rec else 125 | `Id (Exp.ident (Tmap.find t !map |> to_lid)) in 126 | let tvs = Tmap.bindings !map in 127 | List.map fst tvs, List.map snd tvs, pick 128 | 129 | let path = ["Tpf"; "V"] 130 | let tpf_v_k = let id = lid ~path "K" in fun x -> construct id [x] 131 | let tpf_v_r = let id = lid ~path "R" in fun s a -> construct id [s; a] 132 | let tpf_v_a = let id = lid ~path "A" in fun s a f -> construct id [s; a; f] 133 | 134 | let path = ["Tpf"; "S"] 135 | let tpf_s_k = let id = lid ~path "K" in fun x -> construct id [x] 136 | let tpf_s_r = let id = lid ~path "R" in fun s -> construct id [s] 137 | let tpf_s_a = let id = lid ~path "A" in fun s f -> construct id [s; f] 138 | 139 | let tpf_variant = 140 | let id = lid ~path:["Tpf"] "variant" in 141 | fun ?labels name i -> 142 | let labels = match labels with 143 | | Some fs -> [Labelled "labels", Exp.array (List.map const_s fs)] 144 | | None -> [] in 145 | Exp.(apply (ident id) ([Nolabel, i; Nolabel, name] @ labels)) 146 | 147 | let id_data n = lid ~path:["Tpf"] ("data" ^ string_of_int n) 148 | 149 | let t_name t = t.ptype_name 150 | 151 | let raise_error_t t fmt = 152 | raise_errorf ~loc:t.ptype_loc 153 | ("Cannot derive Tpf for %s: " ^^ fmt) t.ptype_name.txt 154 | let assert_arity t types = 155 | if List.length types > 9 then 156 | raise_error_t t "it mentions more than 9 other types" 157 | 158 | let data_defn_name type_name = 159 | Ppx_deriving.mangle_type_decl (`Prefix "data") type_name 160 | 161 | let data_defn_type tdecl other_types = 162 | let arity = List.length other_types in 163 | let self = Typ.constr (t_name tdecl |> to_lid) 164 | (List.map fst tdecl.ptype_params) in 165 | Typ.constr (id_data arity) (other_types @ [self]) 166 | 167 | let labelled lbls xs = 168 | List.(combine (map (fun l -> to_lid l.pld_name) lbls) xs) 169 | 170 | (* NB -- We don't even bother to reject GADTs as that goes well into semantic 171 | territory. Instead we let the typer bomb out later. *) 172 | 173 | let str_of_type ~options:_ ~path:_ tdecl = 174 | (* parse/abort-on options *) 175 | let types, tyvars, tyref = core_types_in tdecl in 176 | assert_arity tdecl types; 177 | structure @@ fun defn -> 178 | let case ?labels ~pat ~ctor name i args = 179 | let argvars = List.map (fun _ -> sym ()) args in 180 | let argrefs = List.map (Exp.ident % to_lid) argvars in 181 | let tyrefs = List.map tyref args in 182 | let cons = defn "_cons" @@ 183 | fun_ argvars (ctor argrefs) in 184 | let vk = defn "_vk" @@ tpf_v_k cons 185 | and sk = defn "_sk" @@ tpf_s_k cons in 186 | let meta = defn "_meta" @@ 187 | tpf_variant ?labels (const_s name) (const_i i) in 188 | let mcase = Exp.case (pat (List.map (fun _ -> Pat.any ()) args)) meta 189 | and vcase = 190 | Exp.case (pat (List.map Pat.var argvars)) 191 | (List.fold_left 192 | (fun e -> function v, `Rec -> tpf_v_r e v | v, `Id x -> tpf_v_a e v x) 193 | vk (List.combine argrefs tyrefs)) 194 | and scase = 195 | Exp.tuple [ 196 | List.fold_left 197 | (fun e -> function `Rec -> tpf_s_r e | `Id x -> tpf_s_a e x) 198 | sk tyrefs 199 | ; meta ] in 200 | vcase, mcase, scase 201 | in 202 | let cases = match tdecl.ptype_kind with 203 | | Ptype_abstract -> raise_error_t tdecl "is abstract" 204 | | Ptype_open -> raise_error_t tdecl "is open" 205 | | Ptype_variant cdecls -> 206 | cdecls |> List.mapi (fun i { pcd_name; pcd_args } -> 207 | let ctor_id = to_lid pcd_name in 208 | match pcd_args with 209 | | Pcstr_tuple args -> 210 | case pcd_name.txt i args 211 | ~pat:(pconstruct ctor_id) ~ctor:(construct ctor_id) 212 | | Pcstr_record lbls -> 213 | let pat vars = 214 | pconstruct ctor_id [Pat.record (labelled lbls vars) Closed] 215 | and ctor vars = 216 | construct ctor_id [Exp.record (labelled lbls vars) None] in 217 | case pcd_name.txt i ~pat ~ctor 218 | ~labels:(List.map (fun l -> l.pld_name.txt) lbls) 219 | (List.map (fun l -> l.pld_type) lbls)) 220 | | Ptype_record lbls -> 221 | let pat vars = Pat.record (labelled lbls vars) Closed 222 | and ctor vars = Exp.record (labelled lbls vars) None in 223 | [ case "" 0 ~pat ~ctor 224 | (List.map (fun l -> l.pld_type) lbls) 225 | ~labels:(List.map (fun l -> l.pld_name.txt) lbls) ] 226 | in 227 | let vcases = List.map (fun (v, _, _) -> v) cases 228 | and mcases = List.map (fun (_, m, _) -> m) cases 229 | and scases = List.map (fun (_, _, s) -> s) cases in 230 | let view = defn "_view" @@ 231 | fun_ tyvars Exp.(tuple [function_ vcases; function_ mcases]) in 232 | let schema = defn "_schema" @@ 233 | fun_ tyvars (const_list scases) in 234 | let _ = defn ~gen:false (data_defn_name tdecl) 235 | Exp.(constraint_ 236 | (record [lid "view", view; lid "schema", schema] None) 237 | (data_defn_type tdecl types)) in 238 | () 239 | 240 | let sig_of_type ~options:_ ~path:_ tdecl = 241 | let types, _, _ = core_types_in tdecl in 242 | assert_arity tdecl types; 243 | match tdecl.ptype_kind with 244 | | Ptype_abstract -> raise_error_t tdecl "is abstract" 245 | | Ptype_open -> raise_error_t tdecl "is open" 246 | | Ptype_variant _ | Ptype_record _ -> 247 | Sig.value @@ 248 | Val.mk (data_defn_name tdecl |> sid) (data_defn_type tdecl types) 249 | 250 | let () = 251 | Ppx_deriving.(register @@ create "tpf" 252 | ~type_decl_str: (fun ~options ~path tdecls -> 253 | List.(map (str_of_type ~options ~path) tdecls |> concat)) 254 | ~type_decl_sig: (fun ~options ~path tdecls -> 255 | List.map (sig_of_type ~options ~path) tdecls) 256 | ()) 257 | -------------------------------------------------------------------------------- /src-ppx-deriving/ppx_deriving_tpf.mli: -------------------------------------------------------------------------------- 1 | (* Copyright (c) 2019 David Kaloper Meršinjak. All rights reserved. 2 | See LICENSE.md. *) 3 | 4 | (** [Ppx_deriving] plugin, that provides [[@@deriving tpf]] annotation. *) 5 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (public_name tpf) 3 | (modules tpf tpf_std) 4 | (synopsis "Minimalist datatype-generic programming") 5 | (wrapped false)) 6 | 7 | (documentation 8 | (package tpf) 9 | (mld_files index)) 10 | -------------------------------------------------------------------------------- /src/index.mld: -------------------------------------------------------------------------------- 1 | {0 Tpf — Tagless/Trivial polytypic functions} 2 | 3 | Tpf is a simple and idiomatic library for datatype-generic programming in OCaml. 4 | 5 | {1:api API} 6 | 7 | Tpf core. 8 | 9 | {!modules: Tpf} 10 | 11 | Standard generic types and functions. 12 | 13 | {!modules: Tpf_std} 14 | 15 | {1:quick_start Quick start} 16 | 17 | {2 Instantiating generic functions} 18 | 19 | To make use of Tpf, you always need to combine a generic function with generic 20 | {{!Tpf.data}data representation}. 21 | 22 | Representations have an arity, which depends on the number of other types the type 23 | in question contains. For instance, {!Tpf_std.list} is [('a, 'a list) data1]. 24 | Its arity is 1, as lists only contain one other type. 25 | 26 | To instantiate a function over type [t], you need its {{!Tpf.data}[data]}, the 27 | generic function {{!Tpf.Data}entry-point} of the 28 | corresponding arity, and arity-many other functions to take 29 | care of inner types. 30 | 31 | This creates a printer for [int] lists: 32 | 33 | {v 34 | let pp_int_list : int list Fmt.t = 35 | Tpf_fmt.data1 Tpf_std.list Format.pp_print_int 36 | v} 37 | 38 | Pulling out the printer for contained type yields a polymorphic combinator: 39 | 40 | {v 41 | let pp_list : 'a Fmt.t -> 'a list Fmt.t = 42 | fun pp_v -> Tpf_fmt.data1 Tpf_std.list pp_v 43 | v} 44 | 45 | {!Tpf_std.result} is [('a, 'b, ('a, 'b) result) data2]: 46 | 47 | {v 48 | let pp_result : 'a Fmt.t -> ('a, string) result Fmt.t = 49 | fun pp_v -> Tpf_fmt.data2 Tpf_std.result pp_v Format.pp_print_string 50 | v} 51 | 52 | The basic idea is that — in the absence of type-based dispatch — the user has to 53 | explicitly specify what happens when the generic function comes across other 54 | types inside and has to cross the type boundary. This is done by simply 55 | supplying the generic function with the functions to call at these types. 56 | 57 | This is the mechanism that gives Tpf a flavour idiomatic to OCaml: as is usually 58 | the case with type-based combinatory libraries, it is the user's responsibility 59 | to parameterise higher-order functions corresponding to higher-kinded types. 60 | There are no additional dispatch schemes involved. 61 | 62 | {2 Equipping types with generic representation} 63 | 64 | To use a generic function on a type, you need its {{!Tpf.data}data}. 65 | 66 | This can be automated with [ppx_deriving_tpf]: 67 | 68 | {v 69 | type 'a t = | X 70 | | Y of string * 'a 71 | [@@deriving tpf] 72 | v} 73 | 74 | Otherwise, you need to construct a pair of functions of arity [n] and pack them 75 | up in a {{!Tpf.data}[data[n]]} value. 76 | 77 | {v 78 | type 'a t = | X 79 | | Y of string * 'a 80 | 81 | open Tpf 82 | 83 | let cons_y string a = Y (string, a) 84 | 85 | let m0 = variant 0 "X" 86 | let m1 = variant 1 "Y" 87 | 88 | let t: (string, 'a, 'a t) data2 = 89 | { view = (fun f_string f_a -> 90 | (function 91 | | X -> V.K X 92 | | Y (string, a) -> V.(A (A (K cons_y, string, f_string), a, f_a))), 93 | (function X -> m0 | Y _ -> m1)) 94 | ; schema = fun f_string f_a -> 95 | [ S.K X, m0; 96 | S.(A (A (K cons_y, f_string), f_a)), m1 ] 97 | } 98 | v} 99 | 100 | Both functions encode values as an AST of (curried) constructor applications; 101 | the {{! Tpf.view}view} function unpacks the value into a 102 | {{! Tpf.V.spine}view spine}, while the {{! Tpf.schema}schema} function 103 | constructs one {{! Tpf.S.spine}schema spine} for each constructor in the type. 104 | 105 | Schematically, 106 | 107 | {v 108 | Y ("foo", 13) 109 | v} 110 | 111 | has the structure 112 | 113 | {v 114 | @ 115 | / \ 116 | @ 13 117 | / \ 118 | Y "foo" 119 | v} 120 | 121 | so the individual value is encoded as the view spine 122 | 123 | {v 124 | A ─┬─ A ─┬─ K ─ (fun s n -> Y (s, n)) 125 | │ ├─ "foo" 126 | │ ╰─ f_string 127 | ├─ 13 128 | ╰─ f_a 129 | v} 130 | 131 | while the type itself is encoded as schema spines 132 | 133 | {v 134 | K ─ X 135 | 136 | A ─┬─ A ─┬─ K ─ (fun s n -> Y (s, n)) 137 | │ ╰─ f_string 138 | ╰─ f_a 139 | v} 140 | 141 | Spines have a {{! Tpf.meta}meta block} attached, which provides additional meta 142 | data about the constructor. 143 | 144 | {2 Writing generic functions} 145 | 146 | These come in two flavours: consumers and producers. 147 | 148 | Iterators, for instance, are consumers. Consumers work on a 149 | {{! Tpf.view}[view]}, and discover the structure of a single value by 150 | traversing the {{! Tpf.V.spine}view spine}: 151 | 152 | {v 153 | open Tpf 154 | module G = Tpf.Generic (struct type 'a q = 'a -> unit end) 155 | 156 | let rec g_iter : ('a, G.p) view -> 'a -> unit = 157 | fun view x -> 158 | let rec go: 'a. ('a, _, _) V.spine -> unit = 159 | function 160 | | V.K _ -> () 161 | | V.A (s, a, f_a) -> go s; G.(!:)f_a a 162 | | V.R (s, a) -> go s; g_iter view a 163 | in 164 | go (spine view x) 165 | v} 166 | 167 | While random generators are producers. Producers work on a 168 | {{! Tpf.schema}[schema]}, and discover the structure of each possible 169 | constructor by traversing the {{! Tpf.S.spine}schema spine}: 170 | 171 | {v 172 | let sample : 'a list -> 'a = 173 | fun xs -> List.(nth xs (length xs |> Random.int)) 174 | 175 | open Tpf 176 | module G = Generic (struct type 'a q = unit -> 'a end) 177 | 178 | let rec g_random : ('a, G.p) schema -> unit -> 'a = 179 | fun schema () -> 180 | let rec go: 'a. ('a, _, _) S.spine -> 'a = 181 | function 182 | | S.K f -> f 183 | | S.A (s, f_a) -> go s G.(!:f_a ()) 184 | | S.R s -> go s (g_random schema ()) 185 | in 186 | go (sample schema |> spine) 187 | v} 188 | 189 | A little complication arises from the fact that spines must be able to contain 190 | any sort of function for the corresponding types. In other words, spines must 191 | exhibit higher-kinded polymorphism. 192 | 193 | We encode this using the {{: https://github.com/ocamllabs/higher}higher} trick. 194 | This is why each generic function needs to instantiate {! Tpf.Generic}: it 195 | provides the {{! Tpf.Generic.p}proxy type} for that particular function, and the 196 | corresponding injection and projection. 197 | 198 | The generic function itself will use projection, to fetch the inner {e query} 199 | functions; and the caller will use injection, to pack them into spines. 200 | 201 | To simplify usage, we can top off the definitions with 202 | 203 | {v 204 | include G.View (struct 205 | type 'a r = 'a -> unit 206 | let gfun = g_iter 207 | end) 208 | v} 209 | 210 | or 211 | 212 | {v 213 | include G.Schema (struct 214 | type 'a r = unit -> 'a 215 | let gfun = g_random 216 | end) 217 | v} 218 | 219 | which will create a family of {{!Tpf.data}[data[n]]} functions, like the ones we 220 | have been using at the beginning: 221 | 222 | {v 223 | let iter_list : ('a -> unit) -> 'a list -> unit = 224 | fun i_v = data1 Tpf_std.list i_v 225 | v} 226 | 227 | {v 228 | let random_result : (unit -> 'a) -> (unit -> 'e) -> unit -> ('a, 'e) result = 229 | fun r_a r_e -> data2 Tpf_std.result r_a r_e 230 | v} 231 | -------------------------------------------------------------------------------- /src/tpf.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (c) 2019 David Kaloper Meršinjak. All rights reserved. 2 | See LICENSE.md. *) 3 | 4 | (* View types. *) 5 | 6 | type (+'a, +'f) app 7 | 8 | module V = struct 9 | type (+_, _, +_) spine = 10 | | K : 'a -> ('a, 'r, 'q) spine 11 | | A : ('a -> 'b, 'r, 'q) spine * 'a * ('a, 'q) app -> ('b, 'r, 'q) spine 12 | | R : ('r -> 'b, 'r, 'q) spine * 'r -> ('b, 'r, 'q) spine 13 | end 14 | 15 | module S = struct 16 | type (+_, _, +_) spine = 17 | | K : 'a -> ('a, 'r, 'q) spine 18 | | A : ('a -> 'b, 'r, 'q) spine * ('a, 'q) app -> ('b, 'r, 'q) spine 19 | | R : ('r -> 'b, 'r, 'q) spine -> ('b, 'r, 'q) spine 20 | end 21 | 22 | type meta = { index : int; name : string; labels : string array } 23 | 24 | type ('a, +'q) view = ('a -> ('a, 'a, 'q) V.spine) * ('a -> meta) 25 | type ('a, +'q) schema = (('a, 'a, 'q) S.spine * meta) list 26 | 27 | let spine = fst and meta = snd 28 | 29 | (* Generic representations of n-point types -- "generics." *) 30 | 31 | type ('q, 'res) app0 = 'res 32 | type ('a, 'q, 'res) app1 = 33 | ('a, 'q) app -> ('q, 'res) app0 34 | type ('a, 'b, 'q, 'res) app2 = 35 | ('a, 'q) app -> ('b, 'q, 'res) app1 36 | type ('a, 'b, 'c, 'q, 'res) app3 = 37 | ('a, 'q) app -> ('b, 'c, 'q, 'res) app2 38 | type ('a, 'b, 'c, 'd, 'q, 'res) app4 = 39 | ('a, 'q) app -> ('b, 'c, 'd, 'q, 'res) app3 40 | type ('a, 'b, 'c, 'd, 'e, 'q, 'res) app5 = 41 | ('a, 'q) app -> ('b, 'c, 'd, 'e, 'q, 'res) app4 42 | type ('a, 'b, 'c, 'd, 'e, 'f, 'q, 'res) app6 = 43 | ('a, 'q) app -> ('b, 'c, 'd, 'e, 'f, 'q, 'res) app5 44 | type ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'q, 'res) app7 = 45 | ('a, 'q) app -> ('b, 'c, 'd, 'e, 'f, 'g, 'q, 'res) app6 46 | type ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h, 'q, 'res) app8 = 47 | ('a, 'q) app -> ('b, 'c, 'd, 'e, 'f, 'g, 'h, 'q, 'res) app7 48 | type ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h, 'i, 'q, 'res) app9 = 49 | ('a, 'q) app -> ('b, 'c, 'd, 'e, 'f, 'g, 'h, 'i, 'q, 'res) app8 50 | 51 | type 'x data0 = 52 | { view : 'q. ('x, 'q) view 53 | ; schema : 'q. ('x, 'q) schema } 54 | type ('a, 'x) data1 = 55 | { view : 'q. ('a, 'q, ('x, 'q) view) app1 56 | ; schema : 'q. ('a, 'q, ('x, 'q) schema) app1 } 57 | type ('a, 'b, 'x) data2 = 58 | { view : 'q. ('a, 'b, 'q, ('x, 'q) view) app2 59 | ; schema : 'q. ('a, 'b, 'q, ('x, 'q) schema) app2 } 60 | type ('a, 'b, 'c, 'x) data3 = 61 | { view : 'q. ('a, 'b, 'c, 'q, ('x, 'q) view) app3 62 | ; schema : 'q. ('a, 'b, 'c, 'q, ('x, 'q) schema) app3 } 63 | type ('a, 'b, 'c, 'd, 'x) data4 = 64 | { view : 'q. ('a, 'b, 'c, 'd, 'q, ('x, 'q) view) app4 65 | ; schema : 'q. ('a, 'b, 'c, 'd, 'q, ('x, 'q) schema) app4 } 66 | type ('a, 'b, 'c, 'd, 'e, 'x) data5 = 67 | { view : 'q. ('a, 'b, 'c, 'd, 'e, 'q, ('x, 'q) view) app5 68 | ; schema : 'q. ('a, 'b, 'c, 'd, 'e, 'q, ('x, 'q) schema) app5 } 69 | type ('a, 'b, 'c, 'd, 'e, 'f, 'x) data6 = 70 | { view : 'q. ('a, 'b, 'c, 'd, 'e, 'f, 'q, ('x, 'q) view) app6 71 | ; schema : 'q. ('a, 'b, 'c, 'd, 'e, 'f, 'q, ('x, 'q) schema) app6 } 72 | type ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'x) data7 = 73 | { view : 'q. ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'q, ('x, 'q) view) app7 74 | ; schema : 'q. ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'q, ('x, 'q) schema) app7 } 75 | type ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h, 'x) data8 = 76 | { view : 'q. ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h, 'q, ('x, 'q) view) app8 77 | ; schema : 'q. ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h, 'q, ('x, 'q) schema) app8 } 78 | type ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h, 'i, 'x) data9 = 79 | { view : 'q. ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h, 'i, 'q, ('x, 'q) view) app9 80 | ; schema : 'q. ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h, 'i, 'q, ('x, 'q) schema) app9 } 81 | 82 | (* Client-facing exports. *) 83 | 84 | module type P = sig 85 | type p 86 | type 'a q 87 | val (!) : 'a q -> ('a, p) app 88 | end 89 | 90 | module type Data = sig 91 | 92 | type 'a q 93 | type 'a r 94 | val data0 : 'x data0 -> 95 | 'x r 96 | val data1 : ('a, 'x) data1 -> 97 | 'a q -> 'x r 98 | val data2 : ('a, 'b, 'x) data2 -> 99 | 'a q -> 'b q -> 'x r 100 | val data3 : ('a, 'b, 'c, 'x) data3 -> 101 | 'a q -> 'b q -> 'c q -> 'x r 102 | val data4 : ('a, 'b, 'c, 'd, 'x) data4 -> 103 | 'a q -> 'b q -> 'c q -> 'd q -> 'x r 104 | val data5 : ('a, 'b, 'c, 'd, 'e, 'x) data5 -> 105 | 'a q -> 'b q -> 'c q -> 'd q -> 'e q -> 'x r 106 | val data6 : ('a, 'b, 'c, 'd, 'e, 'f, 'x) data6 -> 107 | 'a q -> 'b q -> 'c q -> 'd q -> 'e q -> 'f q -> 'x r 108 | val data7 : ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'x) data7 -> 109 | 'a q -> 'b q -> 'c q -> 'd q -> 'e q -> 'f q -> 'g q -> 'x r 110 | val data8 : ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h, 'x) data8 -> 111 | 'a q -> 'b q -> 'c q -> 'd q -> 'e q -> 'f q -> 'g q -> 'h q -> 112 | 'x r 113 | val data9 : ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h, 'i, 'x) data9 -> 114 | 'a q -> 'b q -> 'c q -> 'd q -> 'e q -> 'f q -> 'g q -> 'h q -> 115 | 'i q -> 'x r 116 | end 117 | 118 | (* [(_, _) app] instantiation. *) 119 | 120 | module Generic (Q: sig type 'a q end) = struct 121 | 122 | type 'a q = 'a Q.q 123 | 124 | type p (* The "brand". *) 125 | external (!) : 'a q -> ('a, p) app = "%identity" 126 | external (!:) : ('a, p) app -> 'a q = "%identity" 127 | 128 | module P = struct 129 | type nonrec p = p 130 | let (!) = (!) 131 | end 132 | 133 | let app0 x y = x y 134 | let app1 x y a = x (y !a) 135 | let app2 x y a b = x (y !a !b) 136 | let app3 x y a b c = x (y !a !b !c) 137 | let app4 x y a b c d = x (y !a !b !c !d) 138 | let app5 x y a b c d e = x (y !a !b !c !d !e) 139 | let app6 x y a b c d e f = x (y !a !b !c !d !e !f) 140 | let app7 x y a b c d e f g = x (y !a !b !c !d !e !f !g) 141 | let app8 x y a b c d e f g h = x (y !a !b !c !d !e !f !g !h) 142 | let app9 x y a b c d e f g h i = x (y !a !b !c !d !e !f !g !h !i) 143 | 144 | module View (F: sig type 'a r val gfun: ('a, p) view -> 'a r end): 145 | Data with type 'a q := 'a q and type 'a r := 'a F.r = struct 146 | let data0 (d: _ data0) = app0 F.gfun d.view 147 | let data1 (d: _ data1) = app1 F.gfun d.view 148 | let data2 (d: _ data2) = app2 F.gfun d.view 149 | let data3 (d: _ data3) = app3 F.gfun d.view 150 | let data4 (d: _ data4) = app4 F.gfun d.view 151 | let data5 (d: _ data5) = app5 F.gfun d.view 152 | let data6 (d: _ data6) = app6 F.gfun d.view 153 | let data7 (d: _ data7) = app7 F.gfun d.view 154 | let data8 (d: _ data8) = app8 F.gfun d.view 155 | let data9 (d: _ data9) = app9 F.gfun d.view 156 | end 157 | 158 | module Schema (F: sig type 'a r val gfun: ('a, p) schema -> 'a r end): 159 | Data with type 'a q := 'a q and type 'a r := 'a F.r = struct 160 | let data0 (d: _ data0) = app0 F.gfun d.schema 161 | let data1 (d: _ data1) = app1 F.gfun d.schema 162 | let data2 (d: _ data2) = app2 F.gfun d.schema 163 | let data3 (d: _ data3) = app3 F.gfun d.schema 164 | let data4 (d: _ data4) = app4 F.gfun d.schema 165 | let data5 (d: _ data5) = app5 F.gfun d.schema 166 | let data6 (d: _ data6) = app6 F.gfun d.schema 167 | let data7 (d: _ data7) = app7 F.gfun d.schema 168 | let data8 (d: _ data8) = app8 F.gfun d.schema 169 | let data9 (d: _ data9) = app9 F.gfun d.schema 170 | end 171 | end 172 | 173 | (* pp *) 174 | 175 | let invalid_arg fmt = Format.kasprintf invalid_arg fmt 176 | 177 | let pf = Format.fprintf 178 | let pp_string = Format.pp_print_string 179 | let pp_iter ?(sep = fun ppf () -> pf ppf ";@ ") iter pp ppf v = 180 | let first = ref true in 181 | let f x = if !first then first := false else sep ppf (); pp ppf x in 182 | iter f v 183 | 184 | let pp_meta ppf m = 185 | let pp_name ppf = function "" -> () | name -> pf ppf "%s " name 186 | and pp_body ppf = function 187 | | [||] -> pp_string ppf "(...)" 188 | | fs -> pf ppf "{%a}" (pp_iter Array.iter pp_string) fs in 189 | pf ppf "@[<1>%a%a@]" pp_name m.name pp_body m.labels 190 | 191 | (* Metablock stuff. *) 192 | 193 | let variant ?(labels = [||]) index name = { name; index; labels } 194 | let record labels = { name = ""; index = 0; labels } 195 | 196 | let name m = m.name 197 | let index m = m.index 198 | let labels m = Array.length m.labels 199 | let has_label m x = Array.exists (String.equal x) m.labels 200 | 201 | let err_label i m = invalid_arg "Tpf: invalid label #%d of %a" i pp_meta m 202 | let label ({ labels; _ } as m) i = 203 | if 0 <= i && i < Array.length labels then 204 | Array.unsafe_get labels i 205 | else err_label i m 206 | -------------------------------------------------------------------------------- /src/tpf.mli: -------------------------------------------------------------------------------- 1 | (* Copyright (c) 2019 David Kaloper Meršinjak. All rights reserved. 2 | See LICENSE.md. *) 3 | 4 | (** [Tpf] — Tagless/Trivial polytypic functions *) 5 | 6 | (** {1:over Overview:} 7 | 8 | {ul 9 | {- {{!core}Core} only contains types: 10 | {ul 11 | {- {!V} and {!S} — View and Schema spines.} 12 | {- {!view} and {!schema} — View and Schema functions.} 13 | {- {!meta} — Constructor meta data.}}} 14 | {- {{!data}[data[n]]} is the interface to types.} 15 | {- {!Generic} provides support for writing generic functions.} 16 | {- {!P}, {!Data} are signatures to ease exporting generic functions.}} 17 | *) 18 | 19 | (** {1:core The Core} *) 20 | 21 | type (+'a, +'f) app 22 | (** Type representing type application of [f] to [a] in the style of {{: 23 | https://github.com/ocamllabs/higher}higher}. *) 24 | 25 | (* A {e spine} is a typed sequence of one-step constructor applications. 26 | Two types of spines, {{!V}view} and {{!S}schema}, are at the heart of 27 | generic representation. *) 28 | 29 | (** [V] is for {!view}. 30 | 31 | An instantiated {e view spine} encodes a value and its pointwise queries. 32 | 33 | The type parameters are: 34 | {ul 35 | {- [a] — the type this spine represents;} 36 | {- [r] — the type of recursive points; and} 37 | {- [q] — the type constructor for queries.}} *) 38 | module V : sig 39 | type (+_, _, +_) spine = 40 | | K : 'a -> ('a, 'r, 'q) spine 41 | | A : ('a -> 'b, 'r, 'q) spine * 'a * ('a, 'q) app -> ('b, 'r, 'q) spine 42 | | R : ('r -> 'b, 'r, 'q) spine * 'r -> ('b, 'r, 'q) spine 43 | end 44 | 45 | (** [S] is for {!schema}. 46 | 47 | An instantiated {e schema spine} encodes type constructors and their 48 | pointwise queries. 49 | 50 | The type parameters are: 51 | {ul 52 | {- [a] — the type this spine represents;} 53 | {- [r] — the type of recursive points; and} 54 | {- [q] — the type constructor for queries.}} *) 55 | module S : sig 56 | type (+_, _, +_) spine = 57 | | K : 'a -> ('a, 'r, 'q) spine 58 | | A : ('a -> 'b, 'r, 'q) spine * ('a, 'q) app -> ('b, 'r, 'q) spine 59 | | R : ('r -> 'b, 'r, 'q) spine -> ('b, 'r, 'q) spine 60 | end 61 | 62 | type meta 63 | (** Meta blocks collect extra information about a constructor. *) 64 | 65 | type ('a, +'q) view = ('a -> ('a, 'a, 'q) V.spine) * ('a -> meta) 66 | (** Generic representation for consumer functions. 67 | It can {e view} a value as a {!V.spine} or {!meta}. 68 | 69 | This [gfoldl] in {e SYB}. *) 70 | 71 | type ('a, +'q) schema = (('a, 'a, 'q) S.spine * meta) list 72 | (** Generic representation for producer functions. 73 | It encodes the set of constructors of a type. 74 | 75 | 76 | This is [gunfold] in {e SYB}. *) 77 | 78 | val spine : 'a * 'b -> 'a 79 | (** [spine] is [fst]. Spine is always first. *) 80 | 81 | val meta : 'a * 'b -> 'b 82 | (** [meta] is [snd]. Meta block is always second. *) 83 | 84 | (** {2:appn App} *) 85 | 86 | (** [(t1, ..., q, res) app[n]] is an alias for [n]-ary functions 87 | [(t1, q) app -> ... -> res]. *) 88 | 89 | type ('q, 'res) app0 = 'res 90 | type ('a, 'q, 'res) app1 = 91 | ('a, 'q) app -> ('q, 'res) app0 92 | type ('a, 'b, 'q, 'res) app2 = 93 | ('a, 'q) app -> ('b, 'q, 'res) app1 94 | type ('a, 'b, 'c, 'q, 'res) app3 = 95 | ('a, 'q) app -> ('b, 'c, 'q, 'res) app2 96 | type ('a, 'b, 'c, 'd, 'q, 'res) app4 = 97 | ('a, 'q) app -> ('b, 'c, 'd, 'q, 'res) app3 98 | type ('a, 'b, 'c, 'd, 'e, 'q, 'res) app5 = 99 | ('a, 'q) app -> ('b, 'c, 'd, 'e, 'q, 'res) app4 100 | type ('a, 'b, 'c, 'd, 'e, 'f, 'q, 'res) app6 = 101 | ('a, 'q) app -> ('b, 'c, 'd, 'e, 'f, 'q, 'res) app5 102 | type ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'q, 'res) app7 = 103 | ('a, 'q) app -> ('b, 'c, 'd, 'e, 'f, 'g, 'q, 'res) app6 104 | type ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h, 'q, 'res) app8 = 105 | ('a, 'q) app -> ('b, 'c, 'd, 'e, 'f, 'g, 'h, 'q, 'res) app7 106 | type ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h, 'i, 'q, 'res) app9 = 107 | ('a, 'q) app -> ('b, 'c, 'd, 'e, 'f, 'g, 'h, 'i, 'q, 'res) app8 108 | 109 | (** {1:data Data} *) 110 | 111 | (** [data[n]] packages up the {!view} and {!schema} for a single type which 112 | contains [n] other types. This is the easiest generic representation to 113 | handle, but it is not necessary. 114 | 115 | Generically representable types should export their [data]. 116 | 117 | Generic functions should export a [data]-based interface, together with a 118 | naked function that operates directly on a {!view} or {!schema}. *) 119 | 120 | type 'x data0 = 121 | { view : 'q. ('x, 'q) view 122 | ; schema : 'q. ('x, 'q) schema } 123 | type ('a, 'x) data1 = 124 | { view : 'q. ('a, 'q, ('x, 'q) view) app1 125 | ; schema : 'q. ('a, 'q, ('x, 'q) schema) app1 } 126 | type ('a, 'b, 'x) data2 = 127 | { view : 'q. ('a, 'b, 'q, ('x, 'q) view) app2 128 | ; schema : 'q. ('a, 'b, 'q, ('x, 'q) schema) app2 } 129 | type ('a, 'b, 'c, 'x) data3 = 130 | { view : 'q. ('a, 'b, 'c, 'q, ('x, 'q) view) app3 131 | ; schema : 'q. ('a, 'b, 'c, 'q, ('x, 'q) schema) app3 } 132 | type ('a, 'b, 'c, 'd, 'x) data4 = 133 | { view : 'q. ('a, 'b, 'c, 'd, 'q, ('x, 'q) view) app4 134 | ; schema : 'q. ('a, 'b, 'c, 'd, 'q, ('x, 'q) schema) app4 } 135 | type ('a, 'b, 'c, 'd, 'e, 'x) data5 = 136 | { view : 'q. ('a, 'b, 'c, 'd, 'e, 'q, ('x, 'q) view) app5 137 | ; schema : 'q. ('a, 'b, 'c, 'd, 'e, 'q, ('x, 'q) schema) app5 } 138 | type ('a, 'b, 'c, 'd, 'e, 'f, 'x) data6 = 139 | { view : 'q. ('a, 'b, 'c, 'd, 'e, 'f, 'q, ('x, 'q) view) app6 140 | ; schema : 'q. ('a, 'b, 'c, 'd, 'e, 'f, 'q, ('x, 'q) schema) app6 } 141 | type ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'x) data7 = 142 | { view : 'q. ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'q, ('x, 'q) view) app7 143 | ; schema : 'q. ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'q, ('x, 'q) schema) app7 } 144 | type ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h, 'x) data8 = 145 | { view : 'q. ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h, 'q, ('x, 'q) view) app8 146 | ; schema : 'q. ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h, 'q, ('x, 'q) schema) app8 } 147 | type ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h, 'i, 'x) data9 = 148 | { view : 'q. ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h, 'i, 'q, ('x, 'q) view) app9 149 | ; schema : 'q. ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h, 'i, 'q, ('x, 'q) schema) app9 } 150 | 151 | (** {1 Writing generic functions} *) 152 | 153 | (** Packages up the basic user-facing part of a {!Generic} instance. 154 | 155 | As access to [p] and the injection are necessary to use a generic function, 156 | this signature gets exported a lot. *) 157 | module type P = sig 158 | type 'a q 159 | (** Query type. *) 160 | 161 | type p 162 | (** [q] proxy. *) 163 | 164 | val (!) : 'a q -> ('a, p) app 165 | (** Injection. *) 166 | end 167 | 168 | (** Packages up {{!data}data}-based entry points to a generic function. *) 169 | module type Data = sig 170 | 171 | type 'a q 172 | (** The {e query} type. 173 | 174 | This is what we need at each inner type that we encounter. *) 175 | 176 | type 'a r 177 | (** The overall {e result} type. 178 | 179 | It's often the same as {!q}, but it doesn't have to be. *) 180 | 181 | (** The functions [data[n]] are variants of the same generic function, 182 | operating on the corresponding {{!Tpf.data}data} representations: *) 183 | 184 | val data0 : 'x data0 -> 185 | 'x r 186 | val data1 : ('a, 'x) data1 -> 187 | 'a q -> 'x r 188 | val data2 : ('a, 'b, 'x) data2 -> 189 | 'a q -> 'b q -> 'x r 190 | val data3 : ('a, 'b, 'c, 'x) data3 -> 191 | 'a q -> 'b q -> 'c q -> 'x r 192 | val data4 : ('a, 'b, 'c, 'd, 'x) data4 -> 193 | 'a q -> 'b q -> 'c q -> 'd q -> 'x r 194 | val data5 : ('a, 'b, 'c, 'd, 'e, 'x) data5 -> 195 | 'a q -> 'b q -> 'c q -> 'd q -> 'e q -> 'x r 196 | val data6 : ('a, 'b, 'c, 'd, 'e, 'f, 'x) data6 -> 197 | 'a q -> 'b q -> 'c q -> 'd q -> 'e q -> 'f q -> 'x r 198 | val data7 : ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'x) data7 -> 199 | 'a q -> 'b q -> 'c q -> 'd q -> 'e q -> 'f q -> 'g q -> 'x r 200 | val data8 : ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h, 'x) data8 -> 201 | 'a q -> 'b q -> 'c q -> 'd q -> 'e q -> 'f q -> 'g q -> 'h q -> 202 | 'x r 203 | val data9 : ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h, 'i, 'x) data9 -> 204 | 'a q -> 'b q -> 'c q -> 'd q -> 'e q -> 'f q -> 'g q -> 'h q -> 205 | 'i q -> 'x r 206 | end 207 | 208 | (** Interface between the outside world and a [spine]. 209 | 210 | It contains only three necessary symbols: 211 | 212 | {ul 213 | {- {e users} need [p] and [!], to inject from ['a Q.q] to [('a, p) app]; 214 | while} 215 | {- {e implementors} need [p] and [!:], to project from [('a, p) app] to 216 | ['a Q.q].}} 217 | 218 | The rest of this module is provided for the implementor's convenience. 219 | 220 | Minimal complete interface to a generic function consists of [p], [!], and 221 | a function that looks like one of 222 | {[val f: ('a, p) view -> ... -> 'a -> ... 223 | val g: ('a, p) schema -> ...]} 224 | 225 | A more complete interface adds a family of functions like 226 | 227 | {[val f0 : 'x data0 -> ... 228 | val f1 : ('a, 'x) data1 -> 'a Q.q -> ... 229 | val f2 : ('a, 'b, 'x) data2 -> 'a Q.q -> 'b Q.q -> ... 230 | ... 231 | ]} 232 | 233 | These can be 234 | 235 | {ul 236 | {- produced with the {!View} and {!Schema} functors, which have pre-canned 237 | module types, but fixed names; or} 238 | {- constructed manually, perhaps by using the functions {{!app0}[app[n]]}, 239 | with their signature spelled out by hand.}} 240 | *) 241 | module Generic (Q: sig type 'a q end) : sig 242 | 243 | type 'a q = 'a Q.q 244 | (** Query type for this (group of) function(s). It gives the action to be done 245 | for each constructor argument. *) 246 | 247 | type p 248 | (** Proxy representing [Q.q]. 249 | 250 | [p]s exists only to embed ['a Q.q] in a [spine]. 251 | 252 | The only possible operations involving [p] are the two below. *) 253 | 254 | external (!) : 'a q -> ('a, p) app = "%identity" 255 | (** [!x] injects into the proxy. *) 256 | 257 | external (!:) : ('a, p) app -> 'a q = "%identity" 258 | (** [!:x] projects from the proxy. *) 259 | 260 | module P: P with type p = p and type 'a q := 'a Q.q 261 | (** Groups {!p} and {!(!)}, above, for easy export. *) 262 | 263 | (** Functors generating a [data[n]] interface. 264 | 265 | {b Note.} They {e do not include} types [q] and [r] from {!Data}; when 266 | describing their output type in signatures using {!Data}, you must eliminate 267 | [q] and [r]. *) 268 | 269 | (** [View] equips a generic consumer [gfun] with the 270 | {{!Tpf.data}[data[n]]} interface, for easy export. *) 271 | module View (F: sig 272 | type 'a r 273 | val gfun: ('a, p) view -> 'a r 274 | end) : Data with type 'a q := 'a Q.q and type 'a r := 'a F.r 275 | 276 | (** [Schema] equips a generic producer [gfun] the the 277 | {{!Tpf.data}[data[n]]} interface, for easy export. *) 278 | module Schema (F: sig 279 | type 'a r 280 | val gfun: ('a, p) schema -> 'a r 281 | end) : Data with type 'a q := 'a Q.q and type 'a r := 'a F.r 282 | 283 | (** Helpers for manually exporting generic functions. 284 | 285 | [app[n] k f] converts [f: ('a, p) app -> ...] into {{!q}['a q -> ...]} and 286 | applies [k] to it. 287 | 288 | For instance, {!View} is given by 289 | {[let data0 (d: _ data0) = app0 gfun d.view 290 | let data1 (d: _ data1) = app1 gfun d.view 291 | ... 292 | ]} 293 | *) 294 | 295 | val app0 : ('cont -> 'res) -> (p, 'cont) app0 -> 296 | 'res 297 | val app1 : ('cont -> 'res) -> ('a, p, 'cont) app1 -> 298 | 'a q -> 'res 299 | val app2 : ('cont -> 'res) -> ('a, 'b, p, 'cont) app2 -> 300 | 'a q -> 'b q -> 'res 301 | val app3 : ('cont -> 'res) -> ('a, 'b, 'c, p, 'cont) app3 -> 302 | 'a q -> 'b q -> 'c q -> 'res 303 | val app4 : ('cont -> 'res) -> ('a, 'b, 'c, 'd, p, 'cont) app4 -> 304 | 'a q -> 'b q -> 'c q -> 'd q -> 'res 305 | val app5 : ('cont -> 'res) -> ('a, 'b, 'c, 'd, 'e, p, 'cont) app5 -> 306 | 'a q -> 'b q -> 'c q -> 'd q -> 'e q -> 'res 307 | val app6 : ('cont -> 'res) -> ('a, 'b, 'c, 'd, 'e, 'f, p, 'cont) app6 -> 308 | 'a q -> 'b q -> 'c q -> 'd q -> 'e q -> 'f q -> 'res 309 | val app7 : ('cont -> 'res) -> ('a, 'b, 'c, 'd, 'e, 'f, 'g, p, 'cont) app7 -> 310 | 'a q -> 'b q -> 'c q -> 'd q -> 'e q -> 'f q -> 'g q -> 'res 311 | val app8 : ('cont -> 'res) -> ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h, p, 'cont) app8 -> 312 | 'a q -> 'b q -> 'c q -> 'd q -> 'e q -> 'f q -> 'g q -> 'h q -> 'res 313 | val app9 : ('cont -> 'res) -> ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h, 'i, p, 'cont) app9 -> 314 | 'a q -> 'b q -> 'c q -> 'd q -> 'e q -> 'f q -> 'g q -> 'h q -> 'i q -> 'res 315 | end 316 | 317 | (** {1:metaf Manipulating [meta]} *) 318 | 319 | val variant : ?labels:string array -> int -> string -> meta 320 | (** [variant ~labels index name] is a variant, component in a sum type. 321 | 322 | [index] is this constructor position in the type definition, and must be 323 | unique within the type. [name] is the constructor name, and must not be 324 | [""]. 325 | 326 | If [labels] are specified, the constructor is an inline record. *) 327 | 328 | val record : string array -> meta 329 | (** [record labels] is a record. It must be the only constructor in the type, 330 | and [labels] must be non-empty. *) 331 | 332 | val name : meta -> string 333 | (** [name meta] is constructor name. If [meta] is a record, its name is [""]. *) 334 | 335 | val index : meta -> int 336 | (** [index meta] is constructor position in the type definition. *) 337 | 338 | val labels : meta -> int 339 | (** [labels meta] is the number of constructor labels. *) 340 | 341 | val label : meta -> int -> string 342 | (** [label meta i] is [i]-th constructor label. 343 | 344 | @raise Invalid_argument then the constructor does not have [i]-th label. *) 345 | 346 | val has_label : meta -> string -> bool 347 | (** [has_label m name] is [true] iff the constructor has a label [name]. *) 348 | 349 | val pp_meta : Format.formatter -> meta -> unit 350 | (** [pp_meta] pretty-prints a meta block in a human-readable way. *) 351 | -------------------------------------------------------------------------------- /src/tpf_std.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (c) 2019 David Kaloper Meršinjak. All rights reserved. 2 | See LICENSE.md. *) 3 | 4 | open Tpf 5 | 6 | (* Misc *) 7 | 8 | let fix f = 9 | let rec g = lazy (f (fun x -> Lazy.force g x)) in 10 | Lazy.force g 11 | 12 | (* Stdlib generics *) 13 | 14 | let unit: _ data0 = 15 | let m0 = variant 0 "()" in 16 | let k0 = V.K () in 17 | { view = (fun () -> k0), (fun () -> m0) 18 | ; schema = S.[ K (), m0 ] } 19 | 20 | let m0 = variant 0 "(,)" 21 | let pair: _ data2 = 22 | let cons a b = a, b in 23 | let k0 = V.K cons in 24 | { view = (fun a b -> V.(fun (x, y) -> A (A (k0, x, a), y, b)), 25 | (fun _ -> m0)) 26 | ; schema = fun a b -> S.[ A (A (K cons, a), b), m0 ] } 27 | 28 | let m0 = variant 0 "(,,)" 29 | let triple: _ data3 = 30 | let cons a b c = a, b, c in 31 | let k0 = V.K cons in 32 | { view = (fun a b c -> 33 | V.(fun (x, y, z) -> A (A (A (k0, x, a), y, b), z, c)), 34 | (fun _ -> m0)) 35 | ; schema = S.(fun a b c -> [A (A (A (K cons, a), b), c), m0]) } 36 | 37 | let m0 = variant 0 "(,,,)" 38 | let quadruple: _ data4 = 39 | let cons a b c d = a, b, c, d in 40 | let k0 = V.K cons in 41 | { view = (fun a b c d -> 42 | V.(fun (x, y, z, w) -> A (A (A (A (k0, x, a), y, b), z, c), w, d)), 43 | (fun _ -> m0)) 44 | ; schema = S.(fun a b c d -> [A (A (A (A (K cons, a), b), c), d), m0]) } 45 | 46 | let m0 = variant 0 "[]" and m1 = variant 1 "(::)" 47 | let list: _ data1 = 48 | let k0 = V.K [] and k1 = V.K List.cons in 49 | { view = (fun a -> 50 | V.(function [] -> k0 | x::xs -> R (A (k1, x, a), xs)), 51 | (function [] -> m0 | _ -> m1)) 52 | ; schema = S.(fun a -> [K [], m0; R (A (K List.cons, a)), m1]) } 53 | 54 | let m0 = variant 0 "Nil" and m1 = variant 1 "Cons" 55 | let seq: _ data1 = 56 | let scons x xs () = Seq.Cons (x, xs) in 57 | let k0 = V.K Seq.empty and k1 = V.K scons in 58 | { view = Seq.(fun a -> 59 | V.(fun s -> match s () with 60 | | Cons (x, s) -> R (A (k1, x, a), s) 61 | | _ -> k0), 62 | (fun s -> match s () with Nil -> m0 | _ -> m1)) 63 | ; schema = S.(fun a -> [K Seq.empty, m0; R (A (K scons, a)), m1]) } 64 | 65 | let m0 = variant 0 "None" and m1 = variant 1 "Some" 66 | let option: _ data1 = 67 | let some x = Some x in 68 | let k0 = V.K None and k1 = V.K some in 69 | { view = (fun a -> V.(function Some x -> A (k1, x, a) | _ -> k0), 70 | (function None -> m0 | _ -> m1)) 71 | ; schema = S.(fun a -> [K None, m0; A (K some, a), m1]) } 72 | 73 | let m0 = variant 0 "Ok" and m1 = variant 1 "Error" 74 | let result: _ data2 = 75 | let ok x = Ok x and error x = Error x in 76 | let k0 = V.K ok and k1 = V.K error in 77 | { view = (fun a b -> 78 | V.(function Ok x -> A (k0, x, a) | Error y -> A (k1, y, b)), 79 | (function Ok _ -> m0 | _ -> m1)) 80 | ; schema = S.(fun a b -> [A (K ok, a), m0; A (K error, b), m1]) } 81 | 82 | (* Natural transformations. *) 83 | 84 | type ('p, 'q) nat = { nat: 'a. ('a, 'p) app -> ('a, 'q) app } 85 | 86 | let vmap {nat} = 87 | let open V in 88 | let rec go: 'a. ('a, _, _) spine -> ('a, _, _) spine = function 89 | | K k -> K k 90 | | A (s, a, f) -> A (go s, a, nat f) 91 | | R (s, a) -> R (go s, a) in 92 | (fun (spine, meta) -> (fun x -> go (spine x)), meta) 93 | 94 | let smap {nat} = 95 | let open S in 96 | let rec go: 'a. ('a, _, _) spine -> ('a, _, _) spine = function 97 | | K k -> K k 98 | | A (s, a) -> A (go s, nat a) 99 | | R s -> R (go s) in 100 | List.map (fun (spine, meta) -> go spine, meta) 101 | 102 | 103 | (* The Upside-down *) 104 | 105 | module type AppV = sig 106 | type 'a t 107 | val pure : 'a -> 'a t 108 | val app : ('a -> 'b) t -> 'a t -> 'b t 109 | val gfun: meta -> 'a t -> 'a t 110 | end 111 | 112 | module AppV (A: AppV) = struct 113 | module G = Generic (struct type 'a q = 'a -> 'a A.t end) 114 | open G 115 | open V 116 | let gfun (spine, meta) = fix @@ fun goto10 -> 117 | let rec go: 'a. ('a, _, _) spine -> 'a A.t = function 118 | | K k -> A.pure k 119 | | A (s, a, f) -> let k = go s in A.app k (!:f a) 120 | | R (s, a) -> let k = go s in A.app k (goto10 a) in 121 | (fun x -> A.gfun (meta x) (go (spine x))) 122 | include P 123 | include View (struct type 'a r = 'a -> 'a A.t let gfun = gfun end) 124 | end 125 | 126 | module type AppS = sig 127 | type 'a t 128 | val pure : 'a -> 'a t 129 | val app : ('a -> 'b) t -> 'a t -> 'b t 130 | val retract : 'a t Lazy.t -> 'a t 131 | val gfun : ('a t Lazy.t * meta) list -> 'a t 132 | end 133 | 134 | module AppS (A: AppS) = struct 135 | module G = Generic (struct type 'a q = 'a A.t end) 136 | open G 137 | open S 138 | let gfun sch = 139 | let rec go: 'a. ('a, _, _) spine -> 'a A.t = function 140 | | K k -> A.pure k 141 | | A (s, a) -> let k = go s in A.app k !:a 142 | | R s -> let k = go s in A.app k (A.retract goto10) 143 | and goto10 = lazy ( 144 | A.gfun (List.map (fun (spine, meta) -> lazy (go spine), meta) sch)) in 145 | Lazy.force goto10 146 | include P 147 | include Schema (struct type 'a r = 'a A.t let gfun = gfun end) 148 | end 149 | 150 | (* Type tags can be a private matter! *) 151 | 152 | type _ ttag = .. 153 | 154 | module Eq = struct 155 | type 'a eq = 'a -> 'a -> bool 156 | type 'a jmeq = { eq: 'b. 'a -> 'b ttag -> 'b -> bool } 157 | 158 | let jmeq (type a) (eq: a -> a -> bool) = 159 | let module M = struct type _ ttag += K : a ttag end in 160 | let eq (type b) a (t: b ttag) (b: b) = 161 | match t with M.K -> eq a b | _ -> false in 162 | { eq }, M.K 163 | 164 | module Eq1 = Generic (struct type 'a q = 'a jmeq end) 165 | module Eq2 = Generic (struct type 'a q = 'a ttag end) 166 | 167 | let g_eq ((spine1, meta1), (spine2, meta2)) = 168 | let open V in 169 | let rec eq a b = 170 | index (meta1 a) = index (meta2 b) && go (spine1 a) (spine2 b) 171 | and go: 'a 'b. ('a, _, _) spine -> ('b, _, _) spine -> bool = 172 | fun s1 s2 -> match s1, s2 with 173 | | K _ , K _ -> true 174 | | A (s1, a, af), A (s2, b, ag) -> go s1 s2 && Eq1.(!:af).eq a Eq2.(!:ag) b 175 | | R (s1, a) , R (s2, b) -> go s1 s2 && eq a b 176 | | _ , _ -> false in 177 | eq 178 | 179 | type p = Eq1.p 180 | type q = Eq2.p 181 | 182 | let ($$) (view1, view2) f = 183 | let (f1, f2) = jmeq f in view1 Eq1.(!f1), view2 Eq2.(!f2) 184 | 185 | let data0 (d: _ data0) = 186 | (d.view, d.view) |> g_eq 187 | let data1 (d: _ data1) eq1 = 188 | (d.view, d.view) $$ eq1 |> g_eq 189 | let data2 (d: _ data2) eq1 eq2 = 190 | (d.view, d.view) $$ eq1 $$ eq2 |> g_eq 191 | let data3 (d: _ data3) eq1 eq2 eq3 = 192 | (d.view, d.view) $$ eq1 $$ eq2 $$ eq3 |> g_eq 193 | let data4 (d: _ data4) eq1 eq2 eq3 eq4 = 194 | (d.view, d.view) $$ eq1 $$ eq2 $$ eq3 $$ eq4 |> g_eq 195 | let data5 (d: _ data5) eq1 eq2 eq3 eq4 eq5 = 196 | (d.view, d.view) $$ eq1 $$ eq2 $$ eq3 $$ eq4 $$ eq5 |> g_eq 197 | let data6 (d: _ data6) eq1 eq2 eq3 eq4 eq5 eq6 = 198 | (d.view, d.view) $$ eq1 $$ eq2 $$ eq3 $$ eq4 $$ eq5 $$ eq6 |> g_eq 199 | let data7 (d: _ data7) eq1 eq2 eq3 eq4 eq5 eq6 eq7 = 200 | (d.view, d.view) $$ eq1 $$ eq2 $$ eq3 $$ eq4 $$ eq5 $$ eq6 $$ 201 | eq7 |> g_eq 202 | let data8 (d: _ data8) eq1 eq2 eq3 eq4 eq5 eq6 eq7 eq8 = 203 | (d.view, d.view) $$ eq1 $$ eq2 $$ eq3 $$ eq4 $$ eq5 $$ eq6 $$ 204 | eq7 $$ eq8 |> g_eq 205 | let data9 (d: _ data9) eq1 eq2 eq3 eq4 eq5 eq6 eq7 eq8 eq9 = 206 | (d.view, d.view) $$ eq1 $$ eq2 $$ eq3 $$ eq4 $$ eq5 $$ eq6 $$ 207 | eq7 $$ eq8 $$ eq9 |> g_eq 208 | end 209 | 210 | module Cmp = struct 211 | 212 | type 'a cmp = 'a -> 'a -> int 213 | type 'a jmcmp = { cmp: 'b. 'a -> 'b ttag -> 'b -> int } 214 | 215 | let lift (type a) (compare: a -> a -> int) = 216 | let module M = struct type _ ttag += K : a ttag end in 217 | let cmp (type b): _ -> b ttag -> b -> _ = 218 | fun a r b -> match r with M.K -> compare a b | _ -> 0 in 219 | { cmp }, M.K 220 | 221 | module Cmp1 = Generic (struct type 'a q = 'a jmcmp end) 222 | module Cmp2 = Generic (struct type 'a q = 'a ttag end) 223 | 224 | let err_spine () = invalid_arg "Tpf_std.compare: incoherent spine" 225 | 226 | let g_cmp ((spine1, meta1), (spine2, meta2)) = 227 | let open V in 228 | let rec cmp a b = 229 | let c = index (meta1 a) - index (meta2 b) in 230 | if c = 0 then go (spine1 a) (spine2 b) else if c < 0 then -1 else 1 231 | and go: 'a 'b. ('a, _, _) spine -> ('b, _, _) spine -> int = 232 | fun s1 s2 -> match s1, s2 with 233 | | A (s1, a, af), A (s2, b, ag) -> 234 | ( match go s1 s2 with 0 -> Cmp1.(!:af).cmp a Cmp2.(!:ag) b | c -> c ) 235 | | R (s1, a), R (s2, b) -> 236 | ( match go s1 s2 with 0 -> cmp a b | c -> c ) 237 | | K _, K _-> 0 238 | | _ -> err_spine () in 239 | cmp 240 | 241 | type p = Cmp1.p 242 | type q = Cmp2.p 243 | 244 | let ($$) (view1, view2) f = 245 | let (f1, f2) = lift f in view1 Cmp1.(!f1), view2 Cmp2.(!f2) 246 | 247 | let data0 (d: _ data0) = 248 | (d.view, d.view) |> g_cmp 249 | let data1 (d: _ data1) cmp1 = 250 | (d.view, d.view) $$ cmp1 |> g_cmp 251 | let data2 (d: _ data2) cmp1 cmp2 = 252 | (d.view, d.view) $$ cmp1 $$ cmp2 |> g_cmp 253 | let data3 (d: _ data3) cmp1 cmp2 cmp3 = 254 | (d.view, d.view) $$ cmp1 $$ cmp2 $$ cmp3 |> g_cmp 255 | let data4 (d: _ data4) cmp1 cmp2 cmp3 cmp4 = 256 | (d.view, d.view) $$ cmp1 $$ cmp2 $$ cmp3 $$ cmp4 |> g_cmp 257 | let data5 (d: _ data5) cmp1 cmp2 cmp3 cmp4 cmp5 = 258 | (d.view, d.view) $$ cmp1 $$ cmp2 $$ cmp3 $$ cmp4 $$ cmp5 |> g_cmp 259 | let data6 (d: _ data6) cmp1 cmp2 cmp3 cmp4 cmp5 cmp6 = 260 | (d.view, d.view) $$ cmp1 $$ cmp2 $$ cmp3 $$ cmp4 $$ cmp5 $$ cmp6 |> g_cmp 261 | let data7 (d: _ data7) cmp1 cmp2 cmp3 cmp4 cmp5 cmp6 cmp7 = 262 | (d.view, d.view) $$ cmp1 $$ cmp2 $$ cmp3 $$ cmp4 $$ cmp5 $$ cmp6 $$ 263 | cmp7 |> g_cmp 264 | let data8 (d: _ data8) cmp1 cmp2 cmp3 cmp4 cmp5 cmp6 cmp7 cmp8 = 265 | (d.view, d.view) $$ cmp1 $$ cmp2 $$ cmp3 $$ cmp4 $$ cmp5 $$ cmp6 $$ 266 | cmp7 $$ cmp8 |> g_cmp 267 | let data9 (d: _ data9) cmp1 cmp2 cmp3 cmp4 cmp5 cmp6 cmp7 cmp8 cmp9 = 268 | (d.view, d.view) $$ cmp1 $$ cmp2 $$ cmp3 $$ cmp4 $$ cmp5 $$ cmp6 $$ 269 | cmp7 $$ cmp8 $$ cmp9 |> g_cmp 270 | end 271 | 272 | module Iter = struct 273 | module G = Generic (struct type 'a q = 'a -> unit end) 274 | open G 275 | open V 276 | let g_iter (spine, _) x = 277 | let rec go: 'a. ('a, _, _) spine -> _ = fun s v -> match s with 278 | | K _ -> () 279 | | A (s, a, af) -> go s v; !:af a 280 | | R (s, a) -> go s v; go (v a) v in 281 | go (spine x) spine 282 | include P 283 | include View (struct type 'a r = 'a -> unit let gfun = g_iter end) 284 | end 285 | 286 | module Random = struct 287 | open Random 288 | module G = Generic (struct type 'a q = State.t -> 'a end) 289 | open S 290 | open G 291 | let err_base () = invalid_arg "Tpf_std.Random.g_gen: size limit exceeded" 292 | let rec null: 'a. ('a, _) schema -> 'a = function 293 | | [] -> err_base () 294 | | (K x, _)::_ -> x 295 | | _::xs -> null xs 296 | let rec g_gen sch ?base size rng = 297 | let rec go: 'a. ('a, _, _) spine -> _ -> _ -> 'a = 298 | fun s size rng -> match s with 299 | | K k -> k 300 | | A (A (A (s, a), b), c) -> go s size rng (!:a rng) (!:b rng) (!:c rng) 301 | | A (A (s, a), b) -> go s size rng (!:a rng) (!:b rng) 302 | | A (s, a) -> go s size rng (!:a rng) 303 | | R s -> go s size rng (g_gen sch ?base size rng) in 304 | if size < 1 then match base with Some x -> x | _ -> null sch else 305 | let spine, _ = List.(nth sch (State.int rng (length sch))) in 306 | go spine (size - 1) rng 307 | include P 308 | include Schema (struct 309 | type 'a r = ?base:'a -> int -> State.t -> 'a 310 | let gfun = g_gen 311 | end) 312 | end 313 | -------------------------------------------------------------------------------- /src/tpf_std.mli: -------------------------------------------------------------------------------- 1 | (* Copyright (c) 2019 David Kaloper Meršinjak. All rights reserved. 2 | See LICENSE.md. *) 3 | 4 | (** Tpf nice-to-haves. *) 5 | 6 | open Tpf 7 | 8 | val fix: (('a -> 'b) -> ('a -> 'b)) -> ('a -> 'b) 9 | (** [fix f x] is [f (fix f) x], the usual fixpoint on functions. 10 | This one maximizes sharing: [f _] is evaluated only once. 11 | Sharing is caring. *) 12 | 13 | (** {1 Stdlib types} 14 | 15 | {{!Tpf.data}[data]} representations of some common types. *) 16 | 17 | val unit : unit data0 18 | val pair : ('a, 'b, 'a * 'b) data2 19 | val triple : ('a, 'b, 'c, 'a * 'b * 'c) data3 20 | val quadruple : ('a, 'b, 'c, 'd, 'a * 'b * 'c * 'd) data4 21 | 22 | val list : ('a, 'a list) data1 23 | val seq : ('a, 'a Seq.t) data1 24 | val option : ('a, 'a option) data1 25 | val result : ('a, 'b, ('a, 'b) result) data2 26 | 27 | (** {1 Useful generic functions} *) 28 | 29 | (** Equality. 30 | 31 | It behaves like the built-in one, but maintains abstraction. *) 32 | module Eq: sig 33 | type 'a eq = 'a -> 'a -> bool 34 | type p 35 | type q 36 | val ($$) : (('a, p) app -> 'b) * (('a, q) app -> 'c) -> 'a eq -> 'b * 'c 37 | val g_eq : ('a, p) view * ('a, q) view -> 'a eq 38 | include Data with type 'a q := 'a eq and type 'a r := 'a eq 39 | end 40 | 41 | (** Comparison. 42 | 43 | It behaves like the built-in one, using the lexicographic ordering on 44 | constructor arguments, but maintains abstraction. *) 45 | module Cmp: sig 46 | type 'a cmp = 'a -> 'a -> int 47 | type p 48 | type q 49 | val ($$) : (('a, p) app -> 'b) * (('a, q) app -> 'c) -> 'a cmp -> 'b * 'c 50 | val g_cmp : ('a, p) view * ('a, q) view -> 'a cmp 51 | include Data with type 'a q := 'a cmp and type 'a r := 'a cmp 52 | end 53 | 54 | (** [iter]. *) 55 | module Iter: sig 56 | include P with type 'a q := 'a -> unit 57 | val g_iter : ('a, p) view -> 'a -> unit 58 | include Data with type 'a q := 'a -> unit and type 'a r := 'a -> unit 59 | end 60 | 61 | (** Random type inhabitants. *) 62 | module Random: sig 63 | open Random 64 | include P with type 'a q := State.t -> 'a 65 | val g_gen : ('a, p) schema -> ?base:'a -> int -> State.t -> 'a 66 | (** [g_gen schema ~base size s] generates a random inhabitant of the type 67 | described by [schema] using the random state [s]. 68 | 69 | The [size] parameter limits the recursion depth. When [size < 1], 70 | {ul 71 | {- returns [base], if specified; or} 72 | {- returns the first nullary constructor in [schema], if any; or} 73 | {- raises.}} 74 | 75 | @raise Invalid_argument if [size < 1], [base] is not specified, and there 76 | are no nullary constructors in ['a]. *) 77 | 78 | include Data 79 | with type 'a q := State.t -> 'a 80 | and type 'a r := ?base:'a -> int -> State.t -> 'a 81 | end 82 | 83 | (** {1:applicative Applicative traversals} 84 | 85 | {{!Tpf.core}Spines} essentially encode values as expressions in the free 86 | applicative functor. 87 | 88 | This API provides a way to uniformly eliminate spines by interpreting them 89 | in a chosen applicative. This captures a slightly restricted, but 90 | significant class of generic functions. 91 | 92 | {b Note.} You can safely ignore this if you don't feel like applicatives 93 | today. *) 94 | 95 | (* Note - gfuns break symmetry, but are necessary to internalize recursion :/ . *) 96 | 97 | (** {{!Tpf.view}View}-flavored applicative. *) 98 | module type AppV = sig 99 | type 'a t 100 | val pure : 'a -> 'a t 101 | val app : ('a -> 'b) t -> 'a t -> 'b t 102 | val gfun : meta -> 'a t -> 'a t 103 | end 104 | 105 | (** {{!Tpf.view}View} traversal. *) 106 | module AppV (A: AppV): sig 107 | include P with type 'a q := 'a -> 'a A.t 108 | val gfun : ('a, p) view -> 'a -> 'a A.t 109 | include Data with type 'a q := 'a -> 'a A.t and type 'a r := 'a -> 'a A.t 110 | end 111 | 112 | (** {{!Tpf.schema}Schema}-flavored applicative. *) 113 | module type AppS = sig 114 | type 'a t 115 | val pure : 'a -> 'a t 116 | val app : ('a -> 'b) t -> 'a t -> 'b t 117 | val retract : 'a t Lazy.t -> 'a t 118 | val gfun : ('a t Lazy.t * meta) list -> 'a t 119 | end 120 | 121 | (** {{!Tpf.schema}Schema} traversal. *) 122 | module AppS (A: AppS) : sig 123 | include P with type 'a q := 'a A.t 124 | val gfun : ('a, p) schema -> 'a A.t 125 | include Data with type 'a q := 'a A.t and type 'a r := 'a A.t 126 | end 127 | 128 | (** {1:qmap Query maps} 129 | 130 | These convert ['a t1] (represented by [('a, 'p) app]) generics into ['a t2] 131 | (represented by [('a, 'q) app]) generics. *) 132 | 133 | type ('p, 'q) nat = { nat: 'a. ('a, 'p) app -> ('a, 'q) app } 134 | (** Essentially the object part of a natural transformation. *) 135 | 136 | val vmap: ('p, 'q) nat -> ('a, 'p) view -> ('a, 'q) view 137 | (** [vmap nat v] is the view with the same structure as [v], but with queries 138 | in [q]. *) 139 | 140 | val smap : ('p, 'q) nat -> ('a, 'p) schema -> ('a, 'q) schema 141 | (** [smap nat s] is the schema with the same structure as [s], but with 142 | queries in [q]. *) 143 | -------------------------------------------------------------------------------- /tpf-ext.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | homepage: "https://github.com/pqwy/tpf" 3 | dev-repo: "git+https://github.com/pqwy/tpf.git" 4 | bug-reports: "https://github.com/pqwy/tpf/issues" 5 | doc: "http://pqwy.github.io/tpf/doc" 6 | author: "David Kaloper Meršinjak " 7 | maintainer: "David Kaloper Meršinjak " 8 | license: "ISC" 9 | synopsis: "Generics for several popular libraries" 10 | description: 11 | "The missing generic support for several libraries that could use it. 12 | 13 | Contains several conditionally compiled sub-libs: 14 | 15 | - tpf-extra.fmt 16 | - tpf-extra.cmdliner 17 | - tpf-extra.sexplib 18 | " 19 | 20 | build: [[ "dune" "subst" ] {pinned} 21 | [ "dune" "build" "-p" name "-j" jobs ]] 22 | depopts: [ 23 | "fmt" {>= "0.8"} 24 | "cmdliner" {>= "1.0.0"} 25 | "sexplib0" {>= "v0.12.0"} 26 | ] 27 | depends: [ 28 | "ocaml" {>= "4.05.0"} 29 | "dune" {build & >= "1.8"} 30 | "tpf" 31 | ] 32 | -------------------------------------------------------------------------------- /tpf.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | homepage: "https://github.com/pqwy/tpf" 3 | dev-repo: "git+https://github.com/pqwy/tpf.git" 4 | bug-reports: "https://github.com/pqwy/tpf/issues" 5 | doc: "http://pqwy.github.io/tpf/doc" 6 | author: "David Kaloper Meršinjak " 7 | maintainer: "David Kaloper Meršinjak " 8 | license: "ISC" 9 | synopsis: "Minimalist datatype-generic programming" 10 | description: 11 | "Tagless/trivial polytypic functions (Tpf) is a simple and idiomatic library for 12 | datatype-generic programming in OCaml. 13 | 14 | Tpf allows you to write functions that work on a wide range of unrelated data 15 | types. Such functions require only the base language, need no runtime, and 16 | seamlessly interoperate with the rest of OCaml. Tpf works in the same stage as 17 | the rest of your program, and doesn't rely on meta-programming. 18 | 19 | Tpf has no dependencies and is distributed under the ISC license." 20 | 21 | build: [[ "dune" "subst" ] {pinned} 22 | [ "dune" "build" "-p" name "-j" jobs ]] 23 | depends: [ 24 | "ocaml" {>= "4.05.0"} 25 | "dune" {build & >= "1.8"} 26 | ] 27 | --------------------------------------------------------------------------------