├── .gitignore ├── CHANGES.md ├── COPYING ├── LICENSE ├── Makefile ├── README.md ├── api ├── dune └── metapp_api.ml ├── dune-project ├── dyncompile ├── dune ├── dyncompile.ml └── options.ml ├── metapp.opam ├── metapp ├── dune ├── metapp.ml └── metapp.mli ├── ppx ├── dune ├── findlib_for_ppx.ml └── metapp_ppx.ml ├── preutils ├── accu.ml ├── accu.mli ├── dune └── metapp_preutils.ml ├── tests ├── deep │ ├── deep.ml │ └── dune ├── framework │ ├── dune │ └── test_framework.ml ├── multistage │ ├── dune │ └── multistage.ml ├── simple │ ├── dune │ └── simple.ml ├── sub_holes │ ├── dune │ └── sub_holes.ml └── utils │ ├── dune │ └── test_utils.ml └── version_info ├── dune ├── metapp_version_info.ml └── metapp_version_info.mli /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | /_build/ 3 | /_opam/ 4 | .merlin 5 | /metapp.install 6 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | # Development version 2 | 3 | - #5: compatibility with merlin 4 | Reported by Kiran Gopinathan, https://github.com/thierry-martinez/metapp/issues/5 5 | 6 | - #8: Windows support 7 | Contributed by jonahbeckford, https://github.com/thierry-martinez/metapp/pull/8 8 | 9 | - #9, #10: Fix filtering on type declaration (records and variants) 10 | Reported and contributed by Török Edwin, 11 | https://github.com/thierry-martinez/metapp/issues/9 12 | and https://github.com/thierry-martinez/metapp/pull/10 13 | 14 | - #10, #11: Support filtering on list expressions and patterns 15 | Reported by Török Edwin, 16 | https://github.com/thierry-martinez/metapp/pull/10#issuecomment-1875539468 17 | 18 | # Version 0.4.4, 2022-07-15 19 | 20 | - Port to ppxlib 0.26.0 21 | (suggested by @nilsbecker, https://github.com/thierry-martinez/ocaml-in-python/issues/1) 22 | 23 | - Add `Pat.Construct.Arg.{construct,destruct}` for constructing and 24 | destructing `Ppat_construct` argument (for compatibility between OCaml 4.14 25 | and older versions of OCaml). 26 | 27 | - Add `Te.destruct_decl` for destructing `Pext_decl` (for compatibility between 28 | OCaml 4.14 and older versions of OCaml). 29 | 30 | # Version 0.4.3, 2022-03-21 31 | 32 | - Add getters `Metapp.Types.get_{desc,level,scope,id}` since `Types.type_expr` 33 | is abstract in OCaml 4.14. 34 | 35 | # Version 0.4.2, 2021-10-08 36 | 37 | - Add `Metapp.Types.destruct_tpackage`: returns a pair `Some (path, list)` 38 | if a `Types.type_desc` is a `Tpackage`, for compatibility between OCaml 4.13 39 | and older versions of OCaml. 40 | 41 | # Version 0.4.1, 2021-10-04 42 | 43 | - Add `Metapp.Types.destruct_type_variant`: returns a pair `Some (ctors, repr)` 44 | if a `Types.type_kind` is a `Type_variant`, for compatibility between OCaml 4.13 45 | and older versions of OCaml. 46 | 47 | # Version 0.4.0, 2021-02-19 48 | 49 | - Port to ppxlib 0.18 and OCaml 4.12 (by kit-ty-kate, #2) 50 | 51 | # Version 0.3.0, 2020-09-22 52 | 53 | - Port to ppxlib 0.16 / ocaml-migrate-parsetree 2.0.0 54 | 55 | - `Metapp.ExtensibleS.destruct_extension` returns a pair `Some (e, attrs)` where 56 | `e` is the extension and `attrs` is the list of optional attributes. 57 | 58 | - Fix bug with nested calls in meta-quotes 59 | 60 | - Add `?optional` argument to `Metapp.apply` 61 | 62 | - Add `[%%metaverbose]` for logging compilation commands. 63 | 64 | # Version 0.2.0, 2020-05-11 65 | 66 | - Compatibility with OCaml 4.11.0 67 | 68 | - More utility functions in `Metapp` module to construct and destruct OCaml's 69 | parsetree in a version-independent way 70 | 71 | - Functions for invoking OCaml compiler and loading modules dynamically are 72 | exported in the package `metapp.dyncompile`. 73 | 74 | # Version 0.1.0, 2020-02-27 75 | 76 | - First release 77 | -------------------------------------------------------------------------------- /COPYING: -------------------------------------------------------------------------------- 1 | BSD 2-Clause License 2 | 3 | Copyright (c) 2020, Thierry Martinez. 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are met: 8 | 9 | 1. Redistributions of source code must retain the above copyright notice, this 10 | list of conditions and the following disclaimer. 11 | 2. Redistributions in binary form must reproduce the above copyright notice, 12 | this list of conditions and the following disclaimer in the documentation 13 | and/or other materials provided with the distribution. 14 | 15 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 16 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 17 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 18 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR 19 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 20 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 21 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 22 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 23 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 24 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 25 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | BSD 3-Clause License 2 | 3 | Copyright (c) 2020-2021, thierry-martinez 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are met: 8 | 9 | 1. Redistributions of source code must retain the above copyright notice, this 10 | list of conditions and the following disclaimer. 11 | 12 | 2. Redistributions in binary form must reproduce the above copyright notice, 13 | this list of conditions and the following disclaimer in the documentation 14 | and/or other materials provided with the distribution. 15 | 16 | 3. Neither the name of the copyright holder nor the names of its 17 | contributors may be used to endorse or promote products derived from 18 | this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 21 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 22 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 23 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 24 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 25 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 26 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 27 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 28 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | DUNE=dune 2 | FLAGS= 3 | 4 | .PHONY : all 5 | all : 6 | $(DUNE) build $(FLAGS) 7 | 8 | .PHONY : clean 9 | clean : 10 | $(DUNE) clean $(FLAGS) 11 | 12 | .PHONY : install 13 | install : 14 | $(DUNE) build @install $(FLAGS) 15 | $(DUNE) install $(FLAGS) 16 | 17 | .PHONY : doc 18 | doc : 19 | $(DUNE) build @doc $(FLAGS) 20 | 21 | .PHONY : test 22 | test : 23 | $(DUNE) runtest $(FLAGS) 24 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # `metapp`: meta-preprocessor for OCaml 2 | 3 | `metapp` is a PPX rewriter that provides a `[%meta ...]` extension, 4 | where the dots `...` are arbitrary OCaml expressions that are 5 | substituted at compile-time by the AST nodes they evaluate into. 6 | These expressions build AST nodes either by quoting some code directly, 7 | or by using `compiler-libs` ([`Parsetree`], [`Ast_helper`], ...). 8 | 9 | [`Parsetree`]: https://caml.inria.fr/pub/docs/manual-ocaml/compilerlibref/Parsetree.html 10 | [`Ast_helper`]: https://caml.inria.fr/pub/docs/manual-ocaml/compilerlibref/Ast_helper.html 11 | 12 | In particular, this preprocessor is easy to use for conditional 13 | compilation, and is an alternative to [`cppo`] and [`ppx_optcomp`]. 14 | 15 | [`cppo`]: https://github.com/ocaml-community/cppo 16 | [`ppx_optcomp`]: https://github.com/janestreet/ppx_optcomp 17 | 18 | ```ocaml 19 | let option_get o = 20 | [%meta if Sys.ocaml_version >= "4.08.0" then 21 | [%e Option.get o] 22 | else 23 | [%e match o with 24 | | None -> invalid_arg "option_get" 25 | | Some x -> x]] 26 | ``` 27 | 28 | `metapp` can be used with [`dune`] by using the [`preprocess`] field. 29 | 30 | [`dune`]: https://github.com/ocaml/dune 31 | [`preprocess`]: https://dune.readthedocs.io/en/latest/concepts.html#preprocessing-with-ppx-rewriters 32 | 33 | ```lisp 34 | (executable 35 | ... 36 | (preprocess (pps metapp.ppx)) 37 | ...) 38 | ``` 39 | 40 | Inside `[%meta ...]` code, the `[%e ...]` extension quotes expressions 41 | (of type [`Parsetree.expression`]). There are other quotations 42 | available: the full list is given below. 43 | 44 | |Quotation |Type | 45 | |-----------------------------|--------------------------| 46 | |`[%e ...]` or `[%expr ...]` |`Parsetree.expression` | 47 | |`[%p? ...]` or `[%pat? ...]` |`Parsetree.pattern` | 48 | |`[%t: ...]` or `[%type: ...]`|`Parsetree.core_type` | 49 | |`[%sig: ...]` |`Parsetree.signature` | 50 | |`[%sigi: ...]` |`Parsetree.signature_item`| 51 | |`[%str ...]` |`Parsetree.structure` | 52 | |`[%stri ...]` |`Parsetree.structure_item`| 53 | 54 | Quoted expressions can in turn contain further `[%meta ...]` code. 55 | Moreover, `[%meta ...]` code can itself contain other levels of 56 | `[%meta ...]` code, for multi-stage programming. 57 | 58 | In addition to this syntax extension, the [`Metapp`] module 59 | provided by the [`metapp`] package provides convenient functions 60 | for AST constructions. In particular, this module provides an 61 | OCaml-version-independent interface. Moveover, this module provides a 62 | common signature `ValueS` for constructing and transforming 63 | expressions (module `Exp`), patterns (module `Pat`) or both at the 64 | same time (module `Value`). 65 | 66 | [`Metapp`]: https://github.com/thierry-martinez/metapp/blob/master/metapp/metapp.mli 67 | 68 | The [`Metapp`] module also provides a `filter` mapper, which handles 69 | `[@if ]` attributes _à la_ `ppx_optcomp`. The `[@if ]` 70 | attribute can appear mostly everywhere syntax elements are enumerated, 71 | including tuples, function applications, arrays, etc. 72 | 73 | ```ocaml 74 | [%%metapackage metapp] 75 | [%%meta Metapp.Stri.of_list @@ (new Metapp.filter)#structure [%str 76 | type t = 77 | | A of int 78 | | B of int * int 79 | [@if [%meta Metapp.Exp.of_bool (Sys.ocaml_version >= "4.04.0")]] 80 | (* ... *) 81 | 82 | let somefunction v = 83 | match (v: t) with 84 | | A x -> something x 85 | | B (y,z) 86 | [@if [%meta Metapp.Exp.of_bool (Sys.ocaml_version >= "4.04.0")]] -> 87 | something' y z 88 | (* ... *) ]] 89 | ``` 90 | 91 | Usually, when `[@if false]` appears in the components of a tuple (in 92 | an expression or a pattern), these components are removed: if the 93 | tuple becomes empty, the tuple is rewritten as the unit constructor 94 | `()`; if the tuple is reduced to a singleton `(v)`, the tuple is 95 | rewritten as the value `v` itself. 96 | 97 | Multiple arguments of a variant constructor are considered as a tuple 98 | syntactically: `C (a, b [@if false])` is rewritten as `C a` and 99 | `C (a [@if false], b [@if false])` is rewritten as `C ()` (a constructor `C` 100 | with a single argument of type `unit`), whereas 101 | `C ((a, b) [@if false])` is rewritten as `C` (a constant constructor `C`). 102 | There is a special case for the list constructor `::`: `a [@if false]::b` 103 | is rewritten as `b` (instead of applying the constructor `::` to the 104 | single argument `b`, which is most probably incorrect). This allows 105 | `[@if false]` to be used to filter list elements as in 106 | `[e1; ...; ei [@if false]; ...; en]`. 107 | 108 | Global definitions for meta-code can be included with `[%%metadef 109 | ...]`. 110 | By default, the meta-code is compiled with the `compiler-libs` package. 111 | Other packages can be loaded with `[%%metapackage ...]`. 112 | More generally, flags can be passed to the compiler to compile meta-code 113 | with `[%%metaflag ...]` (there is another convenient notation for 114 | adding interface directories: `[%%metadir ...]`). 115 | `[%%metaload ...]` loads a particular compilation unit. 116 | For instance, `[%%metapackage metapp]` links the meta-code with the 117 | `metapp` package in order to use the [`Metapp`] module. 118 | All these notations can be applied to multiple arguments at once by using 119 | comma as separator. 120 | 121 | Note that dynamic package loading is broken in PPX with dune 122 | ([#3214]). When packages are loaded with `[%%metapackage ...]`, a 123 | workaround ([see discussion]) is used to load the packages 124 | correctly, but only with OCaml >=4.08. If you need to use 125 | `[%%metapackage ...]` with a prior version of OCaml, you still can 126 | statically link the packages you need by listing them in the 127 | `(preprocess (pps ...))` list. You will still have to import them with 128 | `[%%metapackage ...]` to let the compiler see their interface when 129 | compiling the meta-code. 130 | 131 | [#3214]: https://github.com/ocaml/dune/issues/3214 132 | [see discussion]: https://discuss.ocaml.org 133 | 134 | Compilation commands can be logged by adding `[%%metaverbose]` to the 135 | preprocessed file. 136 | 137 | ## How does `metapp` differ from [`ppx_stage`] 138 | 139 | (Discussed in [this thread](https://discuss.ocaml.org/t/creating-a-ppx-that-transforms-record-updates/10189/4)) 140 | 141 | [`ppx_stage`]: https://github.com/stedolan/ppx_stage 142 | 143 | - By using `ppx_stage`, a program can generate and execute other 144 | programs at runtime (by invoking the compiler and dynamic loader at 145 | runtime). By using metapp, a program can contain portion of codes 146 | that are generated at compile time by executing other programs (by 147 | invoking the compiler and dynamic loader during the preprocessing 148 | phase). 149 | 150 | - With `ppx_stage`, each piece of code that is manipulated is checked 151 | to be well-typed: a value of type `'a code` can be seen as a `unit 152 | -> 'a` closure, with an efficient composition (by compiling). With 153 | `metapp`, meta-programs directly manipulate the parse tree, with the 154 | only constraint that the parse tree produced at the end should lead 155 | to a well-typed program: this is more error prone, but that allows 156 | to describe syntax extensions where we can manipulate as first-class 157 | values some piece of syntax like record fields, that are not 158 | first-class citizens in the language. 159 | -------------------------------------------------------------------------------- /api/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name metapp_api) 3 | (public_name metapp.api) 4 | (libraries compiler-libs metapp_preutils)) 5 | -------------------------------------------------------------------------------- /api/metapp_api.ml: -------------------------------------------------------------------------------- 1 | module type UnaryS = sig 2 | type 'a t 3 | end 4 | 5 | module type UnaryMakeS = sig 6 | type 'a t 7 | 8 | val make : unit -> 'a t 9 | end 10 | 11 | module type MetapointsS = sig 12 | type 'a x 13 | 14 | type t = { 15 | expr : Ppxlib.expression x; 16 | pat : Ppxlib.pattern x; 17 | typ : Ppxlib.core_type x; 18 | class_type : Ppxlib.class_type x; 19 | class_type_field : Ppxlib.class_type_field x; 20 | class_expr : Ppxlib.class_expr x; 21 | class_field : Ppxlib.class_field x; 22 | module_type : Ppxlib.module_type x; 23 | module_expr : Ppxlib.module_expr x; 24 | signature_item : Ppxlib.signature_item x; 25 | structure_item : Ppxlib.structure_item x; 26 | } 27 | end 28 | 29 | module type QuotationsS = sig 30 | type 'a x 31 | 32 | type t = { 33 | expr : Ppxlib.expression x; 34 | pat : Ppxlib.pattern x; 35 | typ : Ppxlib.core_type x; 36 | signature : Ppxlib.signature x; 37 | signature_item : Ppxlib.signature_item x; 38 | structure : Ppxlib.structure x; 39 | structure_item : Ppxlib.structure_item x; 40 | } 41 | end 42 | 43 | module type MetapointS = sig 44 | include Metapp_preutils.ExtensibleS 45 | 46 | module MetapointAccessor (Collector : MetapointsS) : sig 47 | val get : Collector.t -> t Collector.x 48 | 49 | val set : t Collector.x -> Collector.t -> Collector.t 50 | end 51 | end 52 | 53 | module type QuotationS = sig 54 | include Metapp_preutils.VisitableS 55 | 56 | val of_payload : Ppxlib.payload -> t 57 | 58 | module QuotationAccessor (Collector : QuotationsS) : sig 59 | val get : Collector.t -> t Collector.x 60 | 61 | val set : t Collector.x -> Collector.t -> Collector.t 62 | end 63 | end 64 | 65 | module Exp = struct 66 | include Metapp_preutils.Exp 67 | 68 | module MetapointAccessor (Collector : MetapointsS) = struct 69 | let get (c : Collector.t) : t Collector.x = c.expr 70 | 71 | let set (x : t Collector.x) (c : Collector.t) = 72 | { c with expr = x } 73 | end 74 | 75 | module QuotationAccessor (Collector : QuotationsS) = struct 76 | let get (c : Collector.t) : t Collector.x = c.expr 77 | 78 | let set (x : t Collector.x) (c : Collector.t) = 79 | { c with expr = x } 80 | end 81 | end 82 | 83 | module Pat = struct 84 | include Metapp_preutils.Pat 85 | 86 | module MetapointAccessor (Collector : MetapointsS) = struct 87 | let get (c : Collector.t) : t Collector.x = c.pat 88 | 89 | let set (x : t Collector.x) (c : Collector.t) = 90 | { c with pat = x } 91 | end 92 | 93 | module QuotationAccessor (Collector : QuotationsS) = struct 94 | let get (c : Collector.t) : t Collector.x = c.pat 95 | 96 | let set (x : t Collector.x) (c : Collector.t) = 97 | { c with pat = x } 98 | end 99 | end 100 | 101 | module Typ = struct 102 | include Metapp_preutils.Typ 103 | 104 | module MetapointAccessor (Collector : MetapointsS) = struct 105 | let get (c : Collector.t) : t Collector.x = c.typ 106 | 107 | let set (x : t Collector.x) (c : Collector.t) = 108 | { c with typ = x } 109 | end 110 | 111 | module QuotationAccessor (Collector : QuotationsS) = struct 112 | let get (c : Collector.t) : t Collector.x = c.typ 113 | 114 | let set (x : t Collector.x) (c : Collector.t) = 115 | { c with typ = x } 116 | end 117 | end 118 | 119 | module Cty = struct 120 | include Metapp_preutils.Cty 121 | 122 | module MetapointAccessor (Collector : MetapointsS) = struct 123 | let get (c : Collector.t) : t Collector.x = c.class_type 124 | 125 | let set (x : t Collector.x) (c : Collector.t) = 126 | { c with class_type = x } 127 | end 128 | end 129 | 130 | module Ctf = struct 131 | include Metapp_preutils.Ctf 132 | 133 | module MetapointAccessor (Collector : MetapointsS) = struct 134 | let get (c : Collector.t) : t Collector.x = c.class_type_field 135 | 136 | let set (x : t Collector.x) (c : Collector.t) = 137 | { c with class_type_field = x } 138 | end 139 | end 140 | 141 | module Cl = struct 142 | include Metapp_preutils.Cl 143 | 144 | module MetapointAccessor (Collector : MetapointsS) = struct 145 | let get (c : Collector.t) : t Collector.x = c.class_expr 146 | 147 | let set (x : t Collector.x) (c : Collector.t) = 148 | { c with class_expr = x } 149 | end 150 | end 151 | 152 | module Cf = struct 153 | include Metapp_preutils.Cf 154 | 155 | module MetapointAccessor (Collector : MetapointsS) = struct 156 | let get (c : Collector.t) : t Collector.x = c.class_field 157 | 158 | let set (x : t Collector.x) (c : Collector.t) = 159 | { c with class_field = x } 160 | end 161 | end 162 | 163 | module Mty = struct 164 | include Metapp_preutils.Mty 165 | 166 | module MetapointAccessor (Collector : MetapointsS) = struct 167 | let get (c : Collector.t) : t Collector.x = c.module_type 168 | 169 | let set (x : t Collector.x) (c : Collector.t) = 170 | { c with module_type = x } 171 | end 172 | end 173 | 174 | module Mod = struct 175 | include Metapp_preutils.Mod 176 | 177 | module MetapointAccessor (Collector : MetapointsS) = struct 178 | let get (c : Collector.t) : t Collector.x = c.module_expr 179 | 180 | let set (x : t Collector.x) (c : Collector.t) = 181 | { c with module_expr = x } 182 | end 183 | end 184 | 185 | module Sig = struct 186 | include Metapp_preutils.Sig 187 | 188 | module QuotationAccessor (Collector : QuotationsS) = struct 189 | let get (c : Collector.t) : t Collector.x = c.signature 190 | 191 | let set (x : t Collector.x) (c : Collector.t) = 192 | { c with signature = x } 193 | end 194 | end 195 | 196 | module Sigi = struct 197 | include Metapp_preutils.Sigi 198 | 199 | module MetapointAccessor (Collector : MetapointsS) = struct 200 | let get (c : Collector.t) : t Collector.x = c.signature_item 201 | 202 | let set (x : t Collector.x) (c : Collector.t) = 203 | { c with signature_item = x } 204 | end 205 | 206 | module QuotationAccessor (Collector : QuotationsS) = struct 207 | let get (c : Collector.t) : t Collector.x = c.signature_item 208 | 209 | let set (x : t Collector.x) (c : Collector.t) = 210 | { c with signature_item = x } 211 | end 212 | end 213 | 214 | module Str = struct 215 | include Metapp_preutils.Str 216 | 217 | module QuotationAccessor (Collector : QuotationsS) = struct 218 | let get (c : Collector.t) : t Collector.x = c.structure 219 | 220 | let set (x : t Collector.x) (c : Collector.t) = 221 | { c with structure = x } 222 | end 223 | end 224 | 225 | module Stri = struct 226 | include Metapp_preutils.Stri 227 | 228 | module MetapointAccessor (Collector : MetapointsS) = struct 229 | let get (c : Collector.t) : t Collector.x = c.structure_item 230 | 231 | let set (x : t Collector.x) (c : Collector.t) = 232 | { c with structure_item = x } 233 | end 234 | 235 | module QuotationAccessor (Collector : QuotationsS) = struct 236 | let get (c : Collector.t) : t Collector.x = c.structure_item 237 | 238 | let set (x : t Collector.x) (c : Collector.t) = 239 | { c with structure_item = x } 240 | end 241 | end 242 | 243 | module type MetapointsMakeS = sig 244 | include MetapointsS 245 | 246 | module Make (X : UnaryMakeS with type 'a t = 'a x) : sig 247 | val make : unit -> t 248 | end 249 | end 250 | 251 | module type MetapointsWithMakeS = sig 252 | include MetapointsS 253 | 254 | val make : unit -> t 255 | end 256 | 257 | module type QuotationsMakeS = sig 258 | include QuotationsS 259 | 260 | module Make (X : UnaryMakeS with type 'a t = 'a x) : sig 261 | val make : unit -> t 262 | end 263 | end 264 | 265 | module type QuotationsWithMakeS = sig 266 | include QuotationsS 267 | 268 | val make : unit -> t 269 | end 270 | 271 | module Metapoints (X : UnaryS) 272 | : MetapointsMakeS with type 'a x = 'a X.t = struct 273 | module rec Sub : sig 274 | include MetapointsS with type 'a x = 'a X.t 275 | end = struct 276 | include Sub 277 | end 278 | 279 | include Sub 280 | 281 | module Make (X : UnaryMakeS with type 'a t = 'a X.t) = struct 282 | let make () = { 283 | expr = X.make (); 284 | pat = X.make (); 285 | typ = X.make (); 286 | class_type = X.make (); 287 | class_type_field = X.make (); 288 | class_expr = X.make (); 289 | class_field = X.make (); 290 | module_type = X.make (); 291 | module_expr = X.make (); 292 | signature_item = X.make (); 293 | structure_item = X.make (); 294 | } 295 | end 296 | end 297 | 298 | module Quotations (X : UnaryS) 299 | : QuotationsMakeS with type 'a x = 'a X.t = struct 300 | module rec Sub : sig 301 | include QuotationsS with type 'a x = 'a X.t 302 | end = struct 303 | include Sub 304 | end 305 | 306 | include Sub 307 | 308 | module Make (X : UnaryMakeS with type 'a t = 'a X.t) = struct 309 | let make () = { 310 | expr = X.make (); 311 | pat = X.make (); 312 | typ = X.make (); 313 | signature = X.make (); 314 | signature_item = X.make (); 315 | structure = X.make (); 316 | structure_item = X.make (); 317 | } 318 | end 319 | end 320 | 321 | module MetapointName = Metapoints (struct type 'a t = string end) 322 | 323 | let metapoint_name : MetapointName.t = 324 | { 325 | expr = "expr"; 326 | pat = "pat"; 327 | typ = "typ"; 328 | class_type = "class_type"; 329 | class_type_field = "class_type_field"; 330 | class_expr = "class_expr"; 331 | class_field = "class_field"; 332 | module_type = "module_type"; 333 | module_expr = "module_expr"; 334 | signature_item = "signature_item"; 335 | structure_item = "structure_item"; 336 | } 337 | 338 | module QuotationName = Quotations (struct type 'a t = string end) 339 | 340 | let quotation_name : QuotationName.t = 341 | { 342 | expr = "expr"; 343 | pat = "pat"; 344 | typ = "typ"; 345 | signature = "signature"; 346 | signature_item = "signature_item"; 347 | structure = "structure"; 348 | structure_item = "structure_item"; 349 | } 350 | 351 | module MetapointsWithMake (X : UnaryMakeS) : MetapointsWithMakeS 352 | with type 'a x = 'a X.t = struct 353 | include Metapoints (X) 354 | 355 | include Make (X) 356 | end 357 | 358 | module QuotationsWithMake (X : UnaryMakeS) : QuotationsWithMakeS 359 | with type 'a x = 'a X.t = struct 360 | include Quotations (X) 361 | 362 | include Make (X) 363 | end 364 | 365 | module type Map = sig 366 | type 'a x 367 | 368 | type 'a y 369 | 370 | val map : 'a x -> 'a y 371 | end 372 | 373 | module MetapointMap (X : MetapointsS) (Y : MetapointsS) 374 | (M : Map with type 'a x = 'a X.x and type 'a y = 'a Y.x) = struct 375 | let map (x : X.t) : Y.t = { 376 | expr = M.map x.expr; 377 | pat = M.map x.pat; 378 | typ = M.map x.typ; 379 | class_type = M.map x.class_type; 380 | class_type_field = M.map x.class_type_field; 381 | class_expr = M.map x.class_expr; 382 | class_field = M.map x.class_field; 383 | module_type = M.map x.module_type; 384 | module_expr = M.map x.module_expr; 385 | signature_item = M.map x.signature_item; 386 | structure_item = M.map x.structure_item; 387 | } 388 | end 389 | 390 | module QuotationMap (X : QuotationsS) (Y : QuotationsS) 391 | (M : Map with type 'a x = 'a X.x and type 'a y = 'a Y.x) = struct 392 | let map (x : X.t) : Y.t = { 393 | expr = M.map x.expr; 394 | pat = M.map x.pat; 395 | typ = M.map x.typ; 396 | signature = M.map x.signature; 397 | signature_item = M.map x.signature_item; 398 | structure = M.map x.structure; 399 | structure_item = M.map x.structure_item; 400 | } 401 | end 402 | 403 | module OptionArray = struct 404 | type 'a t = 'a option array 405 | end 406 | 407 | module OptionArrayMetapoints = Metapoints (OptionArray) 408 | 409 | module LocationArray = struct 410 | type _ t = Location.t array 411 | end 412 | 413 | module MetapointsLocation = Metapoints (LocationArray) 414 | 415 | module rec ArrayQuotation : sig 416 | type context = { 417 | metapoints : OptionArrayMetapoints.t; 418 | loc : MetapointsLocation.t; 419 | subquotations : ArrayQuotations.t; 420 | } 421 | 422 | type 'a quotation = { 423 | context : context; 424 | fill : unit -> 'a; 425 | } 426 | 427 | type 'a t = (unit -> 'a quotation) array 428 | end = struct 429 | include ArrayQuotation 430 | end 431 | and ArrayQuotations : QuotationsS with type 'a x = 'a ArrayQuotation.t = 432 | Quotations (ArrayQuotation) 433 | 434 | type context = ArrayQuotation.context 435 | 436 | let top_context : context option ref = 437 | ref None 438 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.7) 2 | 3 | (generate_opam_files true) 4 | 5 | (name metapp) 6 | (license "BSD-2-Clause") 7 | (maintainers "Thierry Martinez ") 8 | (authors "Thierry Martinez ") 9 | (source (uri "git+https://github.com/thierry-martinez/metapp.git")) 10 | (homepage "https://github.com/thierry-martinez/metapp") 11 | (bug_reports "https://github.com/thierry-martinez/metapp") 12 | (documentation "https://github.com/thierry-martinez/metapp") 13 | (version "0.4.4") 14 | 15 | (package 16 | (name metapp) 17 | (synopsis "Meta-preprocessor for OCaml") 18 | (description "\ 19 | Meta-preprocessor for OCaml: extends the language with [%meta ... ] 20 | construction where ... stands for OCaml code evaluated at 21 | compile-time. 22 | ") 23 | (depends 24 | (ocaml (>= 4.08.0)) 25 | (stdcompat (>= 12)) 26 | (ppxlib (>= 0.22.0)) 27 | (ocamlfind (>= 1.8.1)) 28 | (odoc (and :with-doc (>= 1.5.1))))) 29 | -------------------------------------------------------------------------------- /dyncompile/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name dyncompile) 3 | (public_name metapp.dyncompile) 4 | ; +warning 32: Unused value declaration. 5 | ; +warning 34: Unused type declaration. 6 | ; -warning 40: Constructor or label name used out of scope. (OCaml <=4.06.0) 7 | (flags -open Stdcompat -w +32+34-40) 8 | (libraries compiler-libs stdcompat dynlink)) 9 | -------------------------------------------------------------------------------- /dyncompile/dyncompile.ml: -------------------------------------------------------------------------------- 1 | module Options = Options 2 | 3 | let output_structure (channel : out_channel) (s : Parsetree.structure) = 4 | let fmt = Format.formatter_of_out_channel channel in 5 | Pprintast.structure fmt s; 6 | Format.pp_print_flush fmt () 7 | 8 | type compiler = { 9 | command : string; 10 | archive_option : string; 11 | archive_suffix : string; 12 | } 13 | 14 | let compiler : compiler = 15 | if Dynlink.is_native then { 16 | command = "ocamlopt"; 17 | archive_option = "-shared"; 18 | archive_suffix = ".cmxs"; 19 | } 20 | else { 21 | command = "ocamlc"; 22 | archive_option = "-a"; 23 | archive_suffix = ".cma"; 24 | } 25 | 26 | let format_process_status fmt (ps : Unix.process_status) = 27 | match ps with 28 | | WEXITED return_code -> 29 | Format.fprintf fmt "return code %d" return_code 30 | | WSIGNALED signal -> 31 | Format.fprintf fmt "signal %d" signal 32 | | WSTOPPED signal -> 33 | Format.fprintf fmt "stopped %d" signal 34 | 35 | let fix_compiler_env env = 36 | let channels = Unix.open_process_full "as --version" env in 37 | let (as_stdout, _, as_stderr) = channels in 38 | let _as_stdout = In_channel.input_all as_stdout in 39 | let _as_stderr = In_channel.input_all as_stderr in 40 | match Unix.close_process_full channels with 41 | | WEXITED 0 -> () 42 | | process_status -> 43 | if not (Sys.file_exists "/usr/bin/as") then 44 | failwith "No 'as' in /usr/bin!"; 45 | let index, path = 46 | let exception Result of { index: int; path: string } in 47 | try 48 | env |> Array.iteri (fun index path -> 49 | if String.starts_with ~prefix:"PATH=" path then 50 | raise (Result { index; path })); 51 | failwith "No PATH in env" 52 | with Result { index; path } -> index, path in 53 | env.(index) <- Printf.sprintf "%s:/usr/bin" path 54 | 55 | let rec try_commands ~verbose list = 56 | match list with 57 | | [] -> assert false 58 | | (command, args) :: tl -> 59 | let command_line = Filename.quote_command command args in 60 | if verbose then 61 | prerr_endline command_line; 62 | let env = Unix.environment () in 63 | if not Sys.win32 then fix_compiler_env env; 64 | let channels = Unix.open_process_full command_line env in 65 | let (compiler_stdout, _, compiler_stderr) = channels in 66 | let compiler_stdout = In_channel.input_all compiler_stdout in 67 | let compiler_stderr = In_channel.input_all compiler_stderr in 68 | match Unix.close_process_full channels with 69 | | WEXITED 0 -> () 70 | | WEXITED 127 when tl <> [] -> try_commands ~verbose tl 71 | | process_status -> 72 | Location.raise_errorf ~loc:!Ast_helper.default_loc 73 | "@[Unable@ to@ compile@ preprocessor:@ command-line@ \"%s\"@ \ 74 | failed@ with@ %a@]@,@[stdout: %s@]@,@[stderr: %s@]." 75 | (String.escaped command_line) format_process_status 76 | process_status compiler_stdout compiler_stderr 77 | 78 | let compile (options : Options.t) (source_filename : string) 79 | (object_filename : string) : unit = 80 | let flags = 81 | options.flags @ 82 | List.concat_map (fun directory -> ["-I"; directory]) 83 | options.directories @ 84 | ["-I"; "+compiler-libs"; "-w"; "-40"; compiler.archive_option; 85 | source_filename; "-o"; object_filename] in 86 | let preutils_cmi = "metapp_preutils.cmi" in 87 | let api_cmi = "metapp_api.cmi" in 88 | let dune_preutils_path = "preutils/.metapp_preutils.objs/byte/" in 89 | let dune_api_path = "api/.metapp_api.objs/byte/" in 90 | let (flags, packages) = 91 | if Sys.file_exists preutils_cmi && Sys.file_exists api_cmi then 92 | (flags, options.packages) 93 | else if Sys.file_exists (Filename.concat dune_preutils_path preutils_cmi) && 94 | Sys.file_exists (Filename.concat dune_api_path api_cmi) then 95 | (["-I"; dune_preutils_path; "-I"; dune_api_path] @ flags, 96 | options.packages) 97 | else 98 | (flags, ["metapp.preutils"; "metapp.api"] @ options.packages) in 99 | let commands = 100 | match packages with 101 | | [] -> 102 | [(compiler.command ^ ".opt", flags); (compiler.command, flags)] 103 | | _ -> 104 | [("ocamlfind", 105 | [compiler.command; "-package"; String.concat "," packages] @ 106 | flags)] in 107 | try_commands ~verbose:options.verbose commands 108 | 109 | (* Code taken from pparse.ml (adapted for a channel instead of a filename to use 110 | open_temp_file), because Pparse.write_ast is introduced in OCaml 4.04.0. *) 111 | let write_ast (plainsource : bool) (channel : out_channel) 112 | (structure : Parsetree.structure) : unit = 113 | if plainsource then 114 | output_structure channel structure 115 | else 116 | begin 117 | output_string channel Config.ast_impl_magic_number; 118 | output_value channel !Location.input_name; 119 | output_value channel structure 120 | end 121 | 122 | let compile_and_load (options : Options.t) (structure : Parsetree.structure) 123 | : unit = 124 | let (source_filename, channel) = 125 | Filename.open_temp_file ~mode:[Open_binary] "metapp" ".ml" in 126 | Fun.protect (fun () -> 127 | Fun.protect (fun () -> 128 | write_ast options.plainsource channel structure) 129 | ~finally:(fun () -> close_out channel); 130 | let object_filename = 131 | Filename.remove_extension source_filename ^ 132 | compiler.archive_suffix in 133 | compile options source_filename object_filename; 134 | Unix.chmod object_filename 0o640; 135 | Fun.protect (fun () -> Dynlink.loadfile object_filename) 136 | ~finally:(fun () -> 137 | (* Windows is an OS that does not let deletes occur when the file 138 | is still open. Dynlink.loadfile opens the file and does not close 139 | it even in [at_exit]. It is probably an OCaml bug that there is 140 | not way to close after Dynlink.loadfile, so we mitigate by just 141 | keeping the file around. [dune build] will remove the temporary 142 | directory (ex. build_3d445b_dune) regardless, so no resource leak 143 | when using Dune. *) 144 | if not Sys.win32 then Sys.remove object_filename)) 145 | ~finally:(fun () -> (*Sys.remove source_filename*)()) 146 | -------------------------------------------------------------------------------- /dyncompile/options.ml: -------------------------------------------------------------------------------- 1 | type t = { 2 | packages : string list; 3 | directories : string list; 4 | flags : string list; 5 | plainsource : bool; 6 | debug_findlib : bool; 7 | verbose : bool; 8 | } 9 | 10 | let empty = { 11 | packages = []; 12 | directories = []; 13 | flags = []; 14 | plainsource = false; 15 | debug_findlib = false; 16 | verbose = false; 17 | } 18 | 19 | let rev options = 20 | { options with 21 | packages = List.rev options.packages; 22 | directories = List.rev options.directories; 23 | flags = List.rev options.flags } 24 | 25 | let add_directories directories options = 26 | { options with 27 | directories = List.rev_append directories options.directories } 28 | 29 | let add_packages packages options = 30 | { options with 31 | packages = List.rev_append packages options.packages } 32 | 33 | let add_flags flags options = 34 | { options with 35 | flags = List.rev_append flags options.flags } 36 | 37 | let set_plainsource plainsource options = 38 | { options with plainsource } 39 | 40 | let set_debug_findlib debug_findlib options = 41 | { options with debug_findlib } 42 | 43 | let set_verbose verbose options = 44 | { options with verbose } 45 | -------------------------------------------------------------------------------- /metapp.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | version: "0.4.4" 4 | synopsis: "Meta-preprocessor for OCaml" 5 | description: """ 6 | Meta-preprocessor for OCaml: extends the language with [%meta ... ] 7 | construction where ... stands for OCaml code evaluated at 8 | compile-time. 9 | """ 10 | maintainer: ["Thierry Martinez "] 11 | authors: ["Thierry Martinez "] 12 | license: "BSD-2-Clause" 13 | homepage: "https://github.com/thierry-martinez/metapp" 14 | doc: "https://github.com/thierry-martinez/metapp" 15 | bug-reports: "https://github.com/thierry-martinez/metapp" 16 | depends: [ 17 | "dune" {>= "2.7"} 18 | "ocaml" {>= "4.08.0"} 19 | "stdcompat" {>= "12"} 20 | "ppxlib" {>= "0.22.0"} 21 | "ocamlfind" {>= "1.8.1"} 22 | "odoc" {with-doc & >= "1.5.1"} 23 | ] 24 | build: [ 25 | ["dune" "subst"] {dev} 26 | [ 27 | "dune" 28 | "build" 29 | "-p" 30 | name 31 | "-j" 32 | jobs 33 | "@install" 34 | "@runtest" {with-test} 35 | "@doc" {with-doc} 36 | ] 37 | ] 38 | dev-repo: "git+https://github.com/thierry-martinez/metapp.git" 39 | -------------------------------------------------------------------------------- /metapp/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (public_name metapp) 3 | (preprocess (pps ppxlib.metaquot metapp.ppx)) 4 | (preprocessor_deps "../version_info/metapp_version_info.cmxs") 5 | (library_flags -linkall) 6 | ; +warning 32: Unused value declaration. 7 | ; +warning 34: Unused type declaration. 8 | ; -warning 40: Constructor or label name used out of scope. (OCaml <=4.06.0) 9 | (flags -open Stdcompat -w +32+34-40) 10 | (libraries metapp.version_info ppxlib metapp_preutils stdcompat)) 11 | -------------------------------------------------------------------------------- /metapp/metapp.ml: -------------------------------------------------------------------------------- 1 | [%%metadir "version_info/.metapp_version_info.objs/byte/"] 2 | [%%metaload "version_info/metapp_version_info.cmxs"] 3 | 4 | include (Metapp_preutils : 5 | module type of struct include Metapp_preutils end with 6 | module Exp := Metapp_preutils.Exp and 7 | module Typ := Metapp_preutils.Typ and 8 | module Mod := Metapp_preutils.Mod and 9 | module Mty := Metapp_preutils.Mty) 10 | 11 | let ppxlib_version = [%meta 12 | let major, minor, patch = Metapp_version_info.ppxlib_version in 13 | [%e ( 14 | [%meta Metapp_preutils.Exp.of_int major], 15 | [%meta Metapp_preutils.Exp.of_int minor], 16 | [%meta Metapp_preutils.Exp.of_int patch])]] 17 | 18 | let ast_version = [%meta 19 | let major, minor = Metapp_version_info.ast_version in 20 | [%e ( 21 | [%meta Metapp_preutils.Exp.of_int major], 22 | [%meta Metapp_preutils.Exp.of_int minor])]] 23 | 24 | (** {1 String constant destructor} *) 25 | 26 | type string_constant = { 27 | s : string; 28 | loc : Location.t; 29 | delim : string option; 30 | } 31 | 32 | (** More general reimplementation without magic *) 33 | 34 | let destruct_string_constant (constant : Ppxlib.constant) 35 | : string_constant option = 36 | match constant with 37 | | Pconst_string (s, loc, delim) -> 38 | Some { s; loc; delim } 39 | | _ -> None 40 | 41 | let string_of_expression (expression : Ppxlib.expression) : string_constant = 42 | Ast_helper.with_default_loc expression.pexp_loc @@ fun () -> 43 | match 44 | match expression.pexp_desc with 45 | | Pexp_constant constant -> destruct_string_constant constant 46 | | _ -> None 47 | with 48 | | Some value -> value 49 | | _ -> 50 | Location.raise_errorf ~loc:!Ast_helper.default_loc 51 | "String value expected" 52 | 53 | let string_of_arbitrary_expression (expression : Ppxlib.expression) 54 | : string = 55 | Ast_helper.with_default_loc expression.pexp_loc @@ fun () -> 56 | match 57 | match expression.pexp_desc with 58 | | Pexp_constant constant -> destruct_string_constant constant 59 | | _ -> None 60 | with 61 | | Some value -> value.s 62 | | _ -> 63 | Format.asprintf "%a" Ppxlib.Pprintast.expression expression 64 | 65 | (** {1 Open} *) 66 | 67 | module Opn = struct 68 | [%%meta if Sys.ocaml_version >= "4.08.0" then 69 | [%stri type 'a t = 'a Ppxlib.open_infos] 70 | else [%stri 71 | type 'a t = { 72 | popen_expr : 'a; 73 | popen_override : Asttypes.override_flag; 74 | popen_loc : Location.t; 75 | popen_attributes : Ppxlib.attributes; 76 | }]] 77 | end 78 | 79 | (** {1 General purpose functions} *) 80 | 81 | let rec extract_first (p : 'a -> 'b option) (l : 'a list) 82 | : ('b * 'a list) option = 83 | match l with 84 | | [] -> None 85 | | hd :: tl -> 86 | match p hd with 87 | | Some b -> Some (b, tl) 88 | | None -> 89 | match extract_first p tl with 90 | | Some (b, tl) -> Some (b, hd :: tl) 91 | | None -> None 92 | 93 | type 'a comparer = 'a -> 'a -> int 94 | 95 | let compare_pair compare_fst compare_snd (a, b) (c, d) : int = 96 | let o = compare_fst a c in 97 | if o = 0 then 98 | compare_snd b d 99 | else 100 | o 101 | 102 | let rec compare_list compare_item a b = 103 | match a, b with 104 | | [], [] -> 0 105 | | a_hd :: a_tl, b_hd :: b_tl -> 106 | compare_pair compare_item (compare_list compare_item) (a_hd, a_tl) 107 | (b_hd, b_tl) 108 | | [], _ :: _ -> -1 109 | | _ :: _, [] -> 1 110 | 111 | (** {1 Module binding and declaration} *) 112 | 113 | type module_name = string option 114 | 115 | external module_name_of_string_option : string option -> module_name = 116 | "%identity" 117 | 118 | external string_option_of_module_name : module_name -> string option = 119 | "%identity" 120 | 121 | module Md = struct 122 | let mk ?loc ?attrs (mod_name : string option Location.loc) 123 | (s : Ppxlib.module_type) : Ppxlib.module_declaration = 124 | Ppxlib.Ast_helper.Md.mk ?loc ?attrs 125 | (map_loc module_name_of_string_option mod_name) 126 | s 127 | end 128 | 129 | module Mb = struct 130 | let mk ?loc ?attrs (mod_name : string option Location.loc) 131 | (s : Ppxlib.module_expr) : Ppxlib.module_binding = 132 | Ppxlib.Ast_helper.Mb.mk ?loc ?attrs 133 | (map_loc module_name_of_string_option mod_name) 134 | s 135 | end 136 | 137 | (** {1 Expressions} *) 138 | 139 | module Exp = struct 140 | include Metapp_preutils.Exp 141 | 142 | let send ?loc ?attrs (expression : Ppxlib.expression) 143 | (str : Ppxlib.Ast_helper.str) : Ppxlib.expression = 144 | Ppxlib.Ast_helper.Exp.send ?loc ?attrs expression str 145 | 146 | let newtype ?loc ?attrs (name : Ppxlib.Ast_helper.str) (ty : Ppxlib.expression) 147 | : Ppxlib.expression = 148 | Ppxlib.Ast_helper.Exp.newtype ?loc ?attrs name ty 149 | 150 | let destruct_open (expression : Ppxlib.expression) 151 | : (Ppxlib.module_expr Opn.t * Ppxlib.expression) option = 152 | match expression.pexp_desc with 153 | | Pexp_open (open_decl, expr) -> 154 | Some (open_decl, expr) 155 | | _ -> 156 | None 157 | 158 | let open_ ?loc ?attrs (open_decl : Ppxlib.module_expr Opn.t) 159 | (expr : Ppxlib.expression) : Ppxlib.expression = 160 | Ppxlib.Ast_helper.Exp.open_ ?loc ?attrs open_decl expr 161 | 162 | let tuple_of_payload (payload : Ppxlib.payload) 163 | : Ppxlib.expression list = 164 | match of_payload payload with 165 | | { pexp_desc = Pexp_tuple tuple } -> tuple 166 | | e -> [e] 167 | end 168 | 169 | (** {1 Attribute management} *) 170 | 171 | module Attr = struct 172 | let mk (name : Ppxlib.Ast_helper.str) (payload : Ppxlib.payload) = 173 | Ppxlib.Ast_helper.Attr.mk name payload 174 | 175 | let name (attribute : Ppxlib.attribute) : Ppxlib.Ast_helper.str = 176 | attribute.attr_name 177 | 178 | let payload (attribute : Ppxlib.attribute) : Ppxlib.payload = 179 | attribute.attr_payload 180 | 181 | let to_loc (attribute : Ppxlib.attribute) : Location.t = 182 | attribute.attr_loc 183 | 184 | let find (attr_name : string) (attributes : Ppxlib.attributes) 185 | : Ppxlib.attribute option = 186 | List.find_opt (fun attribute -> 187 | String.equal (name attribute).txt attr_name) attributes 188 | 189 | let chop (attr_name : string) (attributes : Ppxlib.attributes) 190 | : (Ppxlib.attribute * Ppxlib.attributes) option = 191 | extract_first (fun attribute -> 192 | if String.equal (name attribute).txt attr_name then 193 | Some attribute 194 | else 195 | None) attributes 196 | 197 | let get_derivers (attributes : Ppxlib.attributes) 198 | : Ppxlib.expression list option = 199 | match find "deriving" attributes with 200 | | None -> None 201 | | Some derivers -> Some (Exp.tuple_of_payload (payload derivers)) 202 | 203 | let has_deriver (deriver_name : string) (attributes : Ppxlib.attributes) 204 | : (Ppxlib.Asttypes.arg_label * Ppxlib.expression) list option = 205 | Option.bind (get_derivers attributes) 206 | (List.find_map (fun (e : Ppxlib.expression) -> 207 | match e.pexp_desc with 208 | | Pexp_ident { txt = Lident name; _ } 209 | when String.equal name deriver_name -> 210 | Some [] 211 | | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident name; _ }}, args) 212 | when String.equal name deriver_name -> 213 | Some args 214 | | _ -> None)) 215 | end 216 | 217 | (** {1 Pattern} *) 218 | 219 | module Pat = struct 220 | include Metapp_preutils.Pat 221 | 222 | module Construct = struct 223 | module Arg = struct 224 | type t = [%meta 225 | if Metapp_version_info.ast_version >= (4, 14) then 226 | [%t: string Location.loc list * Ppxlib.pattern] 227 | else 228 | [%t: Ppxlib.pattern]] 229 | 230 | let construct types pat = [%meta 231 | if Metapp_version_info.ast_version >= (4, 14) then 232 | [%e (types, pat)] 233 | else 234 | [%e pat]] 235 | 236 | let destruct arg = [%meta 237 | if Metapp_version_info.ast_version >= (4, 14) then 238 | [%e arg] 239 | else 240 | [%e ([], arg)]] 241 | end 242 | end 243 | end 244 | 245 | (** {1 Type declarations} *) 246 | 247 | module Type = struct 248 | let has_deriver (deriver_name : string) 249 | (declarations : Ppxlib.type_declaration list) 250 | : (Ppxlib.Asttypes.arg_label * Ppxlib.expression) list option = 251 | declarations |> List.find_map (fun (decl : Ppxlib.type_declaration) -> 252 | Attr.has_deriver deriver_name decl.ptype_attributes) 253 | end 254 | 255 | (** {1 Extension constructors} *) 256 | 257 | module Te = struct 258 | type decl = { 259 | vars : Ast_helper.str list; 260 | args : Ppxlib.constructor_arguments; 261 | res : Ppxlib.core_type option; 262 | } 263 | 264 | let destruct_decl (ec : Ppxlib.extension_constructor_kind) = [%meta 265 | if Metapp_version_info.ast_version >= (4, 14) then [%e 266 | match ec with 267 | | Pext_decl (vars, args, res) -> Some { vars; args; res } 268 | | Pext_rebind _ -> None] 269 | else [%e 270 | match ec with 271 | | Pext_decl (args, res) -> Some { vars = []; args; res } 272 | | Pext_rebind _ -> None]] 273 | end 274 | 275 | (** {1 Longident} *) 276 | 277 | module Longident = struct 278 | include Longident 279 | 280 | let make ?prefix name = 281 | make_ident ?prefix name 282 | 283 | let rec concat (a : t) (b : t) : t = 284 | match b with 285 | | Lident b -> Ldot (a, b) 286 | | Ldot (m, name) -> Ldot (concat a m, name) 287 | | Lapply (m, x) -> Lapply (concat a m, x) 288 | 289 | let rec compare (a : t) (b : t) : int = 290 | match a, b with 291 | | Lident a, Lident b -> String.compare a b 292 | | Ldot (am, ax), Ldot (bm, bx) -> 293 | compare_pair compare String.compare (am, ax) (bm, bx) 294 | | Lapply (af, am), Lapply (bf, bm) -> 295 | compare_pair compare compare (af, am) (bf, bm) 296 | | Lident _, (Ldot _ | Lapply _) 297 | | Ldot _, Lapply _ -> -1 298 | | Lapply _, Ldot _ -> 1 299 | | (Ldot _ | Lapply _), Lident _ -> 1 300 | 301 | let equal (a : t) (b : t) : bool = 302 | compare a b = 0 303 | 304 | let rec hash (a : t) : int = 305 | match a with 306 | | Lident a -> Hashtbl.hash (1, a) 307 | | Ldot (a, b) -> Hashtbl.hash (hash a, b) 308 | | Lapply (m, x) -> Hashtbl.hash (hash m, hash x) 309 | 310 | let pp (fmt : Format.formatter) (ident : Longident.t) = 311 | Ppxlib.Pprintast.expression fmt (Ppxlib.Ast_helper.Exp.ident (mkloc ident)) 312 | 313 | let show (ident : Longident.t) : string = 314 | Format.asprintf "%a" pp ident 315 | 316 | let of_module_expr_opt (module_expr : Ppxlib.module_expr) 317 | : Longident.t option = 318 | match module_expr.pmod_desc with 319 | | Pmod_ident { txt; _ } -> Some txt 320 | | _ -> None 321 | 322 | let rec of_expression_opt (expression : Ppxlib.expression) : t option = 323 | match expression.pexp_desc with 324 | | Pexp_ident { txt; _ } -> Some txt 325 | | Pexp_construct ({ txt; _ }, None) -> Some txt 326 | | _ -> 327 | Option.bind (Exp.destruct_open expression) (fun (open_decl, expr) -> 328 | Option.bind (of_module_expr_opt open_decl.popen_expr) (fun a -> 329 | Option.map (concat a) (of_expression_opt expr))) 330 | 331 | let of_payload_opt (payload : Ppxlib.payload) : t option = 332 | match payload with 333 | | PStr [{ pstr_desc = Pstr_eval (expression, [])}] -> 334 | of_expression_opt expression 335 | | _ -> None 336 | 337 | let of_payload (payload : Ppxlib.payload) : t = 338 | match of_payload_opt payload with 339 | | Some ident -> ident 340 | | _ -> 341 | Location.raise_errorf ~loc:!Ppxlib.Ast_helper.default_loc "Identifier expected" 342 | end 343 | 344 | let mklid ?prefix name = 345 | mkloc (Longident.make ?prefix name) 346 | 347 | (** {1 Mapper for [[@if bool]] notation} *) 348 | 349 | class filter = 350 | let check_attr (attributes : Ppxlib.attributes) = 351 | match Attr.find "if" attributes with 352 | | None -> true 353 | | Some attr -> bool_of_payload (Attr.payload attr) in 354 | let rec check_pat (p : Ppxlib.pattern) = 355 | begin match p.ppat_desc with 356 | | Ppat_constraint (p, _) -> check_pat p 357 | | _ -> false 358 | end || 359 | check_attr p.ppat_attributes in 360 | let check_value_binding (binding : Ppxlib.value_binding) = 361 | check_attr binding.pvb_attributes in 362 | let check_value_description (description : Ppxlib.value_description) = 363 | check_attr description.pval_attributes in 364 | let check_case (case : Ppxlib.case) = 365 | check_pat case.pc_lhs in 366 | let check_expr (e : Ppxlib.expression) = 367 | check_attr e.pexp_attributes in 368 | let check_pat_snd (type a) (arg : a * Ppxlib.pattern) = 369 | check_pat (snd arg) in 370 | let check_expr_snd (type a) (arg : a * Ppxlib.expression) = 371 | check_expr (snd arg) in 372 | let check_type_declaration (declaration : Ppxlib.type_declaration) = 373 | check_attr declaration.ptype_attributes in 374 | let check_constructor (c : Ppxlib.constructor_declaration) = 375 | check_attr c.pcd_attributes 376 | in 377 | let check_label (l: Ppxlib.label_declaration) = 378 | check_attr l.pld_attributes 379 | in 380 | object 381 | inherit Ppxlib.Ast_traverse.map as super 382 | 383 | method! type_declaration (t : Ppxlib.type_declaration) : Ppxlib.type_declaration = 384 | let t = super#type_declaration t in 385 | match t.ptype_kind with 386 | | Ptype_variant cons -> 387 | let cons = List.filter check_constructor cons in 388 | { t with ptype_kind = Ptype_variant cons } 389 | | Ptype_record labels -> 390 | begin match List.filter check_label labels with 391 | | [] -> Location.raise_errorf ~loc:t.ptype_loc "Empty records are not allowed" 392 | | labels -> { t with ptype_kind = Ptype_record labels } 393 | end 394 | | _ -> t 395 | 396 | method! pattern (p : Ppxlib.pattern) : Ppxlib.pattern = 397 | let p = 398 | match p with 399 | | [%pat? [%p? hd] :: [%p? tl]] when not (check_pat hd) -> tl 400 | | _ -> p in 401 | let p = super#pattern p in 402 | match p.ppat_desc with 403 | | Ppat_tuple args -> 404 | begin match List.filter check_pat args with 405 | | [] -> Pat.of_unit () 406 | | [singleton] -> singleton 407 | | args -> { p with ppat_desc = Ppat_tuple args } 408 | end 409 | | Ppat_construct (lid, Some arg) -> 410 | let _, pat = Pat.Construct.Arg.destruct arg in 411 | if check_pat pat then 412 | p 413 | else 414 | { p with ppat_desc = Ppat_construct (lid, None)} 415 | | Ppat_variant (label, Some arg) -> 416 | if check_pat arg then 417 | p 418 | else 419 | { p with ppat_desc = Ppat_variant (label, None)} 420 | | Ppat_record (fields, closed_flag) -> 421 | begin match List.filter check_pat_snd fields with 422 | | [] -> { p with ppat_desc = Ppat_any } 423 | | fields -> { p with ppat_desc = Ppat_record (fields, closed_flag)} 424 | end 425 | | Ppat_array args -> 426 | { p with ppat_desc = Ppat_array (List.filter check_pat args)} 427 | | Ppat_or (a, b) when not (check_pat a) -> b 428 | | Ppat_or (a, b) when not (check_pat b) -> a 429 | | _ -> p 430 | 431 | method! expression (e : Ppxlib.expression) : Ppxlib.expression = 432 | Ppxlib.Ast_helper.with_default_loc e.pexp_loc @@ fun () -> 433 | let e = 434 | match e with 435 | | [%expr [%e? hd] :: [%e? tl]] when not (check_expr hd) -> tl 436 | | _ -> e in 437 | let e = super#expression e in 438 | match e.pexp_desc with 439 | | Pexp_let (rec_flag, bindings, body) -> 440 | begin match List.filter check_value_binding bindings with 441 | | [] -> body 442 | | bindings -> 443 | { e with pexp_desc = Pexp_let (rec_flag, bindings, body) } 444 | end 445 | | Pexp_fun (_label, _default, pat, body) when not (check_pat pat) -> 446 | body 447 | | Pexp_function cases -> 448 | { e with pexp_desc = Pexp_function (List.filter check_case cases)} 449 | | Pexp_apply (f, args) -> 450 | let items = 451 | List.filter check_expr_snd ((Ppxlib.Asttypes.Nolabel, f) :: args) in 452 | begin match 453 | extract_first 454 | (function (Ppxlib.Asttypes.Nolabel, f) -> Some f | _ -> None) 455 | items 456 | with 457 | | None -> 458 | Location.raise_errorf ~loc:!Ppxlib.Ast_helper.default_loc 459 | "No function left in this application" 460 | | Some (e, []) -> e 461 | | Some (f, args) -> 462 | { e with pexp_desc = Pexp_apply (f, args)} 463 | end 464 | | Pexp_match (e, cases) -> 465 | { e with pexp_desc = Pexp_match (e, List.filter check_case cases)} 466 | | Pexp_try (e, cases) -> 467 | { e with pexp_desc = Pexp_try (e, List.filter check_case cases)} 468 | | Pexp_tuple args -> 469 | begin match List.filter check_expr args with 470 | | [] -> Exp.of_unit () 471 | | [singleton] -> singleton 472 | | args -> { e with pexp_desc = Pexp_tuple args } 473 | end 474 | | Pexp_construct (lid, Some arg) -> 475 | if check_expr arg then 476 | e 477 | else 478 | { e with pexp_desc = Pexp_construct (lid, None)} 479 | | Pexp_variant (label, Some arg) -> 480 | if check_expr arg then 481 | e 482 | else 483 | { e with pexp_desc = Pexp_variant (label, None)} 484 | | Pexp_record (fields, base) -> 485 | let base = 486 | match base with 487 | | Some expr when check_expr expr -> base 488 | | _ -> None in 489 | let fields = List.filter check_expr_snd fields in 490 | if fields = [] then 491 | Location.raise_errorf ~loc:!Ppxlib.Ast_helper.default_loc 492 | "Cannot construct an empty record"; 493 | { e with pexp_desc = Pexp_record (fields, base)} 494 | | Pexp_array args -> 495 | { e with pexp_desc = Pexp_array (List.filter check_expr args)} 496 | | Pexp_sequence (a, b) when not (check_expr a) -> b 497 | | Pexp_sequence (a, b) when not (check_expr b) -> a 498 | | _ -> e 499 | 500 | method! structure_item (item : Ppxlib.structure_item) : 501 | Ppxlib.structure_item = 502 | let item = super#structure_item item in 503 | match item.pstr_desc with 504 | | Pstr_value (rec_flag, bindings) -> 505 | begin match List.filter check_value_binding bindings with 506 | | [] -> Stri.of_list [] 507 | | bindings -> { item with pstr_desc = Pstr_value (rec_flag, bindings)} 508 | end 509 | | Pstr_primitive description 510 | when not (check_value_description description) -> 511 | Stri.of_list [] 512 | | Pstr_type (rec_flag, declarations) -> 513 | { item with pstr_desc = 514 | Pstr_type 515 | (rec_flag, List.filter check_type_declaration declarations)} 516 | | _ -> item 517 | 518 | method! signature_item (item : Ppxlib.signature_item) : 519 | Ppxlib.signature_item = 520 | let item = super#signature_item item in 521 | match item.psig_desc with 522 | | Psig_value description when not (check_value_description description) -> 523 | Sigi.of_list [] 524 | | Psig_type (rec_flag, declarations) -> 525 | { item with psig_desc = 526 | Psig_type 527 | (rec_flag, List.filter check_type_declaration declarations)} 528 | | _ -> item 529 | end 530 | 531 | (** {1 Type construction} *) 532 | 533 | module Typ = struct 534 | include Metapp_preutils.Typ 535 | 536 | let poly (names : Ppxlib.Ast_helper.str list) (ty : Ppxlib.core_type) 537 | : Ppxlib.core_type = 538 | Ppxlib.Ast_helper.Typ.poly names ty 539 | 540 | let poly_name name = 541 | (name : Ppxlib.Ast_helper.str).txt 542 | end 543 | 544 | (** {1 Row fields} *) 545 | 546 | module Rf = struct 547 | type desc = Ppxlib.row_field_desc = 548 | | Rtag of Asttypes.label Location.loc * bool * Ppxlib.core_type list 549 | | Rinherit of Ppxlib.core_type 550 | 551 | let to_loc (rf : Ppxlib.row_field) : Location.t = 552 | rf.prf_loc 553 | 554 | let to_attributes (rf : Ppxlib.row_field) : Ppxlib.attributes = 555 | rf.prf_attributes 556 | 557 | let destruct (rf : Ppxlib.row_field) : desc = 558 | rf.prf_desc 559 | 560 | let tag ?loc:_loc ?attrs (label : Ppxlib.Asttypes.label Location.loc) 561 | (has_constant : bool) (args : Ppxlib.core_type list) 562 | : Ppxlib.row_field = 563 | Ppxlib.Ast_helper.Rf.tag ?loc:_loc ?attrs label has_constant args 564 | 565 | let inherit_ ?loc:_loc ?attrs:_attrs (core_type : Ppxlib.core_type) 566 | : Ppxlib.row_field = 567 | Ppxlib.Ast_helper.Rf.mk ?loc:_loc ?attrs:_attrs (Rinherit core_type) 568 | end 569 | 570 | (** {1 Object fields} *) 571 | 572 | module Of = struct 573 | type t = Ppxlib.object_field 574 | 575 | type desc = Ppxlib.object_field_desc = 576 | | Otag of Asttypes.label Location.loc * Ppxlib.core_type 577 | | Oinherit of Ppxlib.core_type 578 | 579 | let to_loc (of_ : t) : Location.t = 580 | of_.pof_loc 581 | 582 | let to_attributes (of_ : t) : Ppxlib.attributes = 583 | of_.pof_attributes 584 | 585 | let destruct (of_ : t) : desc = 586 | of_.pof_desc 587 | 588 | let tag ?loc:_loc ?attrs (label : Asttypes.label Location.loc) 589 | (ty : Ppxlib.core_type) : t = 590 | Ppxlib.Ast_helper.Of.tag ?loc:_loc ?attrs label ty 591 | 592 | let inherit_ ?loc:_loc ?attrs:_attrs (_ty : Ppxlib.core_type) : t = 593 | Ppxlib.Ast_helper.Of.mk ?loc:_loc ?attrs:_attrs (Oinherit _ty) 594 | end 595 | 596 | (** {1 Module expressions} *) 597 | 598 | type functor_parameter = Ppxlib.functor_parameter = 599 | | Unit 600 | | Named of string option Location.loc * Ppxlib.module_type 601 | 602 | module type FunctorS = sig 603 | type t 604 | 605 | val functor_ : 606 | ?loc:Location.t -> ?attrs:Ppxlib.attributes -> functor_parameter -> 607 | t -> t 608 | 609 | val destruct_functor : t -> (functor_parameter * t) option 610 | end 611 | 612 | module type ModS = sig 613 | include ExtensibleS 614 | 615 | include FunctorS with type t := t 616 | end 617 | 618 | module Mod = struct 619 | include Metapp_preutils.Mod 620 | 621 | let functor_ ?loc ?attrs (parameter : functor_parameter) 622 | (body : Ppxlib.module_expr) : Ppxlib.module_expr = 623 | Ppxlib.Ast_helper.Mod.functor_ ?loc ?attrs parameter body 624 | 625 | let destruct_functor (modtype : Ppxlib.module_expr) 626 | : (functor_parameter * Ppxlib.module_expr) option = 627 | match modtype.pmod_desc with 628 | | Pmod_functor (f, s) -> 629 | Some (f, s) 630 | | _ -> None 631 | end 632 | 633 | (** {1 Module types} *) 634 | 635 | module Mty = struct 636 | include Metapp_preutils.Mty 637 | 638 | let functor_ ?loc ?attrs (parameter : functor_parameter) 639 | (body : Ppxlib.module_type) : Ppxlib.module_type = 640 | Ppxlib.Ast_helper.Mty.functor_ ?loc ?attrs parameter body 641 | 642 | let destruct_functor (modtype : Ppxlib.module_type) 643 | : (functor_parameter * Ppxlib.module_type) option = 644 | match modtype.pmty_desc with 645 | | Pmty_functor (f, s) -> 646 | Some (f, s) 647 | | _ -> None 648 | end 649 | 650 | let _anonymous_module_unsupported = 651 | "Anonymous modules are not supported with OCaml <4.10.0" 652 | 653 | module Types = struct 654 | (** {1 Signature type destruction} *) 655 | 656 | [%%meta if Sys.ocaml_version >= "4.08.0" then [%stri 657 | type visibility = Types.visibility = 658 | | Exported 659 | | Hidden] 660 | else [%stri 661 | type visibility = 662 | | Exported 663 | | Hidden]] 664 | 665 | module Sigi = struct 666 | type sig_type = { 667 | id : Ident.t; 668 | decl : Types.type_declaration; 669 | rec_status : Types.rec_status; 670 | visibility : visibility; 671 | } 672 | 673 | let sig_type (sig_type : sig_type) : Types.signature_item = 674 | [%meta if Sys.ocaml_version >= "4.08.0" then [%expr 675 | Sig_type ( 676 | sig_type.id, sig_type.decl, sig_type.rec_status, sig_type.visibility)] 677 | else [%expr 678 | Sig_type ( 679 | sig_type.id, sig_type.decl, sig_type.rec_status)]] 680 | 681 | let destruct_sig_type (item : Types.signature_item) : sig_type option = 682 | [%meta if Sys.ocaml_version >= "4.08.0" then [%expr 683 | match item with 684 | | Sig_type (id, decl, rec_status, visibility) -> 685 | Some { id; decl; rec_status; visibility } 686 | | _ -> None] 687 | else [%expr 688 | match item with 689 | | Sig_type (id, decl, rec_status) -> 690 | Some { id; decl; rec_status; visibility = Exported } 691 | | _ -> None]] 692 | end 693 | 694 | (** {1 Module types in Types} *) 695 | 696 | [%%meta Metapp_preutils.Stri.of_list ( 697 | if Sys.ocaml_version >= "4.10.0" then [%str 698 | type functor_parameter = Types.functor_parameter = 699 | | Unit 700 | | Named of Ident.t option * Types.module_type] 701 | else [%str 702 | type functor_parameter = 703 | | Unit 704 | | Named of Ident.t option * Types.module_type 705 | 706 | let construct_functor_parameter x t = 707 | match t with 708 | | None -> Unit 709 | | Some t -> Named (Option.some x, t) 710 | 711 | let destruct_functor_parameter p = 712 | match p with 713 | | Unit -> Ident.create_persistent "", None 714 | | Named (ident_opt, t) -> 715 | match ident_opt with 716 | | None -> invalid_arg _anonymous_module_unsupported 717 | | Some ident -> ident, Some t 718 | ])] 719 | 720 | module Mty = struct 721 | let functor_ (parameter : functor_parameter) 722 | (body : Types.module_type) : Types.module_type = 723 | [%meta if Sys.ocaml_version >= "4.10.0" then 724 | [%e Mty_functor (parameter, body)] 725 | else [%e 726 | let x, t = destruct_functor_parameter parameter in 727 | Mty_functor (x, t, body)]] 728 | 729 | let destruct_functor (modtype : Types.module_type) 730 | : (functor_parameter * Types.module_type) option = 731 | match modtype with 732 | | [%meta if Sys.ocaml_version >= "4.10.0" then 733 | [%p? Mty_functor (f, s)] 734 | else 735 | [%p? Mty_functor (x, t, s)]] -> 736 | [%meta if Sys.ocaml_version >= "4.10.0" then 737 | [%e Some (f, s)] 738 | else 739 | [%e Some (construct_functor_parameter x t, s)]] 740 | | _ -> None 741 | 742 | let destruct_alias (modtype : Types.module_type) : Path.t option = 743 | match modtype with 744 | | [%meta 745 | if Sys.ocaml_version >= "4.08.0" || Sys.ocaml_version < "4.04.0" then 746 | [%p? Mty_alias p] 747 | else 748 | [%p? Mty_alias (_, p)]] -> Some p 749 | | _ -> None 750 | end 751 | 752 | [%%meta if Sys.ocaml_version >= "4.13.0" then [%stri 753 | type variant_representation = Types.variant_representation = 754 | | Variant_regular 755 | | Variant_unboxed] 756 | else [%stri 757 | type variant_representation = 758 | | Variant_regular 759 | | Variant_unboxed]] 760 | 761 | let destruct_type_variant type_kind = 762 | [%meta if Sys.ocaml_version >= "4.13.0" then [%e 763 | match type_kind with 764 | | Types.Type_variant (list, repr) -> Some (list, repr) 765 | | _ -> None] 766 | else [%e 767 | match type_kind with 768 | | Types.Type_variant list -> Some (list, Variant_unboxed) 769 | | _ -> None]] 770 | 771 | let destruct_tpackage (type_desc : Types.type_desc) = 772 | [%meta if Sys.ocaml_version >= "4.13.0" then [%e 773 | match type_desc with 774 | | Tpackage (path, list) -> Some (path, list) 775 | | _ -> None] 776 | else [%e 777 | match type_desc with 778 | | Tpackage (path, idl, tyl) -> Some (path, List.combine idl tyl) 779 | | _ -> None]] 780 | 781 | let get_desc (type_expr : Types.type_expr) : Types.type_desc = 782 | [%meta if Sys.ocaml_version >= "4.14.0" then [%e 783 | Types.get_desc type_expr] 784 | else [%e 785 | type_expr.desc]] 786 | 787 | let get_level (type_expr : Types.type_expr) : int = 788 | [%meta if Sys.ocaml_version >= "4.14.0" then [%e 789 | Types.get_level type_expr] 790 | else [%e 791 | type_expr.level]] 792 | 793 | let get_scope (type_expr : Types.type_expr) : int = 794 | [%meta if Sys.ocaml_version >= "4.14.0" then [%e 795 | Types.get_scope type_expr] 796 | else [%e 797 | type_expr.scope]] 798 | 799 | let get_id (type_expr : Types.type_expr) : int = 800 | [%meta if Sys.ocaml_version >= "4.14.0" then [%e 801 | Types.get_level type_expr] 802 | else [%e 803 | type_expr.id]] 804 | end 805 | 806 | (** {1 With constraint} *) 807 | 808 | module With = struct 809 | let typesubst ?t (decl : Ppxlib.type_declaration) 810 | : Ppxlib.with_constraint = 811 | let t = 812 | match t with 813 | | None -> lid_of_str decl.ptype_name 814 | | Some t -> t in 815 | Ppxlib.Pwith_typesubst (t, decl) 816 | 817 | let destruct_typesubst (cstr : Ppxlib.with_constraint) 818 | : (Ppxlib.Ast_helper.lid * Ppxlib.type_declaration) option = 819 | match cstr with 820 | | Pwith_typesubst (t, decl) -> Some (t, decl) 821 | | _ -> None 822 | 823 | let modsubst (x : Ppxlib.Ast_helper.lid) (y : Ppxlib.Ast_helper.lid) 824 | : Ppxlib.with_constraint = 825 | Ppxlib.Pwith_modsubst (x, y) 826 | 827 | let destruct_modsubst (cstr : Ppxlib.with_constraint) 828 | : (Ppxlib.Ast_helper.lid * Ppxlib.Ast_helper.lid) option = 829 | match cstr with 830 | | Pwith_modsubst (x, y) -> Some (x, y) 831 | | _ -> None 832 | end 833 | -------------------------------------------------------------------------------- /metapp/metapp.mli: -------------------------------------------------------------------------------- 1 | [%%metadir "version_info/.metapp_version_info.objs/byte/"] 2 | [%%metaload "version_info/metapp_version_info.cmxs"] 3 | 4 | val ppxlib_version : int * int * int 5 | 6 | val ast_version : int * int 7 | 8 | (** {1 String constant destructor} *) 9 | 10 | type string_constant = { 11 | s : string; 12 | loc : Location.t; 13 | delim : string option; 14 | } 15 | 16 | val destruct_string_constant : Ppxlib.constant -> string_constant option 17 | 18 | (** {1 Coercions} *) 19 | 20 | val int_of_expression : Ppxlib.expression -> int 21 | 22 | val string_of_expression : Ppxlib.expression -> string_constant 23 | 24 | val string_of_arbitrary_expression : Ppxlib.expression -> string 25 | 26 | val bool_of_expression : Ppxlib.expression -> bool 27 | 28 | val pair_of_expression : 29 | Ppxlib.expression -> Ppxlib.expression * Ppxlib.expression 30 | 31 | val list_of_expression : Ppxlib.expression -> Ppxlib.expression list 32 | 33 | val list_of_tuple : Ppxlib.expression -> Ppxlib.expression list 34 | 35 | val structure_of_expression : Ppxlib.expression -> Ppxlib.structure 36 | 37 | val lid_of_str : Ast_helper.str -> Ast_helper.lid 38 | 39 | val sequence : Ppxlib.expression list -> Ppxlib.expression 40 | 41 | (** {1 Payload construction and extraction} *) 42 | 43 | val int_of_payload : Ppxlib.payload -> int 44 | 45 | val payload_of_int : int -> Ppxlib.payload 46 | 47 | val string_of_payload : Ppxlib.payload -> string 48 | 49 | val bool_of_payload : Ppxlib.payload -> bool 50 | 51 | (** {1 Location management} *) 52 | 53 | val mkloc : 'a -> 'a Location.loc 54 | 55 | val map_loc : ('a -> 'b) -> 'a Location.loc -> 'b Location.loc 56 | 57 | val with_loc : ('a -> 'b) -> 'a Location.loc -> 'b 58 | 59 | (** {1 Longident } *) 60 | 61 | type 'a comparer = 'a -> 'a -> int 62 | 63 | module Longident : sig 64 | type t = Longident.t 65 | 66 | val compare : t comparer 67 | 68 | val equal : t -> t -> bool 69 | 70 | val hash : t -> int 71 | 72 | val pp : Format.formatter -> t -> unit 73 | 74 | val show : t -> string 75 | 76 | val make : ?prefix : t -> string -> t 77 | 78 | val concat : Longident.t -> t -> Longident.t 79 | 80 | val of_module_expr_opt : Ppxlib.module_expr -> Longident.t option 81 | 82 | val of_expression_opt : Ppxlib.expression -> Longident.t option 83 | 84 | val of_payload_opt : Ppxlib.payload -> Longident.t option 85 | 86 | val of_payload : Ppxlib.payload -> Longident.t 87 | end 88 | 89 | val mklid : ?prefix : Longident.t -> string -> Ast_helper.lid 90 | 91 | (** {1 Constructing function application} *) 92 | 93 | val nolabel : 'a -> Ppxlib.Asttypes.arg_label * 'a 94 | 95 | val nolabels : 'a list -> (Ppxlib.Asttypes.arg_label * 'a) list 96 | 97 | val apply : 98 | ?attrs : Ppxlib.attributes -> Ppxlib.expression -> 99 | ?labels : (string * Ppxlib.expression) list -> 100 | ?optional : (string * Ppxlib.expression) list -> 101 | Ppxlib.expression list -> Ppxlib.expression 102 | 103 | (** {1 Generic signature for visitable nodes} *) 104 | 105 | type 'a iter = 'a -> unit 106 | 107 | type 'a map = 'a -> 'a 108 | 109 | module type VisitableS = sig 110 | type t 111 | 112 | val to_loc : t -> Location.t 113 | 114 | val iter : #Ppxlib.Ast_traverse.iter -> t iter 115 | 116 | val map : #Ppxlib.Ast_traverse.map -> t map 117 | end 118 | 119 | (** {1 Generic signature for extensible nodes} *) 120 | 121 | type destruct_extension = Ppxlib.extension * Ppxlib.attributes 122 | 123 | module type ExtensibleS = sig 124 | include VisitableS 125 | 126 | val extension : ?attrs:Ppxlib.attributes -> Ppxlib.extension -> t 127 | 128 | val destruct_extension : t -> destruct_extension option 129 | end 130 | 131 | module type PayloadS = sig 132 | type t 133 | 134 | val of_payload : Ppxlib.payload -> t 135 | 136 | val to_payload : t -> Ppxlib.payload 137 | end 138 | 139 | module type ItemS = sig 140 | include ExtensibleS 141 | 142 | include PayloadS with type t := t 143 | 144 | val of_list : t list -> t 145 | end 146 | 147 | module Cty : ExtensibleS with type t = Ppxlib.class_type 148 | 149 | module Ctf : ExtensibleS with type t = Ppxlib.class_type_field 150 | 151 | module Cl : ExtensibleS with type t = Ppxlib.class_expr 152 | 153 | module Cf : ExtensibleS with type t = Ppxlib.class_field 154 | 155 | module Stri : ItemS with type t := Ppxlib.structure_item 156 | 157 | module Str : sig 158 | include VisitableS with type t = Ppxlib.structure 159 | 160 | include PayloadS with type t := Ppxlib.structure 161 | end 162 | 163 | module Sigi : ItemS with type t := Ppxlib.signature_item 164 | 165 | module Sig : sig 166 | include VisitableS with type t = Ppxlib.signature 167 | 168 | include PayloadS with type t := Ppxlib.signature 169 | end 170 | 171 | (** {1 Module expressions} *) 172 | 173 | type functor_parameter = Ppxlib.functor_parameter = 174 | | Unit 175 | | Named of string option Location.loc * Ppxlib.module_type 176 | 177 | module type FunctorS = sig 178 | type t 179 | 180 | val functor_ : 181 | ?loc:Location.t -> ?attrs:Ppxlib.attributes -> functor_parameter -> 182 | t -> t 183 | 184 | val destruct_functor : t -> (functor_parameter * t) option 185 | end 186 | 187 | module type ModS = sig 188 | include ExtensibleS 189 | 190 | include FunctorS with type t := t 191 | end 192 | 193 | module Mod : ModS with type t = Ppxlib.module_expr 194 | 195 | (** {1 Module types} *) 196 | 197 | module Mty : ModS with type t = Ppxlib.module_type 198 | 199 | module Types : sig 200 | (** {1 Signature type destruction} *) 201 | 202 | [%%meta if Sys.ocaml_version >= "4.08.0" then [%sigi: 203 | type visibility = Types.visibility = 204 | | Exported 205 | | Hidden] 206 | else [%sigi: 207 | type visibility = 208 | | Exported 209 | | Hidden]] 210 | 211 | module Sigi : sig 212 | type sig_type = { 213 | id : Ident.t; 214 | decl : Types.type_declaration; 215 | rec_status : Types.rec_status; 216 | visibility : visibility; 217 | } 218 | 219 | val sig_type : sig_type -> Types.signature_item 220 | 221 | val destruct_sig_type : Types.signature_item -> sig_type option 222 | end 223 | 224 | 225 | (** {1 Module types in Types} *) 226 | 227 | [%%meta if Sys.ocaml_version >= "4.10.0" then [%sigi: 228 | type functor_parameter = Types.functor_parameter = 229 | | Unit 230 | | Named of Ident.t option * Types.module_type] 231 | else [%sigi: 232 | type functor_parameter = 233 | | Unit 234 | | Named of Ident.t option * Types.module_type]] 235 | 236 | module Mty : sig 237 | val functor_ : functor_parameter -> Types.module_type -> Types.module_type 238 | 239 | val destruct_functor : 240 | Types.module_type -> (functor_parameter * Types.module_type) option 241 | 242 | val destruct_alias : Types.module_type -> Path.t option 243 | end 244 | 245 | [%%meta if Sys.ocaml_version >= "4.13.0" then [%sigi: 246 | type variant_representation = Types.variant_representation = 247 | | Variant_regular 248 | | Variant_unboxed] 249 | else [%sigi: 250 | type variant_representation = 251 | | Variant_regular 252 | | Variant_unboxed]] 253 | 254 | (** [destruct_type_variant type_kind] returns a pair [Some (ctors, repr)] 255 | if [type_kind] is a [Type_variant], for compatibility between OCaml 4.13 256 | and older versions of OCaml. *) 257 | [%%meta if Sys.ocaml_version >= "4.13.0" then [%sigi: 258 | val destruct_type_variant : ('lbl, 'cstr) Types.type_kind -> 259 | ('cstr list * variant_representation) option] 260 | else [%sigi: 261 | val destruct_type_variant : Types.type_kind -> 262 | (Types.constructor_declaration list * variant_representation) option]] 263 | 264 | (** [destruct_tpackage type_desc] returns a pair [Some (path, list)] 265 | if [type_desc] is a [Tpackage], for compatibility between OCaml 4.13 266 | and older versions of OCaml. *) 267 | val destruct_tpackage : 268 | Types.type_desc -> (Path.t * (Longident.t * Types.type_expr) list) option 269 | 270 | val get_desc : Types.type_expr -> Types.type_desc 271 | (** Getter for [type_expr] introduced in OCaml 4.14 *) 272 | 273 | val get_level : Types.type_expr -> int 274 | (** Getter for [type_expr] introduced in OCaml 4.14 *) 275 | 276 | val get_scope : Types.type_expr -> int 277 | (** Getter for [type_expr] introduced in OCaml 4.14 *) 278 | 279 | val get_id : Types.type_expr -> int 280 | (** Getter for [type_expr] introduced in OCaml 4.14 *) 281 | end 282 | 283 | (** {1 Generic signature for expressions and patterns} *) 284 | 285 | module type ValueS = sig 286 | include ExtensibleS 287 | 288 | val var : ?attrs:Ppxlib.attributes -> string -> t 289 | 290 | val of_constant : ?attrs:Ppxlib.attributes -> Ppxlib.constant -> t 291 | 292 | val of_bytes : ?attrs:Ppxlib.attributes -> bytes -> t 293 | 294 | val force_tuple : ?attrs:Ppxlib.attributes -> t list -> t 295 | 296 | val force_construct : 297 | ?attrs:Ppxlib.attributes -> Ast_helper.lid -> t option -> t 298 | 299 | val array : ?attrs:Ppxlib.attributes -> t list -> t 300 | 301 | val record : ?attrs:Ppxlib.attributes -> (Longident.t * t) list -> t 302 | 303 | val variant : ?attrs:Ppxlib.attributes -> string -> t option -> t 304 | 305 | val lazy_ : ?attrs:Ppxlib.attributes -> t -> t 306 | 307 | val choice : 308 | (unit -> Ppxlib.expression) -> (unit -> Ppxlib.pattern) -> t 309 | 310 | include PayloadS with type t := t 311 | 312 | val of_int : ?attrs:Ppxlib.attributes -> int -> t 313 | 314 | val of_string : ?attrs:Ppxlib.attributes -> string -> t 315 | 316 | val of_char : ?attrs:Ppxlib.attributes -> char -> t 317 | 318 | val of_unit : ?attrs:Ppxlib.attributes -> unit -> t 319 | 320 | val of_bool : ?attrs:Ppxlib.attributes -> bool -> t 321 | 322 | val of_float : ?attrs:Ppxlib.attributes -> float -> t 323 | 324 | val of_int32 : ?attrs:Ppxlib.attributes -> int32 -> t 325 | 326 | val of_int64 : ?attrs:Ppxlib.attributes -> int64 -> t 327 | 328 | val of_nativeint : ?attrs:Ppxlib.attributes -> nativeint -> t 329 | 330 | val none : ?attrs:Ppxlib.attributes -> unit -> t 331 | 332 | val some : ?attrs:Ppxlib.attributes -> t -> t 333 | 334 | val option : ?attrs:Ppxlib.attributes -> t option -> t 335 | 336 | val of_longident : Longident.t -> t 337 | 338 | val construct : ?attrs:Ppxlib.attributes -> Longident.t -> t list -> t 339 | 340 | val tuple : ?attrs:Ppxlib.attributes -> t list -> t 341 | 342 | val nil : ?attrs:Ppxlib.attributes -> ?prefix:Longident.t -> unit -> t 343 | 344 | val cons : ?attrs:Ppxlib.attributes -> ?prefix:Longident.t -> t -> t -> t 345 | 346 | val list : 347 | ?attrs:Ppxlib.attributes -> ?prefix:Longident.t -> t list -> t 348 | end 349 | 350 | module Pat : sig 351 | include ValueS with type t = Ppxlib.pattern 352 | 353 | module Construct : sig 354 | module Arg : sig 355 | type t = [%meta 356 | if Metapp_version_info.ast_version >= (4, 14) then 357 | [%t: string Location.loc list * Ppxlib.pattern] 358 | else 359 | [%t: Ppxlib.pattern]] 360 | 361 | val construct : string Location.loc list -> Ppxlib.pattern -> t 362 | 363 | val destruct : t -> string Location.loc list * Ppxlib.pattern 364 | end 365 | end 366 | end 367 | 368 | type value = { 369 | exp : Ppxlib.expression; 370 | pat : Ppxlib.pattern; 371 | } 372 | 373 | module Value : ValueS with type t = value 374 | 375 | (** {1 Attribute management} *) 376 | 377 | module Attr : sig 378 | val mk : Ast_helper.str -> Ppxlib.payload -> Ppxlib.attribute 379 | 380 | val name : Ppxlib.attribute -> Ast_helper.str 381 | 382 | val payload : Ppxlib.attribute -> Ppxlib.payload 383 | 384 | val to_loc : Ppxlib.attribute -> Location.t 385 | 386 | val find : string -> Ppxlib.attributes -> Ppxlib.attribute option 387 | 388 | val chop : 389 | string -> Ppxlib.attributes -> 390 | (Ppxlib.attribute * Ppxlib.attributes) option 391 | 392 | val get_derivers : Ppxlib.attributes -> Ppxlib.expression list option 393 | 394 | val has_deriver : 395 | string -> Ppxlib.attributes -> 396 | (Ppxlib.Asttypes.arg_label * Ppxlib.expression) list option 397 | end 398 | 399 | (** {1 Module binding and declaration} *) 400 | 401 | type module_name = string option 402 | 403 | external module_name_of_string_option : string option -> module_name = 404 | "%identity" 405 | 406 | external string_option_of_module_name : module_name -> string option = 407 | "%identity" 408 | 409 | module Md : sig 410 | val mk : 411 | ?loc:Location.t -> ?attrs:Ppxlib.attributes -> 412 | string option Location.loc -> Ppxlib.module_type -> 413 | Ppxlib.module_declaration 414 | end 415 | 416 | module Mb : sig 417 | val mk : 418 | ?loc:Location.t -> ?attrs:Ppxlib.attributes -> 419 | string option Location.loc -> Ppxlib.module_expr -> 420 | Ppxlib.module_binding 421 | end 422 | 423 | (** {1 Mapper for [[@if bool]] notation} *) 424 | 425 | class filter : Ppxlib.Ast_traverse.map 426 | 427 | (** {1 Type construction} *) 428 | 429 | module Typ : sig 430 | include ExtensibleS with type t = Ppxlib.core_type 431 | 432 | include PayloadS with type t := Ppxlib.core_type 433 | 434 | val poly : Ast_helper.str list -> Ppxlib.core_type -> Ppxlib.core_type 435 | 436 | val poly_name : Ast_helper.str -> string 437 | end 438 | 439 | (** {1 Type declarations} *) 440 | 441 | module Type : sig 442 | val has_deriver : 443 | string -> Ppxlib.type_declaration list -> 444 | (Ppxlib.Asttypes.arg_label * Ppxlib.expression) list option 445 | end 446 | 447 | (** {1 Extension constructors} *) 448 | 449 | module Te : sig 450 | type decl = { 451 | vars : Ast_helper.str list; 452 | args : Ppxlib.constructor_arguments; 453 | res : Ppxlib.core_type option; 454 | } 455 | 456 | val destruct_decl : Ppxlib.extension_constructor_kind -> decl option 457 | end 458 | 459 | (** {1 Open} *) 460 | 461 | module Opn : sig 462 | type 'a t = 'a Ppxlib.open_infos 463 | end 464 | 465 | (** {1 Expressions} *) 466 | 467 | module Exp : sig 468 | include ValueS with type t = Ppxlib.expression 469 | 470 | val ident : 471 | ?loc:Location.t -> ?attrs:Ppxlib.attributes -> Longident.t -> 472 | Ppxlib.expression 473 | 474 | val ident_of_str : 475 | ?attrs:Ppxlib.attributes -> Ast_helper.str -> 476 | Ppxlib.expression 477 | 478 | val send : 479 | ?loc:Location.t -> ?attrs:Ppxlib.attributes -> Ppxlib.expression -> 480 | Ast_helper.str -> Ppxlib.expression 481 | 482 | val newtype : 483 | ?loc:Location.t -> ?attrs:Ppxlib.attributes -> Ast_helper.str -> 484 | Ppxlib.expression -> Ppxlib.expression 485 | 486 | val open_ : 487 | ?loc:Location.t -> ?attrs:Ppxlib.attributes -> 488 | Ppxlib.module_expr Opn.t -> Ppxlib.expression -> 489 | Ppxlib.expression 490 | 491 | val destruct_open : 492 | Ppxlib.expression -> 493 | (Ppxlib.module_expr Opn.t * Ppxlib.expression) option 494 | 495 | val tuple_of_payload : Ppxlib.payload -> Ppxlib.expression list 496 | end 497 | 498 | (** {1 Row fields} *) 499 | 500 | (** The module `Rf` has been introduced in [Ast_helper] with OCaml 4.08.0 501 | (as [row_field] type switched to a record representation). 502 | Moreover, even the current [Ast_helper.Rf.inherit_] (OCaml 4.10.0) misses 503 | the [?attrs] flag. *) 504 | module Rf : sig 505 | type desc = 506 | | Rtag of Ppxlib.Asttypes.label Location.loc * bool * Ppxlib.core_type list 507 | | Rinherit of Ppxlib.core_type 508 | 509 | val to_loc : Ppxlib.row_field -> Location.t 510 | 511 | val to_attributes : Ppxlib.row_field -> Ppxlib.attributes 512 | 513 | val destruct : Ppxlib.row_field -> desc 514 | 515 | val tag : 516 | ?loc:Location.t -> ?attrs:Ppxlib.attributes -> 517 | Ppxlib.Asttypes.label Location.loc -> bool -> Ppxlib.core_type list -> 518 | Ppxlib.row_field 519 | 520 | val inherit_ : 521 | ?loc:Location.t -> ?attrs:Ppxlib.attributes -> Ppxlib.core_type -> 522 | Ppxlib.row_field 523 | end 524 | 525 | (** {1 Object fields} *) 526 | 527 | module Of : sig 528 | type t = Ppxlib.object_field 529 | 530 | type desc = 531 | | Otag of Ppxlib.Asttypes.label Location.loc * Ppxlib.core_type 532 | | Oinherit of Ppxlib.core_type 533 | 534 | val to_loc : t -> Location.t 535 | 536 | val to_attributes : t -> Ppxlib.attributes 537 | 538 | val destruct : t -> desc 539 | 540 | val tag : ?loc:Location.t -> ?attrs:Ppxlib.attributes -> 541 | Ppxlib.Asttypes.label Location.loc -> Ppxlib.core_type -> t 542 | 543 | val inherit_ : ?loc:Location.t -> ?attrs:Ppxlib.attributes -> 544 | Ppxlib.core_type -> t 545 | end 546 | 547 | (** {1 With constraint} *) 548 | 549 | module With : sig 550 | val typesubst : 551 | ?t:Ast_helper.lid -> Ppxlib.type_declaration -> 552 | Ppxlib.with_constraint 553 | 554 | val destruct_typesubst : 555 | Ppxlib.with_constraint -> 556 | (Ast_helper.lid * Ppxlib.type_declaration) option 557 | 558 | val modsubst : 559 | Ast_helper.lid -> Ast_helper.lid -> Ppxlib.with_constraint 560 | 561 | val destruct_modsubst : 562 | Ppxlib.with_constraint -> (Ast_helper.lid * Ast_helper.lid) option 563 | end 564 | 565 | (** {1 General purpose functions} *) 566 | 567 | val compare_pair : 'a comparer -> 'b comparer -> ('a * 'b) comparer 568 | 569 | val compare_list : 'a comparer -> 'a list comparer 570 | 571 | val update : ('a -> 'b * 'a) -> 'a ref -> 'b 572 | 573 | val mutate : ('a -> 'a) -> 'a ref -> unit 574 | 575 | val extract_first : ('a -> 'b option) -> 'a list -> ('b * 'a list) option 576 | 577 | (** Indexed accumulator to build an array. *) 578 | module Accu : sig 579 | type 'a t 580 | (** An accumulator of type ['a t] can accumulate values of type ['a] to 581 | build an ['a array]. *) 582 | 583 | val empty : 'a t 584 | (** The empty accumulator. *) 585 | 586 | val add : 'a -> 'a t -> int * 'a t 587 | (** [add v a] returns [(i, a')] where [a'] is the accumulator [a] followed by 588 | the value [v]. [i] is the index of [v] in [a'] (and is equal to the length 589 | of [a]). *) 590 | 591 | val length : 'a t -> int 592 | (** [length a] returns the length of the accumulator [a] (the number of 593 | elements). *) 594 | 595 | val to_array : 'a t -> 'a array 596 | (** [to_array a] returns the array containing all the elements of [a]. *) 597 | end 598 | -------------------------------------------------------------------------------- /ppx/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name metapp_ppx) 3 | (public_name metapp.ppx) 4 | (preprocess (pps ppxlib.metaquot)) 5 | (kind ppx_rewriter) 6 | ; +warning 32: Unused value declaration. 7 | ; +warning 34: Unused type declaration. 8 | ; -warning 40: Constructor or label name used out of scope. (OCaml <=4.06.0) 9 | (flags -open Stdcompat -w +32+34-40) 10 | (libraries ppxlib compiler-libs stdcompat dynlink 11 | findlib.dynload metapp_preutils metapp_api unix dyncompile)) 12 | -------------------------------------------------------------------------------- /ppx/findlib_for_ppx.ml: -------------------------------------------------------------------------------- 1 | (* See https://github.com/ocaml/dune/issues/3214 *) 2 | 3 | let init_predicates () = 4 | if Sys.ocaml_version >= "4.08.0" && Findlib.recorded_predicates () = [] then 5 | let preds = ["ppx_driver"; "mt"; "mt_posix"] in 6 | let preds = (if Dynlink.is_native then "native" else "byte") :: preds in 7 | Findlib.record_package_predicates preds 8 | 9 | let load_pkg_if_needed ~debug pkg = 10 | try 11 | Fl_dynload.load_packages ~debug [pkg] 12 | with Dynlink.Error _ -> 13 | (* Module_already_loaded is not defined in OCaml <4.08.0 *) 14 | Findlib.record_package Findlib.Record_load pkg 15 | 16 | (* The following function is adapted from findlib source code. 17 | (src/findlib/fl_dynload.ml) 18 | 19 | Copyright 1999 by Gerd Stolpmann 20 | 21 | The package "findlib" is copyright by Gerd Stolpmann. 22 | 23 | Permission is hereby granted, free of charge, to any person obtaining 24 | a copy of this document and the "findlib" software (the 25 | "Software"), to deal in the Software without restriction, including 26 | without limitation the rights to use, copy, modify, merge, publish, 27 | distribute, sublicense, and/or sell copies of the Software, and to 28 | permit persons to whom the Software is furnished to do so, subject to 29 | the following conditions: 30 | 31 | The above copyright notice and this permission notice shall be included 32 | in all copies or substantial portions of the Software. 33 | 34 | The Software is provided ``as is'', without warranty of any kind, express 35 | or implied, including but not limited to the warranties of 36 | merchantability, fitness for a particular purpose and noninfringement. 37 | In no event shall Gerd Stolpmann be liable for any claim, damages or 38 | other liability, whether in an action of contract, tort or otherwise, 39 | arising from, out of or in connection with the Software or the use or 40 | other dealings in the software. 41 | *) 42 | 43 | let load_packages ?(debug=false) pkgs = 44 | if Sys.ocaml_version < "4.08.0" then 45 | Fl_dynload.load_packages ~debug pkgs 46 | else 47 | let preds = Findlib.recorded_predicates() in 48 | let eff_pkglist = 49 | Findlib.package_deep_ancestors preds pkgs in 50 | List.iter (load_pkg_if_needed ~debug) eff_pkglist 51 | -------------------------------------------------------------------------------- /ppx/metapp_ppx.ml: -------------------------------------------------------------------------------- 1 | module Counter = struct 2 | type t = int ref 3 | 4 | let make () = 5 | ref 0 6 | 7 | let count counter = 8 | let result = !counter in 9 | counter := succ result; 10 | result 11 | end 12 | 13 | let extension_of_index (i : int) : Ppxlib.extension = 14 | (Metapp_preutils.mkloc "meta", Metapp_preutils.payload_of_int i) 15 | 16 | let deref (e : Ppxlib.expression) : Ppxlib.expression = 17 | Metapp_preutils.apply (Metapp_preutils.Exp.var "!") [e] 18 | 19 | let array_get (a : Ppxlib.expression) (index : int) : Ppxlib.expression = 20 | let i = Metapp_preutils.Exp.of_int index in 21 | Metapp_preutils.apply 22 | (Metapp_preutils.Exp.ident (Ldot (Lident "Array", "get"))) 23 | [a; i] 24 | 25 | let array_set (a : Ppxlib.expression) (index : int) 26 | (v : Ppxlib.expression) : Ppxlib.expression = 27 | let i = Metapp_preutils.Exp.of_int index in 28 | Metapp_preutils.apply 29 | (Metapp_preutils.Exp.ident (Ldot (Lident "Array", "set"))) 30 | [a; i; v] 31 | 32 | let string_list_of_payload (payload : Ppxlib.payload) : string list = 33 | List.map Metapp_preutils.string_of_arbitrary_expression 34 | (Metapp_preutils.list_of_tuple (Metapp_preutils.Exp.of_payload payload)) 35 | 36 | module Options = struct 37 | include Dyncompile.Options 38 | 39 | let handle ((({ txt; _ }, payload), _) : Metapp_preutils.destruct_extension) : 40 | (t -> t) option = 41 | match txt with 42 | | "metaload" -> 43 | let add_object_file object_file = 44 | Dynlink.loadfile object_file; 45 | let dir_name = Filename.dirname object_file in 46 | if dir_name = Filename.current_dir_name then 47 | None 48 | else 49 | Some dir_name in 50 | Some (add_directories (List.filter_map add_object_file 51 | (string_list_of_payload payload))) 52 | | "metapackage" -> Some (add_packages (string_list_of_payload payload)) 53 | | "metadir" -> Some (add_directories (string_list_of_payload payload)) 54 | | "metaflag" -> Some (add_flags (string_list_of_payload payload)) 55 | | "metaplainsource" -> Some (set_plainsource true) 56 | | "metadebug_findlib" -> Some (set_debug_findlib true) 57 | | "metaverbose" -> Some (set_verbose true) 58 | | _ -> None 59 | end 60 | 61 | type instruction = 62 | | Expression of Ppxlib.expression 63 | | Definition of Ppxlib.structure Location.loc 64 | 65 | let get_expression (instruction : instruction) 66 | : Ppxlib.expression = 67 | match instruction with 68 | | Expression expression -> expression 69 | | Definition definition -> 70 | Location.raise_errorf ~loc:definition.loc 71 | "Definitions are only allowed at top-level" 72 | 73 | module rec AccuTypes : sig 74 | type 'a escape = { 75 | instructions : instruction list; 76 | quotation : unit -> 'a Metapp_api.ArrayQuotation.quotation; 77 | } 78 | 79 | type 'a quotations = 'a escape Metapp_preutils.Accu.t ref 80 | 81 | type 'a metapoints = Location.t Metapp_preutils.Accu.t ref 82 | end = struct 83 | include AccuTypes 84 | end 85 | and MutableQuotations : Metapp_api.QuotationsWithMakeS with 86 | type 'a x = 'a AccuQuotation.t = 87 | Metapp_api.QuotationsWithMake (AccuQuotation) 88 | and AccuQuotation : Metapp_api.UnaryMakeS 89 | with type 'a t = 'a AccuTypes.quotations 90 | = struct 91 | type 'a t = 'a AccuTypes.quotations 92 | 93 | let make () = 94 | ref Metapp_preutils.Accu.empty 95 | end 96 | and MutableMetapoints : Metapp_api.MetapointsWithMakeS 97 | with type 'a x = 'a AccuMetapoint.t = 98 | Metapp_api.MetapointsWithMake (AccuMetapoint) 99 | and AccuMetapoint : Metapp_api.UnaryMakeS 100 | with type 'a t = 'a AccuTypes.metapoints = struct 101 | type 'a t = 'a AccuTypes.metapoints 102 | 103 | let make () = 104 | ref Metapp_preutils.Accu.empty 105 | end 106 | 107 | module type MetapointsMapperS = 108 | functor (Metapoint : Metapp_api.MetapointS) -> sig 109 | val map : Ppxlib.payload -> Metapoint.t 110 | end 111 | 112 | module Metapoint_mapper (Mapper : MetapointsMapperS) = struct 113 | module Mapper' (Metapoint : Metapp_api.MetapointS) = struct 114 | let map (super : Metapoint.t Metapp_preutils.map) 115 | (m : Metapoint.t) : Metapoint.t = 116 | Ppxlib.Ast_helper.with_default_loc (Metapoint.to_loc m) @@ fun () -> 117 | match Metapoint.destruct_extension m with 118 | | Some (({ txt = "meta"; _ }, payload), _) -> 119 | let module Map = Mapper (Metapoint) in 120 | Map.map payload 121 | | _ -> super m 122 | end 123 | 124 | class map = object 125 | inherit Ppxlib.Ast_traverse.map as super 126 | 127 | method! expression = 128 | let module M = Mapper' (Metapp_api.Exp) in M.map super#expression 129 | 130 | method! pattern = 131 | let module M = Mapper' (Metapp_api.Pat) in M.map super#pattern 132 | 133 | method! core_type = 134 | let module M = Mapper' (Metapp_api.Typ) in M.map super#core_type 135 | 136 | method! class_type = 137 | let module M = Mapper' (Metapp_api.Cty) in M.map super#class_type 138 | 139 | method! class_type_field = 140 | let module M = Mapper' (Metapp_api.Ctf) in M.map super#class_type_field 141 | 142 | method! class_expr = 143 | let module M = Mapper' (Metapp_api.Cl) in M.map super#class_expr 144 | 145 | method! class_field = 146 | let module M = Mapper' (Metapp_api.Cf) in M.map super#class_field 147 | 148 | method! module_type = 149 | let module M = Mapper' (Metapp_api.Mty) in M.map super#module_type 150 | 151 | method! module_expr = 152 | let module M = Mapper' (Metapp_api.Mod) in M.map super#module_expr 153 | 154 | method! signature_item = 155 | let module M = Mapper' (Metapp_api.Sigi) in M.map super#signature_item 156 | 157 | method! structure_item = 158 | let module M = Mapper' (Metapp_api.Stri) in M.map super#structure_item 159 | end 160 | end 161 | 162 | let unmut_metapoints (context : MutableMetapoints.t) 163 | : Metapp_api.OptionArrayMetapoints.t = 164 | let module Map = Metapp_api.MetapointMap (MutableMetapoints) 165 | (Metapp_api.OptionArrayMetapoints) 166 | (struct 167 | type 'a x = 'a AccuMetapoint.t 168 | 169 | type 'a y = 'a option array 170 | 171 | let map accu = Array.make (Metapp_preutils.Accu.length !accu) None 172 | end) in 173 | Map.map context 174 | 175 | let unmut_loc (context : MutableMetapoints.t) 176 | : Metapp_api.MetapointsLocation.t = 177 | let module Map = Metapp_api.MetapointMap (MutableMetapoints) 178 | (Metapp_api.MetapointsLocation) (struct 179 | type 'a x = 'a AccuMetapoint.t 180 | 181 | type _ y = Location.t array 182 | 183 | let map accu = Metapp_preutils.Accu.to_array !accu 184 | end) in 185 | Map.map context 186 | 187 | let unmut_subquotations (context : MutableQuotations.t) 188 | : Metapp_api.ArrayQuotations.t = 189 | let module Map = Metapp_api.QuotationMap (MutableQuotations) 190 | (Metapp_api.ArrayQuotations) (struct 191 | type 'a x = 'a AccuQuotation.t 192 | 193 | type 'a y = 'a Metapp_api.ArrayQuotation.t 194 | 195 | let map accu = Array.map 196 | (fun quotation -> quotation.AccuTypes.quotation) 197 | (Metapp_preutils.Accu.to_array !accu) 198 | end) in 199 | Map.map context 200 | 201 | let context_var = "__context" 202 | 203 | let fill_var = "__fill" 204 | 205 | let metapoints_field = "metapoints" 206 | 207 | let loc_field = "loc" 208 | 209 | let subquotations_field = "subquotations" 210 | 211 | let field_get (expr : Ppxlib.expression) (field : string) 212 | : Ppxlib.expression = 213 | Ppxlib.Ast_helper.Exp.field expr 214 | (Metapp_preutils.mkloc (Longident.Lident field)) 215 | 216 | let context_get (field : string) : Ppxlib.expression = 217 | field_get (Metapp_preutils.Exp.var context_var) field 218 | 219 | let replace_metapoints (contents : Metapp_api.OptionArrayMetapoints.t) 220 | : Ppxlib.Ast_traverse.map = 221 | let module Mapper (Metapoint : Metapp_api.MetapointS) = struct 222 | module Accessor = 223 | Metapoint.MetapointAccessor (Metapp_api.OptionArrayMetapoints) 224 | 225 | let map (payload : Ppxlib.payload) : Metapoint.t = 226 | Option.get 227 | (Accessor.get contents).(Metapp_preutils.int_of_payload payload) 228 | end in 229 | let module Mapper' = Metapoint_mapper (Mapper) in 230 | new Mapper'.map 231 | 232 | let metapp_api = Longident.Lident "Metapp_api" 233 | 234 | module type Map = sig 235 | class map : Ppxlib.Ast_traverse.map 236 | end 237 | 238 | let rec extract_subquotations (quotations : MutableQuotations.t) : 239 | Ppxlib.Ast_traverse.map = object 240 | inherit Ppxlib.Ast_traverse.map as super 241 | 242 | method! expression (e : Ppxlib.expression) : Ppxlib.expression = 243 | Ppxlib.Ast_helper.with_default_loc e.pexp_loc @@ fun () -> 244 | match 245 | match e.pexp_desc with 246 | | Pexp_extension ({ txt; _ }, payload) -> 247 | Option.map (fun antiquotable -> (antiquotable, payload)) 248 | ((match txt with 249 | | "e" | "expr" -> Some (module Metapp_api.Exp) 250 | | "p" | "pat" -> Some (module Metapp_api.Pat) 251 | | "t" | "type" -> Some (module Metapp_api.Typ) 252 | | "sig" -> Some (module Metapp_api.Sig) 253 | | "sigi" -> Some (module Metapp_api.Sigi) 254 | | "str" -> Some (module Metapp_api.Str) 255 | | "stri" -> Some (module Metapp_api.Stri) 256 | | _ -> None 257 | ) : ((module Metapp_api.QuotationS) option)) 258 | | _ -> None 259 | with 260 | | None -> super#expression e 261 | | Some (antiquotable, payload) -> 262 | let module M = (val antiquotable) in 263 | let module Quotation = M.QuotationAccessor (MutableQuotations) in 264 | let module Name = M.QuotationAccessor (Metapp_api.QuotationName) in 265 | let quotation = M.of_payload payload in 266 | let (map_module, k) = extract_metapoints () in 267 | let module Map = (val map_module : Map) in 268 | let map = new Map.map in 269 | let quotation = M.map map quotation in 270 | let escape : 'a AccuTypes.escape = k () in 271 | let quote () = 272 | let quotation' = escape.quotation () in 273 | let fill () = 274 | let map = replace_metapoints quotation'.context.metapoints in 275 | M.map map quotation in 276 | { quotation' with fill } in 277 | let index = 278 | Metapp_preutils.update 279 | (Metapp_preutils.Accu.add { escape with quotation = quote}) 280 | (Quotation.get quotations) in 281 | let loc = !Ppxlib.Ast_helper.default_loc in 282 | let field_name = Name.get Metapp_api.quotation_name in 283 | [%expr let 284 | { Metapp_api.ArrayQuotation.context = __context; fill = __fill } = 285 | ([%e field_get (context_get subquotations_field) field_name]).( 286 | [%e Metapp_preutils.Exp.of_int index]) () in 287 | [%e (Metapp_preutils.sequence 288 | (List.map get_expression escape.instructions @ 289 | [[%expr __fill ()]]))]] 290 | end 291 | 292 | and extract_metapoints () : (module Map) * (unit -> unit AccuTypes.escape) = 293 | let accu = ref [] in 294 | let metapoints = MutableMetapoints.make () in 295 | let subquotations = MutableQuotations.make () in 296 | let map_subquotations = extract_subquotations subquotations in 297 | let module Mapper (Metapoint : Metapp_api.MetapointS) = struct 298 | module Accessor = Metapoint.MetapointAccessor (MutableMetapoints) 299 | module Name = Metapoint.MetapointAccessor (Metapp_api.MetapointName) 300 | let map (payload : Ppxlib.payload) : Metapoint.t = 301 | let e = Metapp_preutils.Exp.of_payload payload in 302 | Ppxlib.Ast_helper.with_default_loc e.pexp_loc @@ fun () -> 303 | let extracted_expr = map_subquotations#expression e in 304 | let index = 305 | Metapp_preutils.update 306 | (Metapp_preutils.Accu.add !Ppxlib.Ast_helper.default_loc) 307 | (Accessor.get metapoints) in 308 | let field = Name.get Metapp_api.metapoint_name in 309 | let metapoint_field = field_get (context_get metapoints_field) field in 310 | let loc = !Ppxlib.Ast_helper.default_loc in 311 | let extracted_expr : Ppxlib.expression = 312 | [%expr Some (Ppxlib.Ast_helper.with_default_loc 313 | [%e array_get (field_get (context_get loc_field) field) index] 314 | (function () -> [%e extracted_expr]))] in 315 | accu |> Metapp_preutils.mutate (List.cons 316 | (Expression (array_set metapoint_field index extracted_expr))); 317 | Metapoint.extension (extension_of_index index) 318 | end in 319 | let module Meta_map = Metapoint_mapper (Mapper) in 320 | let module Metadef (Item : Metapp_preutils.ItemS) = struct 321 | let map (super : Item.t Metapp_preutils.map) (item : Item.t) : Item.t = 322 | Ppxlib.Ast_helper.with_default_loc (Item.to_loc item) @@ fun () -> 323 | match Item.destruct_extension item with 324 | | Some (({ txt = "metadef"; _ }, payload), _) -> 325 | let defs = 326 | map_subquotations#structure 327 | (Metapp_preutils.Str.of_payload payload) in 328 | accu |> Metapp_preutils.mutate (List.cons (Definition 329 | (Metapp_preutils.mkloc defs))); 330 | Item.of_list [] 331 | | _ -> super item 332 | end in 333 | let module Map = struct 334 | class map = object 335 | inherit Meta_map.map as super 336 | 337 | method! structure_item = 338 | let module M = Metadef (Metapp_preutils.Stri) in 339 | M.map super#structure_item 340 | 341 | method! signature_item = 342 | let module M = Metadef (Metapp_preutils.Sigi) in 343 | M.map super#signature_item 344 | end 345 | end in 346 | let k () : unit AccuTypes.escape = { 347 | instructions = List.rev !accu; 348 | quotation = fun () -> { 349 | fill = (fun () -> ()); 350 | context = { 351 | metapoints = unmut_metapoints metapoints; 352 | loc = unmut_loc metapoints; 353 | subquotations = unmut_subquotations subquotations; }}} in 354 | ((module Map), k) 355 | 356 | let transform (root_mapper : Ppxlib.structure Metapp_preutils.map) 357 | (get_mapper : #Ppxlib.Ast_traverse.map -> 'a Metapp_preutils.map) 358 | (s : 'a) : 'a = 359 | let (meta_map_module, k) = extract_metapoints () in 360 | let module Meta_map = (val meta_map_module) in 361 | let accu_options = ref { Options.empty with packages = ["ppxlib"] } in 362 | let module Metaopt (Item : Metapp_preutils.ItemS) = struct 363 | let map (super : Item.t Metapp_preutils.map) (item : Item.t) : Item.t = 364 | Ppxlib.Ast_helper.with_default_loc (Item.to_loc item) @@ fun () -> 365 | match Option.bind (Item.destruct_extension item) Options.handle with 366 | | None -> super item 367 | | Some option -> 368 | accu_options |> Metapp_preutils.mutate option; 369 | Item.of_list [] 370 | end in 371 | let map = object 372 | inherit Meta_map.map as super 373 | 374 | method! structure_item = 375 | let module M = Metaopt (Metapp_preutils.Stri) in 376 | M.map super#structure_item 377 | 378 | method! signature_item = 379 | let module M = Metaopt (Metapp_preutils.Sigi) in 380 | M.map super#signature_item 381 | end in 382 | let s = get_mapper map s in 383 | match k () with 384 | | { instructions = []; _ } -> s 385 | | { instructions; quotation } -> 386 | match quotation () with { context; _ } -> 387 | let initial_parsetree = 388 | [Ppxlib.Ast_helper.Str.value Nonrecursive 389 | [Ppxlib.Ast_helper.Vb.mk (Metapp_preutils.Pat.var context_var) 390 | (Ppxlib.Ast_helper.Exp.match_ (deref (Metapp_preutils.Exp.ident 391 | (Ldot (metapp_api, "top_context")))) 392 | [Ppxlib.Ast_helper.Exp.case (Metapp_preutils.Pat.none ()) 393 | (Ppxlib.Ast_helper.Exp.assert_ (Metapp_preutils.Exp.of_bool false)); 394 | Ppxlib.Ast_helper.Exp.case 395 | (Metapp_preutils.Pat.some (Metapp_preutils.Pat.var context_var)) 396 | (Metapp_preutils.Exp.var context_var)])]] in 397 | let make_instruction (accu : Ppxlib.structure) (instruction : instruction) 398 | : Ppxlib.structure = 399 | match instruction with 400 | | Expression expr -> 401 | let item = 402 | Ppxlib.Ast_helper.Str.value Nonrecursive 403 | [Ppxlib.Ast_helper.Vb.mk (Metapp_preutils.Pat.of_unit ()) expr] in 404 | item :: accu 405 | | Definition definition -> List.rev_append definition.txt accu in 406 | let accu = List.fold_left make_instruction initial_parsetree instructions in 407 | let parsetree = root_mapper (List.rev accu) in 408 | Metapp_api.top_context := Some context; 409 | let options = Options.rev !accu_options in 410 | if options.packages <> [] then 411 | begin 412 | Findlib_for_ppx.init_predicates (); 413 | Findlib.init (); 414 | Findlib_for_ppx.load_packages ~debug:options.debug_findlib 415 | options.packages; 416 | end; 417 | begin try 418 | Dyncompile.compile_and_load options 419 | (Ppxlib.Selected_ast.To_ocaml.copy_structure parsetree); 420 | with Dynlink.Error error -> 421 | Location.raise_errorf "%s" (Dynlink.error_message error) 422 | end; 423 | let mapper = replace_metapoints context.metapoints in 424 | get_mapper mapper s 425 | 426 | let map = object (self) 427 | inherit Ppxlib.Ast_traverse.map as super 428 | 429 | method! structure s = 430 | transform self#structure (fun map -> map#structure) s 431 | 432 | method! signature s = 433 | transform self#structure (fun map -> map#signature) s 434 | end 435 | 436 | let () = 437 | Ppxlib.Driver.register_transformation "metapp" 438 | ~preprocess_impl:map#structure 439 | ~preprocess_intf:map#signature 440 | -------------------------------------------------------------------------------- /preutils/accu.ml: -------------------------------------------------------------------------------- 1 | type 'a t = { 2 | length : int; 3 | list : 'a list; 4 | } 5 | 6 | let empty = { length = 0; list = [] } 7 | 8 | let add value { length; list } = 9 | length, { length = succ length; list = value :: list } 10 | 11 | let length { length; _ } = 12 | length 13 | 14 | let to_array ({ length; list } : 'a t) : 'a array = 15 | match list with 16 | | [] -> [||] 17 | | hd :: tl -> 18 | let result = Array.make length hd in 19 | let rec fill i list = 20 | match list with 21 | | [] -> () 22 | | hd :: tl -> 23 | result.(i) <- hd; 24 | fill (pred i) tl in 25 | fill (length - 2) tl; 26 | result 27 | -------------------------------------------------------------------------------- /preutils/accu.mli: -------------------------------------------------------------------------------- 1 | type 'a t 2 | 3 | val empty : 'a t 4 | 5 | val add : 'a -> 'a t -> int * 'a t 6 | 7 | val length : 'a t -> int 8 | 9 | val to_array : 'a t -> 'a array 10 | -------------------------------------------------------------------------------- /preutils/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name metapp_preutils) 3 | (public_name metapp.preutils) 4 | ; +warning 32: Unused value declaration. 5 | ; +warning 34: Unused type declaration. 6 | ; -warning 40: Constructor or label name used out of scope. (OCaml <=4.06.0) 7 | (flags -open Stdcompat -w +32+34-40) 8 | (libraries ppxlib stdcompat)) 9 | -------------------------------------------------------------------------------- /preutils/metapp_preutils.ml: -------------------------------------------------------------------------------- 1 | (** {1 Coercions} *) 2 | 3 | let int_of_expression (e : Ppxlib.expression) : int = 4 | Ppxlib.Ast_helper.with_default_loc e.pexp_loc @@ fun () -> 5 | match 6 | match e.pexp_desc with 7 | | Pexp_constant (Pconst_integer (value, _)) -> 8 | int_of_string_opt value 9 | | _ -> 10 | None 11 | with 12 | | Some result -> result 13 | | None -> 14 | Location.raise_errorf ~loc:!Ppxlib.Ast_helper.default_loc 15 | "Integer value expected" 16 | 17 | let destruct_string_constant (constant : Ppxlib.constant) : string option = 18 | match constant with 19 | | Pconst_string (s, _, _) -> Some s 20 | | _ -> None 21 | 22 | let string_of_expression (expression : Ppxlib.expression) : string = 23 | Ppxlib.Ast_helper.with_default_loc expression.pexp_loc @@ fun () -> 24 | match 25 | match expression.pexp_desc with 26 | | Pexp_constant constant -> destruct_string_constant constant 27 | | _ -> None 28 | with 29 | | Some value -> value 30 | | _ -> 31 | Location.raise_errorf ~loc:!Ppxlib.Ast_helper.default_loc 32 | "String value expected" 33 | 34 | let string_of_arbitrary_expression (expression : Ppxlib.expression) 35 | : string = 36 | match 37 | match expression.pexp_desc with 38 | | Pexp_constant constant -> destruct_string_constant constant 39 | | _ -> None 40 | with 41 | | Some value -> value 42 | | _ -> 43 | Format.asprintf "%a" Ppxlib.Pprintast.expression expression 44 | 45 | let bool_of_expression (e : Ppxlib.expression) : bool = 46 | Ppxlib.Ast_helper.with_default_loc e.pexp_loc @@ fun () -> 47 | match e.pexp_desc with 48 | | Pexp_construct ({ txt = Lident "false"; _ }, None) -> 49 | false 50 | | Pexp_construct ({ txt = Lident "true"; _ }, None) -> 51 | true 52 | | _ -> 53 | Location.raise_errorf ~loc:!Ppxlib.Ast_helper.default_loc 54 | "Boolean value expected" 55 | 56 | let pair_of_expression (e : Ppxlib.expression) 57 | : Ppxlib.expression * Ppxlib.expression = 58 | Ppxlib.Ast_helper.with_default_loc e.pexp_loc @@ fun () -> 59 | match e.pexp_desc with 60 | | Pexp_tuple [a; b] -> (a, b) 61 | | _ -> 62 | Location.raise_errorf ~loc:!Ppxlib.Ast_helper.default_loc 63 | "Pair expected" 64 | 65 | let rec list_of_expression (e : Ppxlib.expression) 66 | : Ppxlib.expression list = 67 | Ppxlib.Ast_helper.with_default_loc e.pexp_loc @@ fun () -> 68 | match e.pexp_desc with 69 | | Pexp_construct ({ txt = Lident "[]"; _ }, None) -> [] 70 | | Pexp_construct ({ txt = Lident "::"; _ }, Some pair) -> 71 | let (hd, tl) = pair_of_expression pair in 72 | hd :: list_of_expression tl 73 | | _ -> 74 | Location.raise_errorf ~loc:!Ppxlib.Ast_helper.default_loc 75 | "List expected" 76 | 77 | let list_of_tuple (e : Ppxlib.expression) : Ppxlib.expression list = 78 | match e.pexp_desc with 79 | | Pexp_tuple list -> list 80 | | Pexp_construct ({ txt = Lident "()"; _}, None) -> [] 81 | | _ -> [e] 82 | 83 | let structure_of_expression (e : Ppxlib.expression) : Ppxlib.structure = 84 | [Ppxlib.Ast_helper.Str.eval e] 85 | 86 | let lid_of_str (str : Ppxlib.Ast_helper.str) : Ppxlib.Ast_helper.lid = 87 | Location.mkloc (Longident.Lident str.txt) str.loc 88 | 89 | (** {1 Location management} *) 90 | 91 | let mkloc (txt : 'a) : 'a Location.loc = 92 | { txt; loc = !Ppxlib.Ast_helper.default_loc } 93 | 94 | let map_loc (f : 'a -> 'b) (l : 'a Location.loc) : 'b Location.loc = 95 | Ppxlib.Ast_helper.with_default_loc l.loc (fun () -> { l with txt = f l.txt }) 96 | 97 | let with_loc (f : 'a -> 'b) (l : 'a Location.loc) : 'b = 98 | Ppxlib.Ast_helper.with_default_loc l.loc (fun () -> f l.txt) 99 | 100 | (** {1 Constructing identifiers } *) 101 | 102 | let make_ident ?(prefix : Longident.t option) (s : string) : Longident.t = 103 | match prefix with 104 | | None -> Lident s 105 | | Some prefix -> Ldot (prefix, s) 106 | 107 | (** {1 Constructing function application} *) 108 | 109 | let nolabel arg = 110 | (Ppxlib.Asttypes.Nolabel, arg) 111 | 112 | let nolabels args = 113 | List.map nolabel args 114 | 115 | let apply ?attrs (f : Ppxlib.expression) 116 | ?(labels : (string * Ppxlib.expression) list = []) 117 | ?(optional : (string * Ppxlib.expression) list = []) 118 | (args : Ppxlib.expression list) : Ppxlib.expression = 119 | Ppxlib.Ast_helper.Exp.apply ?attrs f 120 | (List.map (fun (l, e) -> (Ppxlib.Asttypes.Labelled l, e)) labels @ 121 | List.map (fun (l, e) -> (Ppxlib.Asttypes.Optional l, e)) optional @ 122 | nolabels args) 123 | 124 | (** {1 Generic signature for visitable nodes} *) 125 | 126 | type 'a iter = 'a -> unit 127 | 128 | type 'a map = 'a -> 'a 129 | 130 | module type VisitableS = sig 131 | type t 132 | 133 | val to_loc : t -> Location.t 134 | 135 | val iter : #Ppxlib.Ast_traverse.iter -> t iter 136 | 137 | val map : #Ppxlib.Ast_traverse.map -> t map 138 | end 139 | 140 | (** {1 Generic signature for extensible nodes} *) 141 | 142 | type destruct_extension = Ppxlib.extension * Ppxlib.attributes 143 | 144 | module type ExtensibleS = sig 145 | include VisitableS 146 | 147 | val extension : ?attrs:Ppxlib.attributes -> Ppxlib.extension -> t 148 | 149 | val destruct_extension : t -> destruct_extension option 150 | end 151 | 152 | module type PayloadS = sig 153 | type t 154 | 155 | val of_payload : Ppxlib.payload -> t 156 | 157 | val to_payload : t -> Ppxlib.payload 158 | end 159 | 160 | module type ItemS = sig 161 | include ExtensibleS 162 | 163 | include PayloadS with type t := t 164 | 165 | val of_list : t list -> t 166 | end 167 | 168 | module Cty : ExtensibleS with type t = Ppxlib.class_type = struct 169 | type t = Ppxlib.class_type 170 | 171 | let to_loc (cty : Ppxlib.class_type) : Location.t = 172 | cty.pcty_loc 173 | 174 | let iter (iter : #Ppxlib.Ast_traverse.iter) : t iter = 175 | iter#class_type 176 | 177 | let map (map : #Ppxlib.Ast_traverse.map) : t map = 178 | map#class_type 179 | 180 | let extension ?attrs (e : Ppxlib.extension) : t = 181 | Ppxlib.Ast_helper.Cty.extension ?attrs e 182 | 183 | let destruct_extension (cty : Ppxlib.class_type) : 184 | destruct_extension option = 185 | match cty.pcty_desc with 186 | | Pcty_extension e -> Some (e, cty.pcty_attributes) 187 | | _ -> None 188 | end 189 | 190 | module Ctf : ExtensibleS with type t = Ppxlib.class_type_field = struct 191 | type t = Ppxlib.class_type_field 192 | 193 | let to_loc (ctf : Ppxlib.class_type_field) : Location.t = 194 | ctf.pctf_loc 195 | 196 | let iter (iter : #Ppxlib.Ast_traverse.iter) : t iter = 197 | iter#class_type_field 198 | 199 | let map (map : #Ppxlib.Ast_traverse.map) : t map = map#class_type_field 200 | 201 | let extension ?attrs (e : Ppxlib.extension) : t = 202 | Ppxlib.Ast_helper.Ctf.extension ?attrs e 203 | 204 | let destruct_extension (ctf : Ppxlib.class_type_field) 205 | : destruct_extension option = 206 | match ctf.pctf_desc with 207 | | Pctf_extension e -> Some (e, ctf.pctf_attributes) 208 | | _ -> None 209 | end 210 | 211 | module Cl : ExtensibleS with type t = Ppxlib.class_expr = struct 212 | type t = Ppxlib.class_expr 213 | 214 | let to_loc (cl : Ppxlib.class_expr) : Location.t = 215 | cl.pcl_loc 216 | 217 | let iter (iter : #Ppxlib.Ast_traverse.iter) : t iter = 218 | iter#class_expr 219 | 220 | let map (map : #Ppxlib.Ast_traverse.map) : t map = 221 | map#class_expr 222 | 223 | let extension ?attrs (e : Ppxlib.extension) : t = 224 | Ppxlib.Ast_helper.Cl.extension ?attrs e 225 | 226 | let destruct_extension (cl : Ppxlib.class_expr) 227 | : destruct_extension option = 228 | match cl.pcl_desc with 229 | | Pcl_extension e -> Some (e, cl.pcl_attributes) 230 | | _ -> None 231 | end 232 | 233 | module Cf : ExtensibleS with type t = Ppxlib.class_field = struct 234 | type t = Ppxlib.class_field 235 | 236 | let to_loc (cf : Ppxlib.class_field) : Location.t = 237 | cf.pcf_loc 238 | 239 | let iter (iter : #Ppxlib.Ast_traverse.iter) : t iter = 240 | iter#class_field 241 | 242 | let map (map : #Ppxlib.Ast_traverse.map) : t map = 243 | map#class_field 244 | 245 | let extension ?attrs (e : Ppxlib.extension) : t = 246 | Ppxlib.Ast_helper.Cf.extension ?attrs e 247 | 248 | let destruct_extension (cf : Ppxlib.class_field) 249 | : destruct_extension option = 250 | match cf.pcf_desc with 251 | | Pcf_extension e -> Some (e, cf.pcf_attributes) 252 | | _ -> None 253 | end 254 | 255 | module Mty : ExtensibleS with type t = Ppxlib.module_type = struct 256 | type t = Ppxlib.module_type 257 | 258 | let to_loc (mty : Ppxlib.module_type) : Location.t = 259 | mty.pmty_loc 260 | 261 | let iter (iter : #Ppxlib.Ast_traverse.iter) : t iter = 262 | iter#module_type 263 | 264 | let map (map : #Ppxlib.Ast_traverse.map) : t map = 265 | map#module_type 266 | 267 | let extension ?attrs (e : Ppxlib.extension) : t = 268 | Ppxlib.Ast_helper.Mty.extension ?attrs e 269 | 270 | let destruct_extension (mty : Ppxlib.module_type) 271 | : destruct_extension option = 272 | match mty.pmty_desc with 273 | | Pmty_extension e -> Some (e, mty.pmty_attributes) 274 | | _ -> None 275 | end 276 | 277 | module Mod : ExtensibleS with type t = Ppxlib.module_expr = struct 278 | type t = Ppxlib.module_expr 279 | 280 | let to_loc (m : Ppxlib.module_expr) : Location.t = 281 | m.pmod_loc 282 | 283 | let iter (iter : #Ppxlib.Ast_traverse.iter) : t iter = 284 | iter#module_expr 285 | 286 | let map (map : #Ppxlib.Ast_traverse.map) : t map = 287 | map#module_expr 288 | 289 | let extension ?attrs (e : Ppxlib.extension) : t = 290 | Ppxlib.Ast_helper.Mod.extension ?attrs e 291 | 292 | let destruct_extension (m : Ppxlib.module_expr) 293 | : destruct_extension option = 294 | match m.pmod_desc with 295 | | Pmod_extension e -> Some (e, m.pmod_attributes) 296 | | _ -> None 297 | end 298 | 299 | let range_loc (first : Location.t) (last : Location.t) : Location.t = { 300 | loc_start = first.loc_start; 301 | loc_end = last.loc_end; 302 | loc_ghost = first.loc_ghost || last.loc_ghost; 303 | } 304 | 305 | module Stri = struct 306 | type t = Ppxlib.structure_item 307 | 308 | let to_loc (s : Ppxlib.structure_item) : Location.t = 309 | s.pstr_loc 310 | 311 | let iter (iter : #Ppxlib.Ast_traverse.iter) : t iter = 312 | iter#structure_item 313 | 314 | let map (map : #Ppxlib.Ast_traverse.map) : t map = 315 | map#structure_item 316 | 317 | let extension ?attrs (e : Ppxlib.extension) : t = 318 | Ppxlib.Ast_helper.Str.extension ?attrs e 319 | 320 | let destruct_extension (s : Ppxlib.structure_item) 321 | : destruct_extension option = 322 | match s.pstr_desc with 323 | | Pstr_extension (e, attr) -> Some (e, attr) 324 | | _ -> None 325 | 326 | let of_payload (payload : Ppxlib.payload) 327 | : Ppxlib.structure_item = 328 | match payload with 329 | | PStr [item] -> item 330 | | _ -> 331 | Location.raise_errorf ~loc:!Ppxlib.Ast_helper.default_loc 332 | "Single structure item expected" 333 | 334 | let to_payload (item : Ppxlib.structure_item) : Ppxlib.payload = 335 | PStr [item] 336 | 337 | let of_list (structure : Ppxlib.structure) : Ppxlib.structure_item = 338 | Ppxlib.Ast_helper.Str.include_ (Ppxlib.Ast_helper.Incl.mk 339 | (Ppxlib.Ast_helper.Mod.structure structure)) 340 | end 341 | 342 | let list_to_loc (item_to_loc : 'a -> Location.t) (l : 'a list) : Location.t = 343 | match l with 344 | | [] -> !Ppxlib.Ast_helper.default_loc 345 | | first :: tl -> 346 | let last = List.fold_left (fun _ last -> last) first tl in 347 | range_loc (item_to_loc first) (item_to_loc last) 348 | 349 | module Str = struct 350 | type t = Ppxlib.structure 351 | 352 | let to_loc (s : Ppxlib.structure) : Location.t = 353 | list_to_loc Stri.to_loc s 354 | 355 | let iter (iter : #Ppxlib.Ast_traverse.iter) : t iter = 356 | iter#structure 357 | 358 | let map (map : #Ppxlib.Ast_traverse.map) : t map = 359 | map#structure 360 | 361 | let of_payload (payload : Ppxlib.payload) : Ppxlib.structure = 362 | match payload with 363 | | PStr str -> str 364 | | _ -> 365 | Location.raise_errorf ~loc:!Ppxlib.Ast_helper.default_loc "Structure expected" 366 | 367 | let to_payload (str : Ppxlib.structure) : Ppxlib.payload = 368 | PStr str 369 | end 370 | 371 | module Sigi = struct 372 | type t = Ppxlib.signature_item 373 | 374 | let to_loc (s : Ppxlib.signature_item) : Location.t = 375 | s.psig_loc 376 | 377 | let iter (iter : #Ppxlib.Ast_traverse.iter) : t iter = 378 | iter#signature_item 379 | 380 | let map (map : #Ppxlib.Ast_traverse.map) : t map = 381 | map#signature_item 382 | 383 | let extension ?attrs (e : Ppxlib.extension) : t = 384 | Ppxlib.Ast_helper.Sig.extension ?attrs e 385 | 386 | let destruct_extension (s : Ppxlib.signature_item) 387 | : destruct_extension option = 388 | match s.psig_desc with 389 | | Psig_extension (e, attr) -> Some (e, attr) 390 | | _ -> None 391 | 392 | let of_payload (payload : Ppxlib.payload) : Ppxlib.signature_item = 393 | match payload with 394 | | PSig [item] -> item 395 | | _ -> 396 | Location.raise_errorf ~loc:!Ppxlib.Ast_helper.default_loc 397 | "Single signature item expected" 398 | 399 | let to_payload (item : Ppxlib.signature_item) : Ppxlib.payload = 400 | PSig [item] 401 | 402 | let of_list (signature : Ppxlib.signature) : Ppxlib.signature_item = 403 | Ppxlib.Ast_helper.Sig.include_ (Ppxlib.Ast_helper.Incl.mk 404 | (Ppxlib.Ast_helper.Mty.signature signature)) 405 | end 406 | 407 | module Sig = struct 408 | type t = Ppxlib.signature 409 | 410 | let to_loc (s : Ppxlib.signature) : Location.t = 411 | list_to_loc Sigi.to_loc s 412 | 413 | let iter (iter : #Ppxlib.Ast_traverse.iter) : t iter = 414 | iter#signature 415 | 416 | let map (map : #Ppxlib.Ast_traverse.map) : t map = 417 | map#signature 418 | 419 | let of_payload (payload : Ppxlib.payload) : Ppxlib.signature = 420 | match payload with 421 | | PSig sgn -> sgn 422 | | _ -> 423 | Location.raise_errorf ~loc:!Ppxlib.Ast_helper.default_loc "Signature expected" 424 | 425 | let to_payload (signature : Ppxlib.signature) : Ppxlib.payload = 426 | PSig signature 427 | end 428 | 429 | type value = { 430 | exp : Ppxlib.expression; 431 | pat : Ppxlib.pattern; 432 | } 433 | 434 | (** {1 Generic signature for expressions and patterns} *) 435 | 436 | module type BaseValueS = sig 437 | include ExtensibleS 438 | 439 | val var : ?attrs:Ppxlib.attributes -> string -> t 440 | 441 | val of_constant : ?attrs:Ppxlib.attributes -> Ppxlib.constant -> t 442 | 443 | val of_bytes : ?attrs:Ppxlib.attributes -> bytes -> t 444 | 445 | val force_tuple : ?attrs:Ppxlib.attributes -> t list -> t 446 | 447 | val force_construct : 448 | ?attrs:Ppxlib.attributes -> Ppxlib.Ast_helper.lid -> t option -> t 449 | 450 | val array : ?attrs:Ppxlib.attributes -> t list -> t 451 | 452 | val record : ?attrs:Ppxlib.attributes -> (Longident.t * t) list -> t 453 | 454 | val variant : ?attrs:Ppxlib.attributes -> string -> t option -> t 455 | 456 | val lazy_ : ?attrs:Ppxlib.attributes -> t -> t 457 | 458 | val choice : 459 | (unit -> Ppxlib.expression) -> (unit -> Ppxlib.pattern) -> t 460 | 461 | val of_payload : Ppxlib.payload -> t 462 | 463 | val to_payload : t -> Ppxlib.payload 464 | end 465 | 466 | module type ValueS = sig 467 | include BaseValueS 468 | 469 | val of_int : ?attrs:Ppxlib.attributes -> int -> t 470 | 471 | val of_string : ?attrs:Ppxlib.attributes -> string -> t 472 | 473 | val of_char : ?attrs:Ppxlib.attributes -> char -> t 474 | 475 | val of_unit : ?attrs:Ppxlib.attributes -> unit -> t 476 | 477 | val of_bool : ?attrs:Ppxlib.attributes -> bool -> t 478 | 479 | val of_float : ?attrs:Ppxlib.attributes -> float -> t 480 | 481 | val of_int32 : ?attrs:Ppxlib.attributes -> int32 -> t 482 | 483 | val of_int64 : ?attrs:Ppxlib.attributes -> int64 -> t 484 | 485 | val of_nativeint : ?attrs:Ppxlib.attributes -> nativeint -> t 486 | 487 | val none : ?attrs:Ppxlib.attributes -> unit -> t 488 | 489 | val some : ?attrs:Ppxlib.attributes -> t -> t 490 | 491 | val option : ?attrs:Ppxlib.attributes -> t option -> t 492 | 493 | val of_longident : Longident.t -> t 494 | 495 | val construct : ?attrs:Ppxlib.attributes -> Longident.t -> t list -> t 496 | 497 | val tuple : ?attrs:Ppxlib.attributes -> t list -> t 498 | 499 | val nil : ?attrs:Ppxlib.attributes -> ?prefix:Longident.t -> unit -> t 500 | 501 | val cons : ?attrs:Ppxlib.attributes -> ?prefix:Longident.t -> t -> t -> t 502 | 503 | val list : 504 | ?attrs:Ppxlib.attributes -> ?prefix:Longident.t -> t list -> t 505 | end 506 | 507 | let unit_ctor = "()" 508 | 509 | let none_ctor = "None" 510 | 511 | let some_ctor = "Some" 512 | 513 | let nil_ctor = "[]" 514 | 515 | let cons_ctor = "::" 516 | 517 | let longident = Longident.Lident "Longident" 518 | 519 | module ExtendValue (Base : BaseValueS) : ValueS with type t = Base.t = struct 520 | include Base 521 | 522 | let of_int ?attrs i = 523 | of_constant ?attrs (Ppxlib.Ast_helper.Const.int i) 524 | 525 | let of_string ?attrs s = 526 | of_constant ?attrs (Ppxlib.Ast_helper.Const.string s) 527 | 528 | let of_char ?attrs s = 529 | of_constant ?attrs (Ppxlib.Ast_helper.Const.char s) 530 | 531 | let of_unit ?attrs () = 532 | force_construct ?attrs (mkloc (Longident.Lident unit_ctor)) None 533 | 534 | let of_float ?attrs f = 535 | of_constant ?attrs (Ppxlib.Ast_helper.Const.float (string_of_float f)) 536 | 537 | let of_int32 ?attrs i = 538 | of_constant ?attrs (Ppxlib.Ast_helper.Const.int32 i) 539 | 540 | let of_int64 ?attrs i = 541 | of_constant ?attrs (Ppxlib.Ast_helper.Const.int64 i) 542 | 543 | let of_nativeint ?attrs i = 544 | of_constant ?attrs (Ppxlib.Ast_helper.Const.nativeint i) 545 | 546 | let tuple ?attrs (args : t list) : t = 547 | match args with 548 | | [] -> of_unit ?attrs () 549 | | [arg] -> arg 550 | | _ -> force_tuple ?attrs args 551 | 552 | let construct ?attrs (ident : Longident.t) (args : t list) : t = 553 | let arg = 554 | match args with 555 | | [] -> None 556 | | [arg] -> Some arg 557 | | _ -> Some (tuple args) in 558 | force_construct ?attrs (mkloc ident) arg 559 | 560 | let of_bool ?attrs b = 561 | construct ?attrs (Lident (string_of_bool b)) [] 562 | 563 | let none ?attrs () = 564 | construct ?attrs (Lident none_ctor) [] 565 | 566 | let some ?attrs x = 567 | construct ?attrs (Lident some_ctor) [x] 568 | 569 | let option ?attrs opt = 570 | match opt with 571 | | None -> none ?attrs () 572 | | Some x -> some ?attrs x 573 | 574 | let rec of_longident (ident : Longident.t) : t = 575 | match ident with 576 | | Ldot (m, v) -> 577 | construct (Ldot (longident, "Ldot")) 578 | [of_longident m; of_string v] 579 | | Lident ident -> 580 | construct (Ldot (longident, "Lident")) [of_string ident] 581 | | Lapply (f, x) -> 582 | construct (Ldot (longident, "Lapply")) 583 | [of_longident f; of_longident x] 584 | 585 | let nil ?attrs ?prefix () = 586 | construct ?attrs (make_ident ?prefix nil_ctor) [] 587 | 588 | let cons ?attrs ?prefix hd tl = 589 | construct ?attrs (make_ident ?prefix cons_ctor) [hd; tl] 590 | 591 | let rec list ?attrs ?prefix l = 592 | match l with 593 | | [] -> nil ?attrs ?prefix () 594 | | hd :: tl -> cons ?attrs ?prefix hd (list ?prefix tl) 595 | end 596 | 597 | module Exp = struct 598 | let ident ?loc ?attrs (ident : Longident.t) : Ppxlib.expression = 599 | Ppxlib.Ast_helper.Exp.ident ?loc ?attrs (mkloc ident) 600 | 601 | let ident_of_str ?attrs (str : Ppxlib.Ast_helper.str) : Ppxlib.expression = 602 | ident ?attrs ~loc:str.loc (Lident str.txt) 603 | 604 | include ExtendValue (struct 605 | type t = Ppxlib.expression 606 | 607 | let to_loc (e : Ppxlib.expression) : Location.t = 608 | e.pexp_loc 609 | 610 | let var ?attrs x = 611 | ident ?attrs (Lident x) 612 | 613 | let of_constant ?attrs cst = 614 | Ppxlib.Ast_helper.Exp.constant ?attrs cst 615 | 616 | let of_bytes ?attrs b = 617 | apply ?attrs (ident (Ldot (Lident "Bytes", "of_string"))) 618 | [of_constant (Ppxlib.Ast_helper.Const.string (Bytes.to_string b))] 619 | 620 | let force_tuple ?attrs (args : t list) : t = 621 | Ppxlib.Ast_helper.Exp.tuple ?attrs args 622 | 623 | let force_construct ?attrs (lid : Ppxlib.Ast_helper.lid) (args : t option) : t = 624 | Ppxlib.Ast_helper.Exp.construct ?attrs lid args 625 | 626 | let array ?attrs (items : t list) : t = 627 | Ppxlib.Ast_helper.Exp.array ?attrs items 628 | 629 | let record ?attrs (fields : (Longident.t * t) list) : t = 630 | Ppxlib.Ast_helper.Exp.record ?attrs 631 | (List.map (fun (field, value) -> (mkloc field, value)) fields) 632 | None 633 | 634 | let variant ?attrs (ctor : string) (arg : t option) : t = 635 | Ppxlib.Ast_helper.Exp.variant ?attrs ctor arg 636 | 637 | let lazy_ ?attrs (arg : t) : t = 638 | Ppxlib.Ast_helper.Exp.lazy_ ?attrs arg 639 | 640 | let choice (e : unit -> Ppxlib.expression) 641 | (_p : unit ->Ppxlib.pattern) : t = 642 | e () 643 | 644 | let iter (iter : #Ppxlib.Ast_traverse.iter) : t iter = 645 | iter#expression 646 | 647 | let map (map : #Ppxlib.Ast_traverse.map) : t map = 648 | map#expression 649 | 650 | let extension ?attrs (e : Ppxlib.extension) = 651 | Ppxlib.Ast_helper.Exp.extension ?attrs e 652 | 653 | let destruct_extension (e : Ppxlib.expression) 654 | : destruct_extension option = 655 | match e.pexp_desc with 656 | | Pexp_extension extension -> Some (extension, e.pexp_attributes) 657 | | _ -> None 658 | 659 | let of_payload (payload : Ppxlib.payload) : Ppxlib.expression = 660 | match payload with 661 | | PStr [{ pstr_desc = Pstr_eval (expr, []); _ }] -> 662 | expr 663 | | _ -> 664 | Location.raise_errorf ~loc:!Ppxlib.Ast_helper.default_loc 665 | "Expression expected" 666 | 667 | let to_payload (e : Ppxlib.expression) : Ppxlib.payload = 668 | PStr (structure_of_expression e) 669 | end) 670 | end 671 | 672 | module Typ = struct 673 | type t = Ppxlib.core_type 674 | 675 | let to_loc (ty : Ppxlib.core_type) : Location.t = 676 | ty.ptyp_loc 677 | 678 | let iter (iter : #Ppxlib.Ast_traverse.iter) : t iter = 679 | iter#core_type 680 | 681 | let map (map : #Ppxlib.Ast_traverse.map) : t map = 682 | map#core_type 683 | 684 | let extension ?attrs (e : Ppxlib.extension) : t = 685 | Ppxlib.Ast_helper.Typ.extension ?attrs e 686 | 687 | let destruct_extension (ty : Ppxlib.core_type) 688 | : destruct_extension option = 689 | match ty.ptyp_desc with 690 | | Ptyp_extension e -> Some (e, ty.ptyp_attributes) 691 | | _ -> None 692 | 693 | let of_payload (payload : Ppxlib.payload) : Ppxlib.core_type = 694 | match payload with 695 | | PTyp typ -> typ 696 | | _ -> 697 | Location.raise_errorf ~loc:!Ppxlib.Ast_helper.default_loc "Type expected" 698 | 699 | let to_payload (typ : Ppxlib.core_type) : Ppxlib.payload = 700 | PTyp typ 701 | end 702 | 703 | module Pat = ExtendValue (struct 704 | type t = Ppxlib.pattern 705 | 706 | let to_loc (p : Ppxlib.pattern) : Location.t = 707 | p.ppat_loc 708 | 709 | let var ?attrs x = 710 | Ppxlib.Ast_helper.Pat.var ?attrs (mkloc x) 711 | 712 | let of_constant ?attrs cst = 713 | Ppxlib.Ast_helper.Pat.constant ?attrs cst 714 | 715 | let of_bytes ?attrs:_ _b = 716 | failwith "Pat.of_bytes: bytes cannot be turned into patterns" 717 | 718 | let force_tuple ?attrs (args : t list) : t = 719 | Ppxlib.Ast_helper.Pat.tuple ?attrs args 720 | 721 | let force_construct ?attrs (lid : Ppxlib.Ast_helper.lid) (args : t option) : t = 722 | Ppxlib.Ast_helper.Pat.construct ?attrs lid args 723 | 724 | let record ?attrs (fields : (Longident.t * t) list) : t = 725 | Ppxlib.Ast_helper.Pat.record ?attrs 726 | (List.map (fun (field, value) -> (mkloc field, value)) fields) 727 | Closed 728 | 729 | let array ?attrs (items : t list) : t = 730 | Ppxlib.Ast_helper.Pat.array ?attrs items 731 | 732 | let variant ?attrs (ctor : string) (arg : t option) : t = 733 | Ppxlib.Ast_helper.Pat.variant ?attrs ctor arg 734 | 735 | let lazy_ ?attrs (arg : t) : t = 736 | Ppxlib.Ast_helper.Pat.lazy_ ?attrs arg 737 | 738 | let choice (_e : unit -> Ppxlib.expression) (p : unit -> Ppxlib.pattern) 739 | : t = 740 | p () 741 | 742 | let iter (iter : #Ppxlib.Ast_traverse.iter) : t iter = 743 | iter#pattern 744 | 745 | let map (map : #Ppxlib.Ast_traverse.map) : t map = 746 | map#pattern 747 | 748 | let extension ?attrs (e : Ppxlib.extension) = 749 | Ppxlib.Ast_helper.Pat.extension ?attrs e 750 | 751 | let destruct_extension (e : Ppxlib.pattern) : destruct_extension option = 752 | match e.ppat_desc with 753 | | Ppat_extension extension -> Some (extension, e.ppat_attributes) 754 | | _ -> None 755 | 756 | let of_payload (payload : Ppxlib.payload) : Ppxlib.pattern = 757 | match payload with 758 | | PPat (pat, None) -> pat 759 | | _ -> 760 | Location.raise_errorf ~loc:!Ppxlib.Ast_helper.default_loc "Pattern expected" 761 | let to_payload (pat : Ppxlib.pattern) : Ppxlib.payload = 762 | PPat (pat, None) 763 | end) 764 | 765 | module Value : ValueS with type t = value = ExtendValue (struct 766 | type t = value 767 | 768 | let rec split (l : value list) 769 | : Ppxlib.expression list * Ppxlib.pattern list = 770 | match l with 771 | | [] -> ([], []) 772 | | hd :: tl -> 773 | let (tl_exp, tl_pat) = split tl in 774 | (hd.exp :: tl_exp, hd.pat :: tl_pat) 775 | 776 | let split_option (o : value option) 777 | : Ppxlib.expression option * Ppxlib.pattern option = 778 | match o with 779 | | None -> (None, None) 780 | | Some { exp; pat } -> (Some exp, Some pat) 781 | 782 | let rec split_assoc (l : ('a * value) list) 783 | : ('a * Ppxlib.expression) list * ('a * Ppxlib.pattern) list = 784 | match l with 785 | | [] -> ([], []) 786 | | (key, hd) :: tl -> 787 | let (tl_exp, tl_pat) = split_assoc tl in 788 | ((key, hd.exp) :: tl_exp, (key, hd.pat) :: tl_pat) 789 | 790 | let to_loc (v : value) : Location.t = 791 | v.exp.pexp_loc 792 | 793 | let var ?attrs x = 794 | { exp = Exp.var ?attrs x; pat = Pat.var ?attrs x } 795 | 796 | let of_constant ?attrs cst = 797 | { exp = Exp.of_constant ?attrs cst; pat = Pat.of_constant ?attrs cst } 798 | 799 | let of_bytes ?attrs b = 800 | { exp = Exp.of_bytes ?attrs b; pat = Pat.of_bytes ?attrs b } 801 | 802 | let force_tuple ?attrs (args : t list) : t = 803 | let args_exp, args_pat = split args in 804 | { exp = Exp.force_tuple ?attrs args_exp; 805 | pat = Pat.force_tuple ?attrs args_pat; } 806 | 807 | let force_construct ?attrs (lid : Ppxlib.Ast_helper.lid) (args : t option) : t = 808 | let args_exp, args_pat = split_option args in 809 | { exp = Exp.force_construct ?attrs lid args_exp; 810 | pat = Pat.force_construct ?attrs lid args_pat; } 811 | 812 | let array ?attrs (args : t list) : t = 813 | let args_exp, args_pat = split args in 814 | { exp = Exp.array ?attrs args_exp; 815 | pat = Pat.array ?attrs args_pat; } 816 | 817 | let record ?attrs (fields : (Longident.t * t) list) : t = 818 | let fields_exp, fields_pat = split_assoc fields in 819 | { exp = Exp.record ?attrs fields_exp; 820 | pat = Pat.record ?attrs fields_pat; } 821 | 822 | let variant ?attrs (ctor : string) (arg : t option) : t = 823 | let arg_exp, arg_pat = split_option arg in 824 | { exp = Exp.variant ?attrs ctor arg_exp; 825 | pat = Pat.variant ?attrs ctor arg_pat; } 826 | 827 | let lazy_ ?attrs (arg : t) : t = 828 | { exp = Exp.lazy_ ?attrs arg.exp; 829 | pat = Pat.lazy_ ?attrs arg.pat; } 830 | 831 | let choice (e : unit -> Ppxlib.expression) (p : unit -> Ppxlib.pattern) 832 | : t = 833 | { exp = e (); 834 | pat = p (); } 835 | 836 | let iter (iter : #Ppxlib.Ast_traverse.iter) : t iter = 837 | failwith "no iterator" 838 | 839 | let map (map : #Ppxlib.Ast_traverse.map) : t map = 840 | failwith "no mapper" 841 | 842 | let extension ?attrs (e : Ppxlib.extension) : t = 843 | { exp = Exp.extension ?attrs e; 844 | pat = Pat.extension ?attrs e; } 845 | 846 | let destruct_extension (v : value) : destruct_extension option = 847 | Exp.destruct_extension v.exp 848 | 849 | let of_payload _ = 850 | failwith "value cannot be obtained from payload" 851 | 852 | let to_payload (v : value) : Ppxlib.payload = 853 | Exp.to_payload v.exp 854 | end) 855 | 856 | (** {1 Payload extraction} *) 857 | 858 | let int_of_payload (payload : Ppxlib.payload) : int = 859 | int_of_expression (Exp.of_payload payload) 860 | 861 | let string_of_payload (payload : Ppxlib.payload) : string = 862 | string_of_expression (Exp.of_payload payload) 863 | 864 | let bool_of_payload (payload : Ppxlib.payload) : bool = 865 | bool_of_expression (Exp.of_payload payload) 866 | 867 | (** {1 Payload construction (ctd) *) 868 | 869 | let payload_of_int (i : int) : Ppxlib.payload = 870 | Exp.to_payload (Exp.of_int i) 871 | 872 | (** {1 Coercions (ctd)} *) 873 | 874 | let sequence (list : Ppxlib.expression list) : Ppxlib.expression = 875 | match list with 876 | | [] -> Exp.of_unit () 877 | | [singleton] -> singleton 878 | | hd :: tl -> 879 | List.fold_left Ppxlib.Ast_helper.Exp.sequence hd tl 880 | 881 | (** {1 General purpose functions} *) 882 | 883 | let update f ref = 884 | let (result, new_contents) = f !ref in 885 | ref := new_contents; 886 | result 887 | 888 | let mutate f ref = 889 | ref := f !ref 890 | 891 | module Accu = Accu 892 | -------------------------------------------------------------------------------- /tests/deep/deep.ml: -------------------------------------------------------------------------------- 1 | [%%metapackage stdcompat] 2 | [%%metaflag "-open", "Stdcompat"] 3 | 4 | let () = 5 | assert 6 | ([%meta 7 | Ppxlib.Ast_helper.Exp.tuple (List.init 4 (fun i -> 8 | [%e ([%meta Metapp_preutils.Exp.of_int i], false)]))] 9 | = ((0, false), (1, false), (2, false), (3, false))) 10 | 11 | [%%metadef 12 | let param modname k = 13 | [%expr [%meta Metapp_preutils.Exp.of_string modname] :: 14 | [%meta k ()]]] 15 | 16 | let () = 17 | assert 18 | ([%meta (param "U" (fun _tiu -> param "V" (fun _tiv -> [%expr []])))] 19 | = ["U"; "V"]) 20 | -------------------------------------------------------------------------------- /tests/deep/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name deep) 3 | (preprocess (pps metapp.ppx)) 4 | (libraries metapp.preutils test_framework stdcompat)) 5 | -------------------------------------------------------------------------------- /tests/framework/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (public_name metapp.test_framework) 3 | (name test_framework)) -------------------------------------------------------------------------------- /tests/framework/test_framework.ml: -------------------------------------------------------------------------------- 1 | let assert_eq eq print a b = 2 | if not (eq a b) then 3 | failwith (Format.asprintf "Assertion failure: %a != %a.@." print a print b) 4 | -------------------------------------------------------------------------------- /tests/multistage/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name multistage) 3 | (preprocess (pps metapp.ppx)) 4 | (libraries metapp.preutils test_framework)) 5 | -------------------------------------------------------------------------------- /tests/multistage/multistage.ml: -------------------------------------------------------------------------------- 1 | [%%metadef 2 | [%%metadef 3 | let world () = 4 | Metapp_preutils.Exp.of_string "world"] 5 | 6 | let hello () = 7 | Metapp_preutils.Exp.of_string ( 8 | Printf.sprintf "Hello, %s!" [%meta world ()])] 9 | 10 | let () = 11 | Test_framework.assert_eq String.equal Format.pp_print_string 12 | [%meta hello ()] "Hello, world!" 13 | -------------------------------------------------------------------------------- /tests/simple/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name simple) 3 | (preprocess (pps metapp.ppx)) 4 | (libraries metapp.preutils test_framework stdcompat)) 5 | -------------------------------------------------------------------------------- /tests/simple/simple.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | Test_framework.assert_eq String.equal Format.pp_print_string 3 | [%meta Metapp_preutils.Exp.of_string Sys.ocaml_version] 4 | Sys.ocaml_version 5 | 6 | let () = 7 | match true with 8 | | [%meta Metapp_preutils.Pat.of_bool true] 9 | -> () 10 | | _ -> assert false 11 | 12 | let () = 13 | match false with 14 | | [%meta Metapp_preutils.Pat.of_bool true] 15 | -> assert false 16 | | _ -> () 17 | 18 | let r = ref None 19 | 20 | [%%meta Ppxlib.Ast_helper.Str.eval (Metapp_preutils.apply 21 | (Metapp_preutils.Exp.var ":=") 22 | [Metapp_preutils.Exp.var "r"; 23 | Metapp_preutils.Exp.construct (Lident "Some") 24 | [Metapp_preutils.Exp.of_string "Hello"]])] 25 | 26 | let () = 27 | Test_framework.assert_eq (=) 28 | (Stdcompat.Format.pp_print_option Format.pp_print_string) 29 | (!r) (Some "Hello") 30 | -------------------------------------------------------------------------------- /tests/sub_holes/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name sub_holes) 3 | (preprocess (pps metapp.ppx)) 4 | (flags -open Stdcompat) 5 | (libraries metapp test_framework stdcompat)) 6 | -------------------------------------------------------------------------------- /tests/sub_holes/sub_holes.ml: -------------------------------------------------------------------------------- 1 | [%%metapackage stdcompat] 2 | [%%metaflag "-open", "Stdcompat"] 3 | 4 | let () = 5 | let counter = ref 0 in 6 | [%meta 7 | let e = [%e incr counter ] in 8 | Ppxlib.Ast_helper.Exp.sequence e e]; 9 | Test_framework.assert_eq Int.equal Format.pp_print_int !counter 2 10 | 11 | let () = 12 | match (0, 1, "hello", 3) with 13 | | [%meta 14 | Ppxlib.Ast_helper.Pat.tuple (List.init 4 (function 15 | | 2 -> [%p? x] 16 | | _ -> [%p? _]))] -> 17 | Test_framework.assert_eq String.equal Format.pp_print_string x "hello" 18 | 19 | let counter = ref 0 20 | 21 | [%%meta 22 | let s = [%stri let () = incr counter ] in 23 | Metapp_preutils.Stri.of_list [s; s]] 24 | 25 | let () = 26 | Test_framework.assert_eq Int.equal Format.pp_print_int !counter 2 27 | -------------------------------------------------------------------------------- /tests/utils/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test_utils) 3 | (preprocess (pps metapp.ppx)) 4 | (preprocessor_deps "../../metapp/metapp.cmxs") 5 | (flags -open Stdcompat) 6 | (libraries metapp test_framework stdcompat)) 7 | -------------------------------------------------------------------------------- /tests/utils/test_utils.ml: -------------------------------------------------------------------------------- 1 | [%%metadir "metapp/.metapp.objs/byte/"] 2 | [%%metaload "metapp/metapp.cmxs"] 3 | [%%metapackage "stdcompat"] 4 | [%%metaflag "-open", "Stdcompat"] 5 | 6 | let () = 7 | Test_framework.assert_eq Int.equal Format.pp_print_int 8 | [%meta (new Metapp.filter)#expression 9 | [%e (1, 2 [@if false])]] 1 10 | 11 | [%%meta (new Metapp.filter)#structure_item 12 | [%stri let a = 1 and[@if false] b = c]] 13 | 14 | type other = AX | CX 15 | 16 | [%%meta (new Metapp.filter)#structure_item 17 | [%stri type test = other = AX | BX [@if false] | CX] 18 | ] 19 | 20 | type other2 = { a: int; b: float } 21 | 22 | [%%meta (new Metapp.filter)#structure_item 23 | [%stri type test2 = other2 = { a: int; b: float; c: bool [@if false]}] 24 | ] 25 | 26 | let make2 x = 27 | [%meta (new Metapp.filter)#expression [%e 28 | { a = 4; b = 5.0; c = 4 [@if false] } 29 | ]] 30 | 31 | let something' _ _ = () 32 | let something _ = () 33 | 34 | [%%meta Metapp.Stri.of_list @@ (new Metapp.filter)#structure [%str 35 | type t = 36 | | A of int 37 | | B of int * int 38 | [@if [%meta Metapp.Exp.of_bool (Sys.ocaml_version >= "4.04.0")]] 39 | (* ... *) 40 | 41 | let somefunction v = 42 | match (v: t) with 43 | | A x -> something x 44 | | B (y,z) 45 | [@if [%meta Metapp.Exp.of_bool (Sys.ocaml_version >= "4.04.0")]] -> 46 | something' y z 47 | (* ... *) ]] 48 | 49 | [%%meta Metapp.Stri.of_list ((new Metapp.filter)#structure [%str 50 | let () = 51 | assert (List.length [0; 1 [@if false]; 2] = 2) 52 | 53 | let () = 54 | match [0; 2] with 55 | | [0; 1 [@if false]; 2] -> () 56 | | _ -> assert false 57 | ])] 58 | 59 | let () = 60 | Test_framework.assert_eq Int.equal Format.pp_print_int a 1 61 | 62 | let () = 63 | assert 64 | [%meta 65 | Metapp.Exp.of_bool (Option.equal Metapp.Longident.equal 66 | (Metapp.Longident.of_expression_opt [%e M.(+)]) 67 | (Some (Longident.Ldot (Lident "M", "+"))))] 68 | -------------------------------------------------------------------------------- /version_info/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name metapp_version_info) 3 | (public_name metapp.version_info) 4 | (preprocess (pps metapp.ppx)) 5 | (libraries findlib)) 6 | -------------------------------------------------------------------------------- /version_info/metapp_version_info.ml: -------------------------------------------------------------------------------- 1 | let () = Findlib.init () 2 | 3 | let ppxlib_version_string = Findlib.package_property [] "ppxlib" "version" 4 | 5 | let ppxlib_version = 6 | match String.split_on_char '.' ppxlib_version_string with 7 | | [major; minor; patch] -> 8 | (int_of_string major, int_of_string minor, int_of_string patch) 9 | | _ -> assert false 10 | 11 | let ast_version = 12 | match ppxlib_version with 13 | | (0, (22 | 23 | 24 | 25), _) -> (4, 12) 14 | | _ -> (4, 14) 15 | -------------------------------------------------------------------------------- /version_info/metapp_version_info.mli: -------------------------------------------------------------------------------- 1 | val ppxlib_version : int * int * int 2 | 3 | val ast_version : int * int 4 | --------------------------------------------------------------------------------