├── .depend ├── .gitignore ├── .ocp-indent ├── .travis.yml ├── LICENSE ├── Makefile ├── README.md ├── ast_convenience_402.ml ├── ast_convenience_402.mli ├── ast_convenience_403.ml ├── ast_convenience_403.mli ├── ast_convenience_404.ml ├── ast_convenience_404.mli ├── ast_convenience_405.ml ├── ast_convenience_405.mli ├── ast_convenience_406.ml ├── ast_convenience_406.mli ├── ast_convenience_407.ml ├── ast_convenience_407.mli ├── ast_convenience_408.ml ├── ast_convenience_408.mli ├── ast_convenience_409.ml ├── ast_convenience_409.mli ├── ast_convenience_410.ml ├── ast_convenience_410.mli ├── ast_convenience_411.ml ├── ast_convenience_411.mli ├── ast_lifter_402.ml ├── ast_lifter_403.ml ├── ast_lifter_404.ml ├── ast_lifter_405.ml ├── ast_lifter_406.ml ├── ast_lifter_407.ml ├── ast_lifter_408.ml ├── ast_lifter_409.ml ├── ast_lifter_410.ml ├── ast_lifter_411.ml ├── ast_mapper_class_402.ml ├── ast_mapper_class_402.mli ├── ast_mapper_class_403.ml ├── ast_mapper_class_403.mli ├── ast_mapper_class_404.ml ├── ast_mapper_class_404.mli ├── ast_mapper_class_405.ml ├── ast_mapper_class_405.mli ├── ast_mapper_class_406.ml ├── ast_mapper_class_406.mli ├── ast_mapper_class_407.ml ├── ast_mapper_class_407.mli ├── ast_mapper_class_408.ml ├── ast_mapper_class_408.mli ├── ast_mapper_class_409.ml ├── ast_mapper_class_409.mli ├── ast_mapper_class_410.ml ├── ast_mapper_class_410.mli ├── ast_mapper_class_411.ml ├── ast_mapper_class_411.mli ├── dune ├── dune-project ├── dune-workspace.dev ├── dune.inc ├── example └── ppx_once │ ├── .merlin │ ├── META │ ├── Makefile │ ├── ppx_once.ml │ └── standalone.ml ├── gen └── update_dune.ml ├── ppx_metaquot_402.ml ├── ppx_metaquot_403.ml ├── ppx_metaquot_404.ml ├── ppx_metaquot_405.ml ├── ppx_metaquot_406.ml ├── ppx_metaquot_407.ml ├── ppx_metaquot_408.ml ├── ppx_metaquot_409.ml ├── ppx_metaquot_410.ml ├── ppx_metaquot_411.ml ├── ppx_metaquot_run.ml ├── ppx_tools_402.ml ├── ppx_tools_403.ml ├── ppx_tools_404.ml ├── ppx_tools_405.ml ├── ppx_tools_406.ml ├── ppx_tools_407.ml ├── ppx_tools_408.ml ├── ppx_tools_409.ml ├── ppx_tools_410.ml ├── ppx_tools_411.ml └── ppx_tools_versioned.opam /.depend: -------------------------------------------------------------------------------- 1 | ast_convenience_402.cmo : ast_convenience_402.cmi 2 | ast_convenience_402.cmx : ast_convenience_402.cmi 3 | ast_convenience_402.cmi : 4 | ast_convenience_403.cmo : ast_convenience_403.cmi 5 | ast_convenience_403.cmx : ast_convenience_403.cmi 6 | ast_convenience_403.cmi : 7 | ast_convenience_404.cmo : ast_convenience_404.cmi 8 | ast_convenience_404.cmx : ast_convenience_404.cmi 9 | ast_convenience_404.cmi : 10 | ast_convenience_405.cmo : ast_convenience_405.cmi 11 | ast_convenience_405.cmx : ast_convenience_405.cmi 12 | ast_convenience_405.cmi : 13 | ast_convenience_406.cmo : ast_convenience_406.cmi 14 | ast_convenience_406.cmx : ast_convenience_406.cmi 15 | ast_convenience_406.cmi : 16 | ast_lifter_402.cmo : 17 | ast_lifter_402.cmx : 18 | ast_lifter_403.cmo : 19 | ast_lifter_403.cmx : 20 | ast_lifter_404.cmo : 21 | ast_lifter_404.cmx : 22 | ast_lifter_405.cmo : 23 | ast_lifter_405.cmx : 24 | ast_lifter_406.cmo : 25 | ast_lifter_406.cmx : 26 | ast_mapper_class_402.cmo : ast_mapper_class_402.cmi 27 | ast_mapper_class_402.cmx : ast_mapper_class_402.cmi 28 | ast_mapper_class_402.cmi : 29 | ast_mapper_class_403.cmo : ast_mapper_class_403.cmi 30 | ast_mapper_class_403.cmx : ast_mapper_class_403.cmi 31 | ast_mapper_class_403.cmi : 32 | ast_mapper_class_404.cmo : ast_mapper_class_404.cmi 33 | ast_mapper_class_404.cmx : ast_mapper_class_404.cmi 34 | ast_mapper_class_404.cmi : 35 | ast_mapper_class_405.cmo : ast_mapper_class_405.cmi 36 | ast_mapper_class_405.cmx : ast_mapper_class_405.cmi 37 | ast_mapper_class_405.cmi : 38 | ast_mapper_class_406.cmo : ast_mapper_class_406.cmi 39 | ast_mapper_class_406.cmx : ast_mapper_class_406.cmi 40 | ast_mapper_class_406.cmi : 41 | ppx_metaquot_402.cmo : ast_lifter_402.cmo ast_convenience_402.cmi 42 | ppx_metaquot_402.cmx : ast_lifter_402.cmx ast_convenience_402.cmx 43 | ppx_metaquot_403.cmo : ast_lifter_403.cmo ast_convenience_403.cmi 44 | ppx_metaquot_403.cmx : ast_lifter_403.cmx ast_convenience_403.cmx 45 | ppx_metaquot_404.cmo : ast_lifter_404.cmo ast_convenience_404.cmi 46 | ppx_metaquot_404.cmx : ast_lifter_404.cmx ast_convenience_404.cmx 47 | ppx_metaquot_405.cmo : ast_lifter_405.cmo ast_convenience_405.cmi 48 | ppx_metaquot_405.cmx : ast_lifter_405.cmx ast_convenience_405.cmx 49 | ppx_metaquot_406.cmo : ast_lifter_406.cmo ast_convenience_406.cmi 50 | ppx_metaquot_406.cmx : ast_lifter_406.cmx ast_convenience_406.cmx 51 | ppx_metaquot_run.cmo : 52 | ppx_metaquot_run.cmx : 53 | ppx_tools_402.cmo : ast_mapper_class_402.cmi ast_convenience_402.cmi 54 | ppx_tools_402.cmx : ast_mapper_class_402.cmx ast_convenience_402.cmx 55 | ppx_tools_403.cmo : ast_mapper_class_403.cmi ast_convenience_403.cmi 56 | ppx_tools_403.cmx : ast_mapper_class_403.cmx ast_convenience_403.cmx 57 | ppx_tools_404.cmo : ast_mapper_class_404.cmi ast_convenience_404.cmi 58 | ppx_tools_404.cmx : ast_mapper_class_404.cmx ast_convenience_404.cmx 59 | ppx_tools_405.cmo : ast_mapper_class_405.cmi ast_convenience_405.cmi 60 | ppx_tools_405.cmx : ast_mapper_class_405.cmx ast_convenience_405.cmx 61 | ppx_tools_406.cmo : ast_mapper_class_406.cmi ast_convenience_406.cmi 62 | ppx_tools_406.cmx : ast_mapper_class_406.cmx ast_convenience_406.cmx 63 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.annot 2 | *.cmo 3 | *.cma 4 | *.cmi 5 | *.a 6 | *.o 7 | *.cmx 8 | *.cmxs 9 | *.cmxa 10 | *.exe 11 | *.cmt 12 | *.cmti 13 | _build 14 | dumpast 15 | genlifter 16 | ppx_metaquot 17 | rewriter 18 | ast_lifter.ml 19 | .gitignore 20 | *.install 21 | .merlin 22 | _opam 23 | -------------------------------------------------------------------------------- /.ocp-indent: -------------------------------------------------------------------------------- 1 | match_clause=4 2 | strict_with=auto 3 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | install: wget https://raw.githubusercontent.com/ocaml/ocaml-travisci-skeleton/master/.travis-docker.sh 3 | script: bash -ex .travis-docker.sh 4 | services: 5 | - docker 6 | sudo: false 7 | env: 8 | global: 9 | - PACKAGE="ppx_tools_versioned" 10 | - PRE_INSTALL_HOOK="cd /home/opam/opam-repository && git pull origin master && opam update -u -y" 11 | - DISTRO=ubuntu-16.04 12 | matrix: 13 | - OCAML_VERSION=4.02.3 14 | - OCAML_VERSION=4.03.0 15 | - OCAML_VERSION=4.04.2 16 | - OCAML_VERSION=4.05.0 17 | - OCAML_VERSION=4.06.1 18 | - OCAML_VERSION=4.07.1 19 | - OCAML_VERSION=4.08.1 20 | - OCAML_VERSION=4.09.1 21 | - OCAML_VERSION=4.10.0 22 | - OCAML_VERSION=4.11.0 23 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2013 Alain Frisch and LexiFi 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy of 6 | this software and associated documentation files (the "Software"), to deal in 7 | the Software without restriction, including without limitation the rights to 8 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of 9 | the Software, and to permit persons to whom the Software is furnished to do so, 10 | subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS 17 | FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR 18 | COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER 19 | IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 20 | CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | INSTALL_ARGS := $(if $(PREFIX),--prefix $(PREFIX),) 2 | 3 | all: 4 | dune build 5 | 6 | install: 7 | dune install $(INSTALL_ARGS) 8 | 9 | uninstall: 10 | dune uninstall $(INSTALL_ARGS) 11 | 12 | reinstall: uninstall reinstall 13 | 14 | test: 15 | dune runtest 16 | 17 | promote: 18 | dune promote 19 | 20 | clean: 21 | dune clean 22 | 23 | all-supported-ocaml-versions: 24 | dune build @default @runtest --workspace dune-workspace.dev 25 | 26 | .PHONY: all-supported-ocaml-versions all install uninstall reinstall test clean 27 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ppx_tools 2 | ========= 3 | 4 | Tools for authors of syntactic tools (such as ppx rewriters). 5 | 6 | This package is licensed by LexiFi under the terms of the MIT license. 7 | 8 | The tools are installed as a findlib package called 'ppx_tools'. 9 | Executables are thus accessible through the ocamlfind driver (e.g.: 10 | ocamlfind ppx_tools/dumpast). 11 | 12 | Main contributors: 13 | 14 | - Alain Frisch 15 | - Peter Zotov (whitequark) 16 | - Gabriel Radanne (Drup) 17 | 18 | [![Build Status](https://img.shields.io/travis/ocaml-ppx/ppx_tools_versioned?label=travis)](https://travis-ci.org/ocaml-ppx/ppx_tools_versioned) 19 | 20 | ppx_metaquot 21 | ------------ 22 | 23 | A ppx filter to help writing programs which manipulate the Parsetree, 24 | by allowing the programmer to use concrete syntax for expressions 25 | creating Parsetree fragments and patterns deconstructing Parsetree 26 | fragments. See the top of ppx_metaquot.ml for a description of the 27 | supported extensions. 28 | 29 | Usage: 30 | 31 | ocamlfind ocamlc -c -package ppx_tools.metaquot my_ppx_code.ml 32 | 33 | 34 | Ast_mapper_class 35 | ---------------- 36 | 37 | This module implements an API similar to Ast_mapper from the 38 | compiler-libs, i.e. a generic mapper from Parsetree to Parsetree 39 | implemeting a deep identity copy, which can be customized with a 40 | custom behavior for each syntactic category. The difference with 41 | Ast_mapper is that Ast_mapper_class implements the open recursion 42 | using a class. 43 | -------------------------------------------------------------------------------- /ast_convenience_402.ml: -------------------------------------------------------------------------------- 1 | open Migrate_parsetree.Ast_402 2 | 3 | (* This file is part of the ppx_tools package. It is released *) 4 | (* under the terms of the MIT license (see LICENSE file). *) 5 | (* Copyright 2013 Alain Frisch and LexiFi *) 6 | 7 | open Parsetree 8 | open Asttypes 9 | open Location 10 | open Ast_helper 11 | 12 | 13 | module Label = struct 14 | 15 | type t = string 16 | 17 | type desc = 18 | Nolabel 19 | | Labelled of string 20 | | Optional of string 21 | 22 | let explode s = 23 | if s = "" then Nolabel 24 | else if s.[0] = '?' then Optional (String.sub s 1 (String.length s - 1)) 25 | else Labelled s 26 | 27 | let nolabel = "" 28 | let labelled s = s 29 | let optional s = "?"^s 30 | 31 | end 32 | 33 | module Constant = struct 34 | type t = 35 | Pconst_integer of string * char option 36 | | Pconst_char of char 37 | | Pconst_string of string * string option 38 | | Pconst_float of string * char option 39 | 40 | exception Unknown_literal of string * char 41 | 42 | (** Backport Int_literal_converter from ocaml 4.03 - 43 | * https://github.com/ocaml/ocaml/blob/trunk/utils/misc.ml#L298 *) 44 | module Int_literal_converter = struct 45 | let cvt_int_aux str neg of_string = 46 | if String.length str = 0 || str.[0] = '-' 47 | then of_string str 48 | else neg (of_string ("-" ^ str)) 49 | let int s = cvt_int_aux s (~-) int_of_string 50 | let int32 s = cvt_int_aux s Int32.neg Int32.of_string 51 | let int64 s = cvt_int_aux s Int64.neg Int64.of_string 52 | let nativeint s = cvt_int_aux s Nativeint.neg Nativeint.of_string 53 | end 54 | 55 | let of_constant = function 56 | | Asttypes.Const_int32(i) -> Pconst_integer(Int32.to_string i, Some 'l') 57 | | Asttypes.Const_int64(i) -> Pconst_integer(Int64.to_string i, Some 'L') 58 | | Asttypes.Const_nativeint(i) -> Pconst_integer(Nativeint.to_string i, Some 'n') 59 | | Asttypes.Const_int(i) -> Pconst_integer(string_of_int i, None) 60 | | Asttypes.Const_char c -> Pconst_char c 61 | | Asttypes.Const_string(s, s_opt) -> Pconst_string(s, s_opt) 62 | | Asttypes.Const_float f -> Pconst_float(f, None) 63 | 64 | let to_constant = function 65 | | Pconst_integer(i,Some 'l') -> Asttypes.Const_int32 (Int_literal_converter.int32 i) 66 | | Pconst_integer(i,Some 'L') -> Asttypes.Const_int64 (Int_literal_converter.int64 i) 67 | | Pconst_integer(i,Some 'n') -> Asttypes.Const_nativeint (Int_literal_converter.nativeint i) 68 | | Pconst_integer(i,None) -> Asttypes.Const_int (Int_literal_converter.int i) 69 | | Pconst_integer(i,Some c) -> raise (Unknown_literal (i, c)) 70 | | Pconst_char c -> Asttypes.Const_char c 71 | | Pconst_string(s,d) -> Asttypes.Const_string(s, d) 72 | | Pconst_float(f,None) -> Asttypes.Const_float f 73 | | Pconst_float(f,Some c) -> raise (Unknown_literal (f, c)) 74 | end 75 | 76 | let may_tuple ?loc tup = function 77 | | [] -> None 78 | | [x] -> Some x 79 | | l -> Some (tup ?loc ?attrs:None l) 80 | 81 | let lid ?(loc = !default_loc) s = mkloc (Longident.parse s) loc 82 | let constr ?loc ?attrs s args = Exp.construct ?loc ?attrs (lid ?loc s) (may_tuple ?loc Exp.tuple args) 83 | let nil ?loc ?attrs () = constr ?loc ?attrs "[]" [] 84 | let unit ?loc ?attrs () = constr ?loc ?attrs "()" [] 85 | let tuple ?loc ?attrs = function 86 | | [] -> unit ?loc ?attrs () 87 | | [x] -> x 88 | | xs -> Exp.tuple ?loc ?attrs xs 89 | let cons ?loc ?attrs hd tl = constr ?loc ?attrs "::" [hd; tl] 90 | let list ?loc ?attrs l = List.fold_right (cons ?loc ?attrs) l (nil ?loc ?attrs ()) 91 | let str ?loc ?attrs s = Exp.constant ?loc ?attrs (Const_string (s, None)) 92 | let int ?loc ?attrs x = Exp.constant ?loc ?attrs (Const_int x) 93 | let char ?loc ?attrs x = Exp.constant ?loc ?attrs (Const_char x) 94 | let float ?loc ?attrs x = Exp.constant ?loc ?attrs (Const_float (string_of_float x)) 95 | let record ?loc ?attrs ?over l = 96 | Exp.record ?loc ?attrs (List.map (fun (s, e) -> (lid ~loc:e.pexp_loc s, e)) l) over 97 | let func ?loc ?attrs l = Exp.function_ ?loc ?attrs (List.map (fun (p, e) -> Exp.case p e) l) 98 | let lam ?loc ?attrs ?(label = Label.nolabel) ?default pat exp = Exp.fun_ ?loc ?attrs label default pat exp 99 | let app ?loc ?attrs f l = if l = [] then f else Exp.apply ?loc ?attrs f (List.map (fun a -> Label.nolabel, a) l) 100 | let evar ?loc ?attrs s = Exp.ident ?loc ?attrs (lid ?loc s) 101 | let let_in ?loc ?attrs ?(recursive = false) b body = 102 | Exp.let_ ?loc ?attrs (if recursive then Recursive else Nonrecursive) b body 103 | 104 | let sequence ?loc ?attrs = function 105 | | [] -> unit ?loc ?attrs () 106 | | hd :: tl -> List.fold_left (fun e1 e2 -> Exp.sequence ?loc ?attrs e1 e2) hd tl 107 | 108 | let pvar ?(loc = !default_loc) ?attrs s = Pat.var ~loc ?attrs (mkloc s loc) 109 | let pconstr ?loc ?attrs s args = Pat.construct ?loc ?attrs (lid ?loc s) (may_tuple ?loc Pat.tuple args) 110 | let precord ?loc ?attrs ?(closed = Open) l = 111 | Pat.record ?loc ?attrs (List.map (fun (s, e) -> (lid ~loc:e.ppat_loc s, e)) l) closed 112 | let pnil ?loc ?attrs () = pconstr ?loc ?attrs "[]" [] 113 | let pcons ?loc ?attrs hd tl = pconstr ?loc ?attrs "::" [hd; tl] 114 | let punit ?loc ?attrs () = pconstr ?loc ?attrs "()" [] 115 | let ptuple ?loc ?attrs = function 116 | | [] -> punit ?loc ?attrs () 117 | | [x] -> x 118 | | xs -> Pat.tuple ?loc ?attrs xs 119 | let plist ?loc ?attrs l = List.fold_right (pcons ?loc ?attrs) l (pnil ?loc ?attrs ()) 120 | 121 | let pstr ?loc ?attrs s = Pat.constant ?loc ?attrs (Const_string (s, None)) 122 | let pint ?loc ?attrs x = Pat.constant ?loc ?attrs (Const_int x) 123 | let pchar ?loc ?attrs x = Pat.constant ?loc ?attrs (Const_char x) 124 | let pfloat ?loc ?attrs x = Pat.constant ?loc ?attrs (Const_float (string_of_float x)) 125 | 126 | let tconstr ?loc ?attrs c l = Typ.constr ?loc ?attrs (lid ?loc c) l 127 | 128 | let get_str = function 129 | | {pexp_desc=Pexp_constant (Const_string (s, _)); _} -> Some s 130 | | _ -> None 131 | 132 | let get_str_with_quotation_delimiter = function 133 | | {pexp_desc=Pexp_constant (Const_string (s, d)); _} -> Some (s, d) 134 | | _ -> None 135 | 136 | let get_lid = function 137 | | {pexp_desc=Pexp_ident{txt=id;_};_} -> 138 | Some (String.concat "." (Longident.flatten id)) 139 | | _ -> None 140 | 141 | let find_attr s attrs = 142 | try Some (snd (List.find (fun (x, _) -> x.txt = s) attrs)) 143 | with Not_found -> None 144 | 145 | let expr_of_payload = function 146 | | PStr [{pstr_desc=Pstr_eval(e, _); _}] -> Some e 147 | | _ -> None 148 | 149 | let find_attr_expr s attrs = 150 | match find_attr s attrs with 151 | | Some e -> expr_of_payload e 152 | | None -> None 153 | 154 | let has_attr s attrs = 155 | find_attr s attrs <> None 156 | -------------------------------------------------------------------------------- /ast_convenience_402.mli: -------------------------------------------------------------------------------- 1 | open Migrate_parsetree.Ast_402 2 | 3 | (* This file is part of the ppx_tools package. It is released *) 4 | (* under the terms of the MIT license (see LICENSE file). *) 5 | (* Copyright 2013 Alain Frisch and LexiFi *) 6 | 7 | (** {1 Convenience functions to help build and deconstruct AST fragments.} *) 8 | 9 | open Parsetree 10 | open Asttypes 11 | open Ast_helper 12 | 13 | (** {2 Compatibility modules} *) 14 | 15 | module Label : sig 16 | type t = string 17 | 18 | type desc = 19 | Nolabel 20 | | Labelled of string 21 | | Optional of string 22 | 23 | val explode : t -> desc 24 | 25 | val nolabel : t 26 | val labelled : string -> t 27 | val optional : string -> t 28 | 29 | end 30 | 31 | (** {2 Provides abstraction over Asttypes.constant type }*) 32 | module Constant : sig 33 | type t = 34 | Pconst_integer of string * char option 35 | | Pconst_char of char 36 | | Pconst_string of string * string option 37 | | Pconst_float of string * char option 38 | 39 | exception Unknown_literal of string * char 40 | 41 | (** Converts Asttypes.constant to Constant.t *) 42 | val of_constant : constant -> t 43 | 44 | (** Converts Constant.t to Asttypes.constant. Raises Unknown_literal if conversion fails *) 45 | val to_constant : t -> constant 46 | end 47 | 48 | (** {2 Misc} *) 49 | 50 | val lid: ?loc:loc -> string -> lid 51 | 52 | (** {2 Expressions} *) 53 | 54 | val evar: ?loc:loc -> ?attrs:attrs -> string -> expression 55 | val let_in: ?loc:loc -> ?attrs:attrs -> ?recursive:bool -> value_binding list -> expression -> expression 56 | 57 | val constr: ?loc:loc -> ?attrs:attrs -> string -> expression list -> expression 58 | val record: ?loc:loc -> ?attrs:attrs -> ?over:expression -> (string * expression) list -> expression 59 | val tuple: ?loc:loc -> ?attrs:attrs -> expression list -> expression 60 | 61 | val nil: ?loc:loc -> ?attrs:attrs -> unit -> expression 62 | val cons: ?loc:loc -> ?attrs:attrs -> expression -> expression -> expression 63 | val list: ?loc:loc -> ?attrs:attrs -> expression list -> expression 64 | 65 | val unit: ?loc:loc -> ?attrs:attrs -> unit -> expression 66 | 67 | val func: ?loc:loc -> ?attrs:attrs -> (pattern * expression) list -> expression 68 | val lam: ?loc:loc -> ?attrs:attrs -> ?label:Label.t -> ?default:expression -> pattern -> expression -> expression 69 | val app: ?loc:loc -> ?attrs:attrs -> expression -> expression list -> expression 70 | 71 | val str: ?loc:loc -> ?attrs:attrs -> string -> expression 72 | val int: ?loc:loc -> ?attrs:attrs -> int -> expression 73 | val char: ?loc:loc -> ?attrs:attrs -> char -> expression 74 | val float: ?loc:loc -> ?attrs:attrs -> float -> expression 75 | 76 | val sequence: ?loc:loc -> ?attrs:attrs -> expression list -> expression 77 | (** Return [()] if the list is empty. Tail rec. *) 78 | 79 | (** {2 Patterns} *) 80 | 81 | val pvar: ?loc:loc -> ?attrs:attrs -> string -> pattern 82 | val pconstr: ?loc:loc -> ?attrs:attrs -> string -> pattern list -> pattern 83 | val precord: ?loc:loc -> ?attrs:attrs -> ?closed:closed_flag -> (string * pattern) list -> pattern 84 | val ptuple: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern 85 | 86 | val pnil: ?loc:loc -> ?attrs:attrs -> unit -> pattern 87 | val pcons: ?loc:loc -> ?attrs:attrs -> pattern -> pattern -> pattern 88 | val plist: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern 89 | 90 | val pstr: ?loc:loc -> ?attrs:attrs -> string -> pattern 91 | val pint: ?loc:loc -> ?attrs:attrs -> int -> pattern 92 | val pchar: ?loc:loc -> ?attrs:attrs -> char -> pattern 93 | val pfloat: ?loc:loc -> ?attrs:attrs -> float -> pattern 94 | 95 | val punit: ?loc:loc -> ?attrs:attrs -> unit -> pattern 96 | 97 | 98 | (** {2 Types} *) 99 | 100 | val tconstr: ?loc:loc -> ?attrs:attrs -> string -> core_type list -> core_type 101 | 102 | (** {2 AST deconstruction} *) 103 | 104 | val get_str: expression -> string option 105 | val get_str_with_quotation_delimiter: expression -> (string * string option) option 106 | val get_lid: expression -> string option 107 | 108 | val has_attr: string -> attributes -> bool 109 | val find_attr: string -> attributes -> payload option 110 | val find_attr_expr: string -> attributes -> expression option 111 | -------------------------------------------------------------------------------- /ast_convenience_403.ml: -------------------------------------------------------------------------------- 1 | open Migrate_parsetree.Ast_403 2 | 3 | (* This file is part of the ppx_tools package. It is released *) 4 | (* under the terms of the MIT license (see LICENSE file). *) 5 | (* Copyright 2013 Alain Frisch and LexiFi *) 6 | 7 | open Parsetree 8 | open Asttypes 9 | open Location 10 | open Ast_helper 11 | 12 | 13 | module Label = struct 14 | 15 | type t = Asttypes.arg_label 16 | 17 | type desc = Asttypes.arg_label = 18 | Nolabel 19 | | Labelled of string 20 | | Optional of string 21 | 22 | let explode x = x 23 | 24 | let nolabel = Nolabel 25 | let labelled x = Labelled x 26 | let optional x = Optional x 27 | 28 | end 29 | 30 | module Constant = struct 31 | type t = Parsetree.constant = 32 | Pconst_integer of string * char option 33 | | Pconst_char of char 34 | | Pconst_string of string * string option 35 | | Pconst_float of string * char option 36 | 37 | let of_constant x = x 38 | 39 | let to_constant x = x 40 | 41 | end 42 | 43 | let may_tuple ?loc tup = function 44 | | [] -> None 45 | | [x] -> Some x 46 | | l -> Some (tup ?loc ?attrs:None l) 47 | 48 | let lid ?(loc = !default_loc) s = mkloc (Longident.parse s) loc 49 | let constr ?loc ?attrs s args = Exp.construct ?loc ?attrs (lid ?loc s) (may_tuple ?loc Exp.tuple args) 50 | let nil ?loc ?attrs () = constr ?loc ?attrs "[]" [] 51 | let unit ?loc ?attrs () = constr ?loc ?attrs "()" [] 52 | let tuple ?loc ?attrs = function 53 | | [] -> unit ?loc ?attrs () 54 | | [x] -> x 55 | | xs -> Exp.tuple ?loc ?attrs xs 56 | let cons ?loc ?attrs hd tl = constr ?loc ?attrs "::" [hd; tl] 57 | let list ?loc ?attrs l = List.fold_right (cons ?loc ?attrs) l (nil ?loc ?attrs ()) 58 | let str ?loc ?attrs s = Exp.constant ?loc ?attrs (Pconst_string (s, None)) 59 | let int ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_integer (string_of_int x, None)) 60 | let char ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_char x) 61 | let float ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_float (string_of_float x, None)) 62 | let record ?loc ?attrs ?over l = 63 | Exp.record ?loc ?attrs (List.map (fun (s, e) -> (lid ~loc:e.pexp_loc s, e)) l) over 64 | let func ?loc ?attrs l = Exp.function_ ?loc ?attrs (List.map (fun (p, e) -> Exp.case p e) l) 65 | let lam ?loc ?attrs ?(label = Label.nolabel) ?default pat exp = Exp.fun_ ?loc ?attrs label default pat exp 66 | let app ?loc ?attrs f l = if l = [] then f else Exp.apply ?loc ?attrs f (List.map (fun a -> Label.nolabel, a) l) 67 | let evar ?loc ?attrs s = Exp.ident ?loc ?attrs (lid ?loc s) 68 | let let_in ?loc ?attrs ?(recursive = false) b body = 69 | Exp.let_ ?loc ?attrs (if recursive then Recursive else Nonrecursive) b body 70 | 71 | let sequence ?loc ?attrs = function 72 | | [] -> unit ?loc ?attrs () 73 | | hd :: tl -> List.fold_left (fun e1 e2 -> Exp.sequence ?loc ?attrs e1 e2) hd tl 74 | 75 | let pvar ?(loc = !default_loc) ?attrs s = Pat.var ~loc ?attrs (mkloc s loc) 76 | let pconstr ?loc ?attrs s args = Pat.construct ?loc ?attrs (lid ?loc s) (may_tuple ?loc Pat.tuple args) 77 | let precord ?loc ?attrs ?(closed = Open) l = 78 | Pat.record ?loc ?attrs (List.map (fun (s, e) -> (lid ~loc:e.ppat_loc s, e)) l) closed 79 | let pnil ?loc ?attrs () = pconstr ?loc ?attrs "[]" [] 80 | let pcons ?loc ?attrs hd tl = pconstr ?loc ?attrs "::" [hd; tl] 81 | let punit ?loc ?attrs () = pconstr ?loc ?attrs "()" [] 82 | let ptuple ?loc ?attrs = function 83 | | [] -> punit ?loc ?attrs () 84 | | [x] -> x 85 | | xs -> Pat.tuple ?loc ?attrs xs 86 | let plist ?loc ?attrs l = List.fold_right (pcons ?loc ?attrs) l (pnil ?loc ?attrs ()) 87 | 88 | let pstr ?loc ?attrs s = Pat.constant ?loc ?attrs (Pconst_string (s, None)) 89 | let pint ?loc ?attrs x = Pat.constant ?loc ?attrs (Pconst_integer (string_of_int x, None)) 90 | let pchar ?loc ?attrs x = Pat.constant ?loc ?attrs (Pconst_char x) 91 | let pfloat ?loc ?attrs x = Pat.constant ?loc ?attrs (Pconst_float (string_of_float x, None)) 92 | 93 | let tconstr ?loc ?attrs c l = Typ.constr ?loc ?attrs (lid ?loc c) l 94 | 95 | let get_str = function 96 | | {pexp_desc=Pexp_constant (Pconst_string (s, _)); _} -> Some s 97 | | _ -> None 98 | 99 | let get_str_with_quotation_delimiter = function 100 | | {pexp_desc=Pexp_constant (Pconst_string (s, d)); _} -> Some (s, d) 101 | | _ -> None 102 | 103 | let get_lid = function 104 | | {pexp_desc=Pexp_ident{txt=id;_};_} -> 105 | Some (String.concat "." (Longident.flatten id)) 106 | | _ -> None 107 | 108 | let find_attr s attrs = 109 | try Some (snd (List.find (fun (x, _) -> x.txt = s) attrs)) 110 | with Not_found -> None 111 | 112 | let expr_of_payload = function 113 | | PStr [{pstr_desc=Pstr_eval(e, _); _}] -> Some e 114 | | _ -> None 115 | 116 | let find_attr_expr s attrs = 117 | match find_attr s attrs with 118 | | Some e -> expr_of_payload e 119 | | None -> None 120 | 121 | let has_attr s attrs = 122 | find_attr s attrs <> None 123 | -------------------------------------------------------------------------------- /ast_convenience_403.mli: -------------------------------------------------------------------------------- 1 | open Migrate_parsetree.Ast_403 2 | 3 | (* This file is part of the ppx_tools package. It is released *) 4 | (* under the terms of the MIT license (see LICENSE file). *) 5 | (* Copyright 2013 Alain Frisch and LexiFi *) 6 | 7 | (** {1 Convenience functions to help build and deconstruct AST fragments.} *) 8 | 9 | open Asttypes 10 | open Ast_helper 11 | open Parsetree 12 | 13 | (** {2 Compatibility modules} *) 14 | 15 | module Label : sig 16 | type t = Asttypes.arg_label 17 | 18 | type desc = Asttypes.arg_label = 19 | Nolabel 20 | | Labelled of string 21 | | Optional of string 22 | 23 | val explode : t -> desc 24 | 25 | val nolabel : t 26 | val labelled : string -> t 27 | val optional : string -> t 28 | 29 | end 30 | 31 | (** {2 Provides a unified abstraction over differences in Parsetree.constant and Asttypes.constant 32 | * types defined in ocaml 4.03 and 4.02 respectively}*) 33 | module Constant : sig 34 | type t = Parsetree.constant = 35 | Pconst_integer of string * char option 36 | | Pconst_char of char 37 | | Pconst_string of string * string option 38 | | Pconst_float of string * char option 39 | 40 | (** Convert Asttypes.constant to Constant.t *) 41 | val of_constant : Parsetree.constant -> t 42 | 43 | (** Convert Constant.t to Asttypes.constant *) 44 | val to_constant : t -> Parsetree.constant 45 | 46 | end 47 | 48 | (** {2 Misc} *) 49 | 50 | val lid: ?loc:loc -> string -> lid 51 | 52 | (** {2 Expressions} *) 53 | 54 | val evar: ?loc:loc -> ?attrs:attrs -> string -> expression 55 | val let_in: ?loc:loc -> ?attrs:attrs -> ?recursive:bool -> value_binding list -> expression -> expression 56 | 57 | val constr: ?loc:loc -> ?attrs:attrs -> string -> expression list -> expression 58 | val record: ?loc:loc -> ?attrs:attrs -> ?over:expression -> (string * expression) list -> expression 59 | val tuple: ?loc:loc -> ?attrs:attrs -> expression list -> expression 60 | 61 | val nil: ?loc:loc -> ?attrs:attrs -> unit -> expression 62 | val cons: ?loc:loc -> ?attrs:attrs -> expression -> expression -> expression 63 | val list: ?loc:loc -> ?attrs:attrs -> expression list -> expression 64 | 65 | val unit: ?loc:loc -> ?attrs:attrs -> unit -> expression 66 | 67 | val func: ?loc:loc -> ?attrs:attrs -> (pattern * expression) list -> expression 68 | val lam: ?loc:loc -> ?attrs:attrs -> ?label:Label.t -> ?default:expression -> pattern -> expression -> expression 69 | val app: ?loc:loc -> ?attrs:attrs -> expression -> expression list -> expression 70 | 71 | val str: ?loc:loc -> ?attrs:attrs -> string -> expression 72 | val int: ?loc:loc -> ?attrs:attrs -> int -> expression 73 | val char: ?loc:loc -> ?attrs:attrs -> char -> expression 74 | val float: ?loc:loc -> ?attrs:attrs -> float -> expression 75 | 76 | val sequence: ?loc:loc -> ?attrs:attrs -> expression list -> expression 77 | (** Return [()] if the list is empty. Tail rec. *) 78 | 79 | (** {2 Patterns} *) 80 | 81 | val pvar: ?loc:loc -> ?attrs:attrs -> string -> pattern 82 | val pconstr: ?loc:loc -> ?attrs:attrs -> string -> pattern list -> pattern 83 | val precord: ?loc:loc -> ?attrs:attrs -> ?closed:closed_flag -> (string * pattern) list -> pattern 84 | val ptuple: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern 85 | 86 | val pnil: ?loc:loc -> ?attrs:attrs -> unit -> pattern 87 | val pcons: ?loc:loc -> ?attrs:attrs -> pattern -> pattern -> pattern 88 | val plist: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern 89 | 90 | val pstr: ?loc:loc -> ?attrs:attrs -> string -> pattern 91 | val pint: ?loc:loc -> ?attrs:attrs -> int -> pattern 92 | val pchar: ?loc:loc -> ?attrs:attrs -> char -> pattern 93 | val pfloat: ?loc:loc -> ?attrs:attrs -> float -> pattern 94 | 95 | val punit: ?loc:loc -> ?attrs:attrs -> unit -> pattern 96 | 97 | 98 | (** {2 Types} *) 99 | 100 | val tconstr: ?loc:loc -> ?attrs:attrs -> string -> core_type list -> core_type 101 | 102 | (** {2 AST deconstruction} *) 103 | 104 | val get_str: expression -> string option 105 | val get_str_with_quotation_delimiter: expression -> (string * string option) option 106 | val get_lid: expression -> string option 107 | 108 | val has_attr: string -> attributes -> bool 109 | val find_attr: string -> attributes -> payload option 110 | val find_attr_expr: string -> attributes -> expression option 111 | -------------------------------------------------------------------------------- /ast_convenience_404.ml: -------------------------------------------------------------------------------- 1 | open Migrate_parsetree.Ast_404 2 | 3 | (* This file is part of the ppx_tools package. It is released *) 4 | (* under the terms of the MIT license (see LICENSE file). *) 5 | (* Copyright 2013 Alain Frisch and LexiFi *) 6 | 7 | open Parsetree 8 | open Asttypes 9 | open Location 10 | open Ast_helper 11 | 12 | 13 | module Label = struct 14 | 15 | type t = Asttypes.arg_label 16 | 17 | type desc = Asttypes.arg_label = 18 | Nolabel 19 | | Labelled of string 20 | | Optional of string 21 | 22 | let explode x = x 23 | 24 | let nolabel = Nolabel 25 | let labelled x = Labelled x 26 | let optional x = Optional x 27 | 28 | end 29 | 30 | module Constant = struct 31 | type t = Parsetree.constant = 32 | Pconst_integer of string * char option 33 | | Pconst_char of char 34 | | Pconst_string of string * string option 35 | | Pconst_float of string * char option 36 | 37 | let of_constant x = x 38 | 39 | let to_constant x = x 40 | 41 | end 42 | 43 | let may_tuple ?loc tup = function 44 | | [] -> None 45 | | [x] -> Some x 46 | | l -> Some (tup ?loc ?attrs:None l) 47 | 48 | let lid ?(loc = !default_loc) s = mkloc (Longident.parse s) loc 49 | let constr ?loc ?attrs s args = Exp.construct ?loc ?attrs (lid ?loc s) (may_tuple ?loc Exp.tuple args) 50 | let nil ?loc ?attrs () = constr ?loc ?attrs "[]" [] 51 | let unit ?loc ?attrs () = constr ?loc ?attrs "()" [] 52 | let tuple ?loc ?attrs = function 53 | | [] -> unit ?loc ?attrs () 54 | | [x] -> x 55 | | xs -> Exp.tuple ?loc ?attrs xs 56 | let cons ?loc ?attrs hd tl = constr ?loc ?attrs "::" [hd; tl] 57 | let list ?loc ?attrs l = List.fold_right (cons ?loc ?attrs) l (nil ?loc ?attrs ()) 58 | let str ?loc ?attrs s = Exp.constant ?loc ?attrs (Pconst_string (s, None)) 59 | let int ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_integer (string_of_int x, None)) 60 | let int32 ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_integer (Int32.to_string x, Some 'l')) 61 | let int64 ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_integer (Int64.to_string x, Some 'L')) 62 | let char ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_char x) 63 | let float ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_float (string_of_float x, None)) 64 | let record ?loc ?attrs ?over l = 65 | Exp.record ?loc ?attrs (List.map (fun (s, e) -> (lid ~loc:e.pexp_loc s, e)) l) over 66 | let func ?loc ?attrs l = Exp.function_ ?loc ?attrs (List.map (fun (p, e) -> Exp.case p e) l) 67 | let lam ?loc ?attrs ?(label = Label.nolabel) ?default pat exp = Exp.fun_ ?loc ?attrs label default pat exp 68 | let app ?loc ?attrs f l = if l = [] then f else Exp.apply ?loc ?attrs f (List.map (fun a -> Label.nolabel, a) l) 69 | let evar ?loc ?attrs s = Exp.ident ?loc ?attrs (lid ?loc s) 70 | let let_in ?loc ?attrs ?(recursive = false) b body = 71 | Exp.let_ ?loc ?attrs (if recursive then Recursive else Nonrecursive) b body 72 | 73 | let sequence ?loc ?attrs = function 74 | | [] -> unit ?loc ?attrs () 75 | | hd :: tl -> List.fold_left (fun e1 e2 -> Exp.sequence ?loc ?attrs e1 e2) hd tl 76 | 77 | let pvar ?(loc = !default_loc) ?attrs s = Pat.var ~loc ?attrs (mkloc s loc) 78 | let pconstr ?loc ?attrs s args = Pat.construct ?loc ?attrs (lid ?loc s) (may_tuple ?loc Pat.tuple args) 79 | let precord ?loc ?attrs ?(closed = Open) l = 80 | Pat.record ?loc ?attrs (List.map (fun (s, e) -> (lid ~loc:e.ppat_loc s, e)) l) closed 81 | let pnil ?loc ?attrs () = pconstr ?loc ?attrs "[]" [] 82 | let pcons ?loc ?attrs hd tl = pconstr ?loc ?attrs "::" [hd; tl] 83 | let punit ?loc ?attrs () = pconstr ?loc ?attrs "()" [] 84 | let ptuple ?loc ?attrs = function 85 | | [] -> punit ?loc ?attrs () 86 | | [x] -> x 87 | | xs -> Pat.tuple ?loc ?attrs xs 88 | let plist ?loc ?attrs l = List.fold_right (pcons ?loc ?attrs) l (pnil ?loc ?attrs ()) 89 | 90 | let pstr ?loc ?attrs s = Pat.constant ?loc ?attrs (Pconst_string (s, None)) 91 | let pint ?loc ?attrs x = Pat.constant ?loc ?attrs (Pconst_integer (string_of_int x, None)) 92 | let pchar ?loc ?attrs x = Pat.constant ?loc ?attrs (Pconst_char x) 93 | let pfloat ?loc ?attrs x = Pat.constant ?loc ?attrs (Pconst_float (string_of_float x, None)) 94 | 95 | let tconstr ?loc ?attrs c l = Typ.constr ?loc ?attrs (lid ?loc c) l 96 | 97 | let get_str = function 98 | | {pexp_desc=Pexp_constant (Pconst_string (s, _)); _} -> Some s 99 | | _ -> None 100 | 101 | let get_str_with_quotation_delimiter = function 102 | | {pexp_desc=Pexp_constant (Pconst_string (s, d)); _} -> Some (s, d) 103 | | _ -> None 104 | 105 | let get_lid = function 106 | | {pexp_desc=Pexp_ident{txt=id;_};_} -> 107 | Some (String.concat "." (Longident.flatten id)) 108 | | _ -> None 109 | 110 | let find_attr s attrs = 111 | try Some (snd (List.find (fun (x, _) -> x.txt = s) attrs)) 112 | with Not_found -> None 113 | 114 | let expr_of_payload = function 115 | | PStr [{pstr_desc=Pstr_eval(e, _); _}] -> Some e 116 | | _ -> None 117 | 118 | let find_attr_expr s attrs = 119 | match find_attr s attrs with 120 | | Some e -> expr_of_payload e 121 | | None -> None 122 | 123 | let has_attr s attrs = 124 | find_attr s attrs <> None 125 | -------------------------------------------------------------------------------- /ast_convenience_404.mli: -------------------------------------------------------------------------------- 1 | open Migrate_parsetree.Ast_404 2 | 3 | (* This file is part of the ppx_tools package. It is released *) 4 | (* under the terms of the MIT license (see LICENSE file). *) 5 | (* Copyright 2013 Alain Frisch and LexiFi *) 6 | 7 | (** {1 Convenience functions to help build and deconstruct AST fragments.} *) 8 | 9 | open Asttypes 10 | open Ast_helper 11 | open Parsetree 12 | 13 | (** {2 Compatibility modules} *) 14 | 15 | module Label : sig 16 | type t = Asttypes.arg_label 17 | 18 | type desc = Asttypes.arg_label = 19 | Nolabel 20 | | Labelled of string 21 | | Optional of string 22 | 23 | val explode : t -> desc 24 | 25 | val nolabel : t 26 | val labelled : string -> t 27 | val optional : string -> t 28 | 29 | end 30 | 31 | (** {2 Provides a unified abstraction over differences in Parsetree.constant and Asttypes.constant 32 | * types defined in ocaml 4.03 and 4.02 respectively}*) 33 | module Constant : sig 34 | type t = Parsetree.constant = 35 | Pconst_integer of string * char option 36 | | Pconst_char of char 37 | | Pconst_string of string * string option 38 | | Pconst_float of string * char option 39 | 40 | (** Convert Asttypes.constant to Constant.t *) 41 | val of_constant : Parsetree.constant -> t 42 | 43 | (** Convert Constant.t to Asttypes.constant *) 44 | val to_constant : t -> Parsetree.constant 45 | 46 | end 47 | 48 | (** {2 Misc} *) 49 | 50 | val lid: ?loc:loc -> string -> lid 51 | 52 | (** {2 Expressions} *) 53 | 54 | val evar: ?loc:loc -> ?attrs:attrs -> string -> expression 55 | val let_in: ?loc:loc -> ?attrs:attrs -> ?recursive:bool -> value_binding list -> expression -> expression 56 | 57 | val constr: ?loc:loc -> ?attrs:attrs -> string -> expression list -> expression 58 | val record: ?loc:loc -> ?attrs:attrs -> ?over:expression -> (string * expression) list -> expression 59 | val tuple: ?loc:loc -> ?attrs:attrs -> expression list -> expression 60 | 61 | val nil: ?loc:loc -> ?attrs:attrs -> unit -> expression 62 | val cons: ?loc:loc -> ?attrs:attrs -> expression -> expression -> expression 63 | val list: ?loc:loc -> ?attrs:attrs -> expression list -> expression 64 | 65 | val unit: ?loc:loc -> ?attrs:attrs -> unit -> expression 66 | 67 | val func: ?loc:loc -> ?attrs:attrs -> (pattern * expression) list -> expression 68 | val lam: ?loc:loc -> ?attrs:attrs -> ?label:Label.t -> ?default:expression -> pattern -> expression -> expression 69 | val app: ?loc:loc -> ?attrs:attrs -> expression -> expression list -> expression 70 | 71 | val str: ?loc:loc -> ?attrs:attrs -> string -> expression 72 | val int: ?loc:loc -> ?attrs:attrs -> int -> expression 73 | val int32: ?loc:loc -> ?attrs:attrs -> int32 -> expression 74 | val int64: ?loc:loc -> ?attrs:attrs -> int64 -> expression 75 | val char: ?loc:loc -> ?attrs:attrs -> char -> expression 76 | val float: ?loc:loc -> ?attrs:attrs -> float -> expression 77 | 78 | val sequence: ?loc:loc -> ?attrs:attrs -> expression list -> expression 79 | (** Return [()] if the list is empty. Tail rec. *) 80 | 81 | (** {2 Patterns} *) 82 | 83 | val pvar: ?loc:loc -> ?attrs:attrs -> string -> pattern 84 | val pconstr: ?loc:loc -> ?attrs:attrs -> string -> pattern list -> pattern 85 | val precord: ?loc:loc -> ?attrs:attrs -> ?closed:closed_flag -> (string * pattern) list -> pattern 86 | val ptuple: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern 87 | 88 | val pnil: ?loc:loc -> ?attrs:attrs -> unit -> pattern 89 | val pcons: ?loc:loc -> ?attrs:attrs -> pattern -> pattern -> pattern 90 | val plist: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern 91 | 92 | val pstr: ?loc:loc -> ?attrs:attrs -> string -> pattern 93 | val pint: ?loc:loc -> ?attrs:attrs -> int -> pattern 94 | val pchar: ?loc:loc -> ?attrs:attrs -> char -> pattern 95 | val pfloat: ?loc:loc -> ?attrs:attrs -> float -> pattern 96 | 97 | val punit: ?loc:loc -> ?attrs:attrs -> unit -> pattern 98 | 99 | 100 | (** {2 Types} *) 101 | 102 | val tconstr: ?loc:loc -> ?attrs:attrs -> string -> core_type list -> core_type 103 | 104 | (** {2 AST deconstruction} *) 105 | 106 | val get_str: expression -> string option 107 | val get_str_with_quotation_delimiter: expression -> (string * string option) option 108 | val get_lid: expression -> string option 109 | 110 | val has_attr: string -> attributes -> bool 111 | val find_attr: string -> attributes -> payload option 112 | val find_attr_expr: string -> attributes -> expression option 113 | -------------------------------------------------------------------------------- /ast_convenience_405.ml: -------------------------------------------------------------------------------- 1 | open Migrate_parsetree.Ast_405 2 | 3 | (* This file is part of the ppx_tools package. It is released *) 4 | (* under the terms of the MIT license (see LICENSE file). *) 5 | (* Copyright 2013 Alain Frisch and LexiFi *) 6 | 7 | open Parsetree 8 | open Asttypes 9 | open Location 10 | open Ast_helper 11 | 12 | 13 | module Label = struct 14 | 15 | type t = Asttypes.arg_label 16 | 17 | type desc = Asttypes.arg_label = 18 | Nolabel 19 | | Labelled of string 20 | | Optional of string 21 | 22 | let explode x = x 23 | 24 | let nolabel = Nolabel 25 | let labelled x = Labelled x 26 | let optional x = Optional x 27 | 28 | end 29 | 30 | module Constant = struct 31 | type t = Parsetree.constant = 32 | Pconst_integer of string * char option 33 | | Pconst_char of char 34 | | Pconst_string of string * string option 35 | | Pconst_float of string * char option 36 | 37 | let of_constant x = x 38 | 39 | let to_constant x = x 40 | 41 | end 42 | 43 | let may_tuple ?loc tup = function 44 | | [] -> None 45 | | [x] -> Some x 46 | | l -> Some (tup ?loc ?attrs:None l) 47 | 48 | let lid ?(loc = !default_loc) s = mkloc (Longident.parse s) loc 49 | let constr ?loc ?attrs s args = Exp.construct ?loc ?attrs (lid ?loc s) (may_tuple ?loc Exp.tuple args) 50 | let nil ?loc ?attrs () = constr ?loc ?attrs "[]" [] 51 | let unit ?loc ?attrs () = constr ?loc ?attrs "()" [] 52 | let tuple ?loc ?attrs = function 53 | | [] -> unit ?loc ?attrs () 54 | | [x] -> x 55 | | xs -> Exp.tuple ?loc ?attrs xs 56 | let cons ?loc ?attrs hd tl = constr ?loc ?attrs "::" [hd; tl] 57 | let list ?loc ?attrs l = List.fold_right (cons ?loc ?attrs) l (nil ?loc ?attrs ()) 58 | let str ?loc ?attrs s = Exp.constant ?loc ?attrs (Pconst_string (s, None)) 59 | let int ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_integer (string_of_int x, None)) 60 | let int32 ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_integer (Int32.to_string x, Some 'l')) 61 | let int64 ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_integer (Int64.to_string x, Some 'L')) 62 | let char ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_char x) 63 | let float ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_float (string_of_float x, None)) 64 | let record ?loc ?attrs ?over l = 65 | Exp.record ?loc ?attrs (List.map (fun (s, e) -> (lid ~loc:e.pexp_loc s, e)) l) over 66 | let func ?loc ?attrs l = Exp.function_ ?loc ?attrs (List.map (fun (p, e) -> Exp.case p e) l) 67 | let lam ?loc ?attrs ?(label = Label.nolabel) ?default pat exp = Exp.fun_ ?loc ?attrs label default pat exp 68 | let app ?loc ?attrs f l = if l = [] then f else Exp.apply ?loc ?attrs f (List.map (fun a -> Label.nolabel, a) l) 69 | let evar ?loc ?attrs s = Exp.ident ?loc ?attrs (lid ?loc s) 70 | let let_in ?loc ?attrs ?(recursive = false) b body = 71 | Exp.let_ ?loc ?attrs (if recursive then Recursive else Nonrecursive) b body 72 | 73 | let sequence ?loc ?attrs = function 74 | | [] -> unit ?loc ?attrs () 75 | | hd :: tl -> List.fold_left (fun e1 e2 -> Exp.sequence ?loc ?attrs e1 e2) hd tl 76 | 77 | let pvar ?(loc = !default_loc) ?attrs s = Pat.var ~loc ?attrs (mkloc s loc) 78 | let pconstr ?loc ?attrs s args = Pat.construct ?loc ?attrs (lid ?loc s) (may_tuple ?loc Pat.tuple args) 79 | let precord ?loc ?attrs ?(closed = Open) l = 80 | Pat.record ?loc ?attrs (List.map (fun (s, e) -> (lid ~loc:e.ppat_loc s, e)) l) closed 81 | let pnil ?loc ?attrs () = pconstr ?loc ?attrs "[]" [] 82 | let pcons ?loc ?attrs hd tl = pconstr ?loc ?attrs "::" [hd; tl] 83 | let punit ?loc ?attrs () = pconstr ?loc ?attrs "()" [] 84 | let ptuple ?loc ?attrs = function 85 | | [] -> punit ?loc ?attrs () 86 | | [x] -> x 87 | | xs -> Pat.tuple ?loc ?attrs xs 88 | let plist ?loc ?attrs l = List.fold_right (pcons ?loc ?attrs) l (pnil ?loc ?attrs ()) 89 | 90 | let pstr ?loc ?attrs s = Pat.constant ?loc ?attrs (Pconst_string (s, None)) 91 | let pint ?loc ?attrs x = Pat.constant ?loc ?attrs (Pconst_integer (string_of_int x, None)) 92 | let pchar ?loc ?attrs x = Pat.constant ?loc ?attrs (Pconst_char x) 93 | let pfloat ?loc ?attrs x = Pat.constant ?loc ?attrs (Pconst_float (string_of_float x, None)) 94 | 95 | let tconstr ?loc ?attrs c l = Typ.constr ?loc ?attrs (lid ?loc c) l 96 | 97 | let get_str = function 98 | | {pexp_desc=Pexp_constant (Pconst_string (s, _)); _} -> Some s 99 | | _ -> None 100 | 101 | let get_str_with_quotation_delimiter = function 102 | | {pexp_desc=Pexp_constant (Pconst_string (s, d)); _} -> Some (s, d) 103 | | _ -> None 104 | 105 | let get_lid = function 106 | | {pexp_desc=Pexp_ident{txt=id;_};_} -> 107 | Some (String.concat "." (Longident.flatten id)) 108 | | _ -> None 109 | 110 | let find_attr s attrs = 111 | try Some (snd (List.find (fun (x, _) -> x.txt = s) attrs)) 112 | with Not_found -> None 113 | 114 | let expr_of_payload = function 115 | | PStr [{pstr_desc=Pstr_eval(e, _); _}] -> Some e 116 | | _ -> None 117 | 118 | let find_attr_expr s attrs = 119 | match find_attr s attrs with 120 | | Some e -> expr_of_payload e 121 | | None -> None 122 | 123 | let has_attr s attrs = 124 | find_attr s attrs <> None 125 | -------------------------------------------------------------------------------- /ast_convenience_405.mli: -------------------------------------------------------------------------------- 1 | open Migrate_parsetree.Ast_405 2 | 3 | (* This file is part of the ppx_tools package. It is released *) 4 | (* under the terms of the MIT license (see LICENSE file). *) 5 | (* Copyright 2013 Alain Frisch and LexiFi *) 6 | 7 | (** {1 Convenience functions to help build and deconstruct AST fragments.} *) 8 | 9 | open Asttypes 10 | open Ast_helper 11 | open Parsetree 12 | 13 | (** {2 Compatibility modules} *) 14 | 15 | module Label : sig 16 | type t = Asttypes.arg_label 17 | 18 | type desc = Asttypes.arg_label = 19 | Nolabel 20 | | Labelled of string 21 | | Optional of string 22 | 23 | val explode : t -> desc 24 | 25 | val nolabel : t 26 | val labelled : string -> t 27 | val optional : string -> t 28 | 29 | end 30 | 31 | (** {2 Provides a unified abstraction over differences in Parsetree.constant and Asttypes.constant 32 | * types defined in ocaml 4.03 and 4.02 respectively}*) 33 | module Constant : sig 34 | type t = Parsetree.constant = 35 | Pconst_integer of string * char option 36 | | Pconst_char of char 37 | | Pconst_string of string * string option 38 | | Pconst_float of string * char option 39 | 40 | (** Convert Asttypes.constant to Constant.t *) 41 | val of_constant : Parsetree.constant -> t 42 | 43 | (** Convert Constant.t to Asttypes.constant *) 44 | val to_constant : t -> Parsetree.constant 45 | 46 | end 47 | 48 | (** {2 Misc} *) 49 | 50 | val lid: ?loc:loc -> string -> lid 51 | 52 | (** {2 Expressions} *) 53 | 54 | val evar: ?loc:loc -> ?attrs:attrs -> string -> expression 55 | val let_in: ?loc:loc -> ?attrs:attrs -> ?recursive:bool -> value_binding list -> expression -> expression 56 | 57 | val constr: ?loc:loc -> ?attrs:attrs -> string -> expression list -> expression 58 | val record: ?loc:loc -> ?attrs:attrs -> ?over:expression -> (string * expression) list -> expression 59 | val tuple: ?loc:loc -> ?attrs:attrs -> expression list -> expression 60 | 61 | val nil: ?loc:loc -> ?attrs:attrs -> unit -> expression 62 | val cons: ?loc:loc -> ?attrs:attrs -> expression -> expression -> expression 63 | val list: ?loc:loc -> ?attrs:attrs -> expression list -> expression 64 | 65 | val unit: ?loc:loc -> ?attrs:attrs -> unit -> expression 66 | 67 | val func: ?loc:loc -> ?attrs:attrs -> (pattern * expression) list -> expression 68 | val lam: ?loc:loc -> ?attrs:attrs -> ?label:Label.t -> ?default:expression -> pattern -> expression -> expression 69 | val app: ?loc:loc -> ?attrs:attrs -> expression -> expression list -> expression 70 | 71 | val str: ?loc:loc -> ?attrs:attrs -> string -> expression 72 | val int: ?loc:loc -> ?attrs:attrs -> int -> expression 73 | val int32: ?loc:loc -> ?attrs:attrs -> int32 -> expression 74 | val int64: ?loc:loc -> ?attrs:attrs -> int64 -> expression 75 | val char: ?loc:loc -> ?attrs:attrs -> char -> expression 76 | val float: ?loc:loc -> ?attrs:attrs -> float -> expression 77 | 78 | val sequence: ?loc:loc -> ?attrs:attrs -> expression list -> expression 79 | (** Return [()] if the list is empty. Tail rec. *) 80 | 81 | (** {2 Patterns} *) 82 | 83 | val pvar: ?loc:loc -> ?attrs:attrs -> string -> pattern 84 | val pconstr: ?loc:loc -> ?attrs:attrs -> string -> pattern list -> pattern 85 | val precord: ?loc:loc -> ?attrs:attrs -> ?closed:closed_flag -> (string * pattern) list -> pattern 86 | val ptuple: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern 87 | 88 | val pnil: ?loc:loc -> ?attrs:attrs -> unit -> pattern 89 | val pcons: ?loc:loc -> ?attrs:attrs -> pattern -> pattern -> pattern 90 | val plist: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern 91 | 92 | val pstr: ?loc:loc -> ?attrs:attrs -> string -> pattern 93 | val pint: ?loc:loc -> ?attrs:attrs -> int -> pattern 94 | val pchar: ?loc:loc -> ?attrs:attrs -> char -> pattern 95 | val pfloat: ?loc:loc -> ?attrs:attrs -> float -> pattern 96 | 97 | val punit: ?loc:loc -> ?attrs:attrs -> unit -> pattern 98 | 99 | 100 | (** {2 Types} *) 101 | 102 | val tconstr: ?loc:loc -> ?attrs:attrs -> string -> core_type list -> core_type 103 | 104 | (** {2 AST deconstruction} *) 105 | 106 | val get_str: expression -> string option 107 | val get_str_with_quotation_delimiter: expression -> (string * string option) option 108 | val get_lid: expression -> string option 109 | 110 | val has_attr: string -> attributes -> bool 111 | val find_attr: string -> attributes -> payload option 112 | val find_attr_expr: string -> attributes -> expression option 113 | -------------------------------------------------------------------------------- /ast_convenience_406.ml: -------------------------------------------------------------------------------- 1 | open Migrate_parsetree.Ast_406 2 | 3 | (* This file is part of the ppx_tools package. It is released *) 4 | (* under the terms of the MIT license (see LICENSE file). *) 5 | (* Copyright 2013 Alain Frisch and LexiFi *) 6 | 7 | open Parsetree 8 | open Asttypes 9 | open Location 10 | open Ast_helper 11 | 12 | 13 | module Label = struct 14 | 15 | type t = Asttypes.arg_label 16 | 17 | type desc = Asttypes.arg_label = 18 | Nolabel 19 | | Labelled of string 20 | | Optional of string 21 | 22 | let explode x = x 23 | 24 | let nolabel = Nolabel 25 | let labelled x = Labelled x 26 | let optional x = Optional x 27 | 28 | end 29 | 30 | module Constant = struct 31 | type t = Parsetree.constant = 32 | Pconst_integer of string * char option 33 | | Pconst_char of char 34 | | Pconst_string of string * string option 35 | | Pconst_float of string * char option 36 | 37 | let of_constant x = x 38 | 39 | let to_constant x = x 40 | 41 | end 42 | 43 | let may_tuple ?loc tup = function 44 | | [] -> None 45 | | [x] -> Some x 46 | | l -> Some (tup ?loc ?attrs:None l) 47 | 48 | let lid ?(loc = !default_loc) s = mkloc (Longident.parse s) loc 49 | let constr ?loc ?attrs s args = Exp.construct ?loc ?attrs (lid ?loc s) (may_tuple ?loc Exp.tuple args) 50 | let nil ?loc ?attrs () = constr ?loc ?attrs "[]" [] 51 | let unit ?loc ?attrs () = constr ?loc ?attrs "()" [] 52 | let tuple ?loc ?attrs = function 53 | | [] -> unit ?loc ?attrs () 54 | | [x] -> x 55 | | xs -> Exp.tuple ?loc ?attrs xs 56 | let cons ?loc ?attrs hd tl = constr ?loc ?attrs "::" [hd; tl] 57 | let list ?loc ?attrs l = List.fold_right (cons ?loc ?attrs) l (nil ?loc ?attrs ()) 58 | let str ?loc ?attrs s = Exp.constant ?loc ?attrs (Pconst_string (s, None)) 59 | let int ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_integer (string_of_int x, None)) 60 | let int32 ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_integer (Int32.to_string x, Some 'l')) 61 | let int64 ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_integer (Int64.to_string x, Some 'L')) 62 | let char ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_char x) 63 | let float ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_float (string_of_float x, None)) 64 | let record ?loc ?attrs ?over l = 65 | Exp.record ?loc ?attrs (List.map (fun (s, e) -> (lid ~loc:e.pexp_loc s, e)) l) over 66 | let func ?loc ?attrs l = Exp.function_ ?loc ?attrs (List.map (fun (p, e) -> Exp.case p e) l) 67 | let lam ?loc ?attrs ?(label = Label.nolabel) ?default pat exp = Exp.fun_ ?loc ?attrs label default pat exp 68 | let app ?loc ?attrs f l = if l = [] then f else Exp.apply ?loc ?attrs f (List.map (fun a -> Label.nolabel, a) l) 69 | let evar ?loc ?attrs s = Exp.ident ?loc ?attrs (lid ?loc s) 70 | let let_in ?loc ?attrs ?(recursive = false) b body = 71 | Exp.let_ ?loc ?attrs (if recursive then Recursive else Nonrecursive) b body 72 | 73 | let sequence ?loc ?attrs = function 74 | | [] -> unit ?loc ?attrs () 75 | | hd :: tl -> List.fold_left (fun e1 e2 -> Exp.sequence ?loc ?attrs e1 e2) hd tl 76 | 77 | let pvar ?(loc = !default_loc) ?attrs s = Pat.var ~loc ?attrs (mkloc s loc) 78 | let pconstr ?loc ?attrs s args = Pat.construct ?loc ?attrs (lid ?loc s) (may_tuple ?loc Pat.tuple args) 79 | let precord ?loc ?attrs ?(closed = Open) l = 80 | Pat.record ?loc ?attrs (List.map (fun (s, e) -> (lid ~loc:e.ppat_loc s, e)) l) closed 81 | let pnil ?loc ?attrs () = pconstr ?loc ?attrs "[]" [] 82 | let pcons ?loc ?attrs hd tl = pconstr ?loc ?attrs "::" [hd; tl] 83 | let punit ?loc ?attrs () = pconstr ?loc ?attrs "()" [] 84 | let ptuple ?loc ?attrs = function 85 | | [] -> punit ?loc ?attrs () 86 | | [x] -> x 87 | | xs -> Pat.tuple ?loc ?attrs xs 88 | let plist ?loc ?attrs l = List.fold_right (pcons ?loc ?attrs) l (pnil ?loc ?attrs ()) 89 | 90 | let pstr ?loc ?attrs s = Pat.constant ?loc ?attrs (Pconst_string (s, None)) 91 | let pint ?loc ?attrs x = Pat.constant ?loc ?attrs (Pconst_integer (string_of_int x, None)) 92 | let pchar ?loc ?attrs x = Pat.constant ?loc ?attrs (Pconst_char x) 93 | let pfloat ?loc ?attrs x = Pat.constant ?loc ?attrs (Pconst_float (string_of_float x, None)) 94 | 95 | let tconstr ?loc ?attrs c l = Typ.constr ?loc ?attrs (lid ?loc c) l 96 | 97 | let get_str = function 98 | | {pexp_desc=Pexp_constant (Pconst_string (s, _)); _} -> Some s 99 | | _ -> None 100 | 101 | let get_str_with_quotation_delimiter = function 102 | | {pexp_desc=Pexp_constant (Pconst_string (s, d)); _} -> Some (s, d) 103 | | _ -> None 104 | 105 | let get_lid = function 106 | | {pexp_desc=Pexp_ident{txt=id;_};_} -> 107 | Some (String.concat "." (Longident.flatten id)) 108 | | _ -> None 109 | 110 | let find_attr s attrs = 111 | try Some (snd (List.find (fun (x, _) -> x.txt = s) attrs)) 112 | with Not_found -> None 113 | 114 | let expr_of_payload = function 115 | | PStr [{pstr_desc=Pstr_eval(e, _); _}] -> Some e 116 | | _ -> None 117 | 118 | let find_attr_expr s attrs = 119 | match find_attr s attrs with 120 | | Some e -> expr_of_payload e 121 | | None -> None 122 | 123 | let has_attr s attrs = 124 | find_attr s attrs <> None 125 | -------------------------------------------------------------------------------- /ast_convenience_406.mli: -------------------------------------------------------------------------------- 1 | open Migrate_parsetree.Ast_406 2 | 3 | (* This file is part of the ppx_tools package. It is released *) 4 | (* under the terms of the MIT license (see LICENSE file). *) 5 | (* Copyright 2013 Alain Frisch and LexiFi *) 6 | 7 | (** {1 Convenience functions to help build and deconstruct AST fragments.} *) 8 | 9 | open Asttypes 10 | open Ast_helper 11 | open Parsetree 12 | 13 | (** {2 Compatibility modules} *) 14 | 15 | module Label : sig 16 | type t = Asttypes.arg_label 17 | 18 | type desc = Asttypes.arg_label = 19 | Nolabel 20 | | Labelled of string 21 | | Optional of string 22 | 23 | val explode : t -> desc 24 | 25 | val nolabel : t 26 | val labelled : string -> t 27 | val optional : string -> t 28 | 29 | end 30 | 31 | (** {2 Provides a unified abstraction over differences in Parsetree.constant and Asttypes.constant 32 | * types defined in ocaml 4.03 and 4.02 respectively}*) 33 | module Constant : sig 34 | type t = Parsetree.constant = 35 | Pconst_integer of string * char option 36 | | Pconst_char of char 37 | | Pconst_string of string * string option 38 | | Pconst_float of string * char option 39 | 40 | (** Convert Asttypes.constant to Constant.t *) 41 | val of_constant : Parsetree.constant -> t 42 | 43 | (** Convert Constant.t to Asttypes.constant *) 44 | val to_constant : t -> Parsetree.constant 45 | 46 | end 47 | 48 | (** {2 Misc} *) 49 | 50 | val lid: ?loc:loc -> string -> lid 51 | 52 | (** {2 Expressions} *) 53 | 54 | val evar: ?loc:loc -> ?attrs:attrs -> string -> expression 55 | val let_in: ?loc:loc -> ?attrs:attrs -> ?recursive:bool -> value_binding list -> expression -> expression 56 | 57 | val constr: ?loc:loc -> ?attrs:attrs -> string -> expression list -> expression 58 | val record: ?loc:loc -> ?attrs:attrs -> ?over:expression -> (string * expression) list -> expression 59 | val tuple: ?loc:loc -> ?attrs:attrs -> expression list -> expression 60 | 61 | val nil: ?loc:loc -> ?attrs:attrs -> unit -> expression 62 | val cons: ?loc:loc -> ?attrs:attrs -> expression -> expression -> expression 63 | val list: ?loc:loc -> ?attrs:attrs -> expression list -> expression 64 | 65 | val unit: ?loc:loc -> ?attrs:attrs -> unit -> expression 66 | 67 | val func: ?loc:loc -> ?attrs:attrs -> (pattern * expression) list -> expression 68 | val lam: ?loc:loc -> ?attrs:attrs -> ?label:Label.t -> ?default:expression -> pattern -> expression -> expression 69 | val app: ?loc:loc -> ?attrs:attrs -> expression -> expression list -> expression 70 | 71 | val str: ?loc:loc -> ?attrs:attrs -> string -> expression 72 | val int: ?loc:loc -> ?attrs:attrs -> int -> expression 73 | val int32: ?loc:loc -> ?attrs:attrs -> int32 -> expression 74 | val int64: ?loc:loc -> ?attrs:attrs -> int64 -> expression 75 | val char: ?loc:loc -> ?attrs:attrs -> char -> expression 76 | val float: ?loc:loc -> ?attrs:attrs -> float -> expression 77 | 78 | val sequence: ?loc:loc -> ?attrs:attrs -> expression list -> expression 79 | (** Return [()] if the list is empty. Tail rec. *) 80 | 81 | (** {2 Patterns} *) 82 | 83 | val pvar: ?loc:loc -> ?attrs:attrs -> string -> pattern 84 | val pconstr: ?loc:loc -> ?attrs:attrs -> string -> pattern list -> pattern 85 | val precord: ?loc:loc -> ?attrs:attrs -> ?closed:closed_flag -> (string * pattern) list -> pattern 86 | val ptuple: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern 87 | 88 | val pnil: ?loc:loc -> ?attrs:attrs -> unit -> pattern 89 | val pcons: ?loc:loc -> ?attrs:attrs -> pattern -> pattern -> pattern 90 | val plist: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern 91 | 92 | val pstr: ?loc:loc -> ?attrs:attrs -> string -> pattern 93 | val pint: ?loc:loc -> ?attrs:attrs -> int -> pattern 94 | val pchar: ?loc:loc -> ?attrs:attrs -> char -> pattern 95 | val pfloat: ?loc:loc -> ?attrs:attrs -> float -> pattern 96 | 97 | val punit: ?loc:loc -> ?attrs:attrs -> unit -> pattern 98 | 99 | 100 | (** {2 Types} *) 101 | 102 | val tconstr: ?loc:loc -> ?attrs:attrs -> string -> core_type list -> core_type 103 | 104 | (** {2 AST deconstruction} *) 105 | 106 | val get_str: expression -> string option 107 | val get_str_with_quotation_delimiter: expression -> (string * string option) option 108 | val get_lid: expression -> string option 109 | 110 | val has_attr: string -> attributes -> bool 111 | val find_attr: string -> attributes -> payload option 112 | val find_attr_expr: string -> attributes -> expression option 113 | -------------------------------------------------------------------------------- /ast_convenience_407.ml: -------------------------------------------------------------------------------- 1 | open Migrate_parsetree.Ast_407 2 | 3 | (* This file is part of the ppx_tools package. It is released *) 4 | (* under the terms of the MIT license (see LICENSE file). *) 5 | (* Copyright 2013 Alain Frisch and LexiFi *) 6 | 7 | open Parsetree 8 | open Asttypes 9 | open Location 10 | open Ast_helper 11 | 12 | 13 | module Label = struct 14 | 15 | type t = Asttypes.arg_label 16 | 17 | type desc = Asttypes.arg_label = 18 | Nolabel 19 | | Labelled of string 20 | | Optional of string 21 | 22 | let explode x = x 23 | 24 | let nolabel = Nolabel 25 | let labelled x = Labelled x 26 | let optional x = Optional x 27 | 28 | end 29 | 30 | module Constant = struct 31 | type t = Parsetree.constant = 32 | Pconst_integer of string * char option 33 | | Pconst_char of char 34 | | Pconst_string of string * string option 35 | | Pconst_float of string * char option 36 | 37 | let of_constant x = x 38 | 39 | let to_constant x = x 40 | 41 | end 42 | 43 | let may_tuple ?loc tup = function 44 | | [] -> None 45 | | [x] -> Some x 46 | | l -> Some (tup ?loc ?attrs:None l) 47 | 48 | let lid ?(loc = !default_loc) s = mkloc (Longident.parse s) loc 49 | let constr ?loc ?attrs s args = Exp.construct ?loc ?attrs (lid ?loc s) (may_tuple ?loc Exp.tuple args) 50 | let nil ?loc ?attrs () = constr ?loc ?attrs "[]" [] 51 | let unit ?loc ?attrs () = constr ?loc ?attrs "()" [] 52 | let tuple ?loc ?attrs = function 53 | | [] -> unit ?loc ?attrs () 54 | | [x] -> x 55 | | xs -> Exp.tuple ?loc ?attrs xs 56 | let cons ?loc ?attrs hd tl = constr ?loc ?attrs "::" [hd; tl] 57 | let list ?loc ?attrs l = List.fold_right (cons ?loc ?attrs) l (nil ?loc ?attrs ()) 58 | let str ?loc ?attrs s = Exp.constant ?loc ?attrs (Pconst_string (s, None)) 59 | let int ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_integer (string_of_int x, None)) 60 | let int32 ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_integer (Int32.to_string x, Some 'l')) 61 | let int64 ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_integer (Int64.to_string x, Some 'L')) 62 | let char ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_char x) 63 | let float ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_float (string_of_float x, None)) 64 | let record ?loc ?attrs ?over l = 65 | Exp.record ?loc ?attrs (List.map (fun (s, e) -> (lid ~loc:e.pexp_loc s, e)) l) over 66 | let func ?loc ?attrs l = Exp.function_ ?loc ?attrs (List.map (fun (p, e) -> Exp.case p e) l) 67 | let lam ?loc ?attrs ?(label = Label.nolabel) ?default pat exp = Exp.fun_ ?loc ?attrs label default pat exp 68 | let app ?loc ?attrs f l = if l = [] then f else Exp.apply ?loc ?attrs f (List.map (fun a -> Label.nolabel, a) l) 69 | let evar ?loc ?attrs s = Exp.ident ?loc ?attrs (lid ?loc s) 70 | let let_in ?loc ?attrs ?(recursive = false) b body = 71 | Exp.let_ ?loc ?attrs (if recursive then Recursive else Nonrecursive) b body 72 | 73 | let sequence ?loc ?attrs = function 74 | | [] -> unit ?loc ?attrs () 75 | | hd :: tl -> List.fold_left (fun e1 e2 -> Exp.sequence ?loc ?attrs e1 e2) hd tl 76 | 77 | let pvar ?(loc = !default_loc) ?attrs s = Pat.var ~loc ?attrs (mkloc s loc) 78 | let pconstr ?loc ?attrs s args = Pat.construct ?loc ?attrs (lid ?loc s) (may_tuple ?loc Pat.tuple args) 79 | let precord ?loc ?attrs ?(closed = Open) l = 80 | Pat.record ?loc ?attrs (List.map (fun (s, e) -> (lid ~loc:e.ppat_loc s, e)) l) closed 81 | let pnil ?loc ?attrs () = pconstr ?loc ?attrs "[]" [] 82 | let pcons ?loc ?attrs hd tl = pconstr ?loc ?attrs "::" [hd; tl] 83 | let punit ?loc ?attrs () = pconstr ?loc ?attrs "()" [] 84 | let ptuple ?loc ?attrs = function 85 | | [] -> punit ?loc ?attrs () 86 | | [x] -> x 87 | | xs -> Pat.tuple ?loc ?attrs xs 88 | let plist ?loc ?attrs l = List.fold_right (pcons ?loc ?attrs) l (pnil ?loc ?attrs ()) 89 | 90 | let pstr ?loc ?attrs s = Pat.constant ?loc ?attrs (Pconst_string (s, None)) 91 | let pint ?loc ?attrs x = Pat.constant ?loc ?attrs (Pconst_integer (string_of_int x, None)) 92 | let pchar ?loc ?attrs x = Pat.constant ?loc ?attrs (Pconst_char x) 93 | let pfloat ?loc ?attrs x = Pat.constant ?loc ?attrs (Pconst_float (string_of_float x, None)) 94 | 95 | let tconstr ?loc ?attrs c l = Typ.constr ?loc ?attrs (lid ?loc c) l 96 | 97 | let get_str = function 98 | | {pexp_desc=Pexp_constant (Pconst_string (s, _)); _} -> Some s 99 | | _ -> None 100 | 101 | let get_str_with_quotation_delimiter = function 102 | | {pexp_desc=Pexp_constant (Pconst_string (s, d)); _} -> Some (s, d) 103 | | _ -> None 104 | 105 | let get_lid = function 106 | | {pexp_desc=Pexp_ident{txt=id;_};_} -> 107 | Some (String.concat "." (Longident.flatten id)) 108 | | _ -> None 109 | 110 | let find_attr s attrs = 111 | try Some (snd (List.find (fun (x, _) -> x.txt = s) attrs)) 112 | with Not_found -> None 113 | 114 | let expr_of_payload = function 115 | | PStr [{pstr_desc=Pstr_eval(e, _); _}] -> Some e 116 | | _ -> None 117 | 118 | let find_attr_expr s attrs = 119 | match find_attr s attrs with 120 | | Some e -> expr_of_payload e 121 | | None -> None 122 | 123 | let has_attr s attrs = 124 | find_attr s attrs <> None 125 | -------------------------------------------------------------------------------- /ast_convenience_407.mli: -------------------------------------------------------------------------------- 1 | open Migrate_parsetree.Ast_407 2 | 3 | (* This file is part of the ppx_tools package. It is released *) 4 | (* under the terms of the MIT license (see LICENSE file). *) 5 | (* Copyright 2013 Alain Frisch and LexiFi *) 6 | 7 | (** {1 Convenience functions to help build and deconstruct AST fragments.} *) 8 | 9 | open Asttypes 10 | open Ast_helper 11 | open Parsetree 12 | 13 | (** {2 Compatibility modules} *) 14 | 15 | module Label : sig 16 | type t = Asttypes.arg_label 17 | 18 | type desc = Asttypes.arg_label = 19 | Nolabel 20 | | Labelled of string 21 | | Optional of string 22 | 23 | val explode : t -> desc 24 | 25 | val nolabel : t 26 | val labelled : string -> t 27 | val optional : string -> t 28 | 29 | end 30 | 31 | (** {2 Provides a unified abstraction over differences in Parsetree.constant and Asttypes.constant 32 | * types defined in ocaml 4.03 and 4.02 respectively}*) 33 | module Constant : sig 34 | type t = Parsetree.constant = 35 | Pconst_integer of string * char option 36 | | Pconst_char of char 37 | | Pconst_string of string * string option 38 | | Pconst_float of string * char option 39 | 40 | (** Convert Asttypes.constant to Constant.t *) 41 | val of_constant : Parsetree.constant -> t 42 | 43 | (** Convert Constant.t to Asttypes.constant *) 44 | val to_constant : t -> Parsetree.constant 45 | 46 | end 47 | 48 | (** {2 Misc} *) 49 | 50 | val lid: ?loc:loc -> string -> lid 51 | 52 | (** {2 Expressions} *) 53 | 54 | val evar: ?loc:loc -> ?attrs:attrs -> string -> expression 55 | val let_in: ?loc:loc -> ?attrs:attrs -> ?recursive:bool -> value_binding list -> expression -> expression 56 | 57 | val constr: ?loc:loc -> ?attrs:attrs -> string -> expression list -> expression 58 | val record: ?loc:loc -> ?attrs:attrs -> ?over:expression -> (string * expression) list -> expression 59 | val tuple: ?loc:loc -> ?attrs:attrs -> expression list -> expression 60 | 61 | val nil: ?loc:loc -> ?attrs:attrs -> unit -> expression 62 | val cons: ?loc:loc -> ?attrs:attrs -> expression -> expression -> expression 63 | val list: ?loc:loc -> ?attrs:attrs -> expression list -> expression 64 | 65 | val unit: ?loc:loc -> ?attrs:attrs -> unit -> expression 66 | 67 | val func: ?loc:loc -> ?attrs:attrs -> (pattern * expression) list -> expression 68 | val lam: ?loc:loc -> ?attrs:attrs -> ?label:Label.t -> ?default:expression -> pattern -> expression -> expression 69 | val app: ?loc:loc -> ?attrs:attrs -> expression -> expression list -> expression 70 | 71 | val str: ?loc:loc -> ?attrs:attrs -> string -> expression 72 | val int: ?loc:loc -> ?attrs:attrs -> int -> expression 73 | val int32: ?loc:loc -> ?attrs:attrs -> int32 -> expression 74 | val int64: ?loc:loc -> ?attrs:attrs -> int64 -> expression 75 | val char: ?loc:loc -> ?attrs:attrs -> char -> expression 76 | val float: ?loc:loc -> ?attrs:attrs -> float -> expression 77 | 78 | val sequence: ?loc:loc -> ?attrs:attrs -> expression list -> expression 79 | (** Return [()] if the list is empty. Tail rec. *) 80 | 81 | (** {2 Patterns} *) 82 | 83 | val pvar: ?loc:loc -> ?attrs:attrs -> string -> pattern 84 | val pconstr: ?loc:loc -> ?attrs:attrs -> string -> pattern list -> pattern 85 | val precord: ?loc:loc -> ?attrs:attrs -> ?closed:closed_flag -> (string * pattern) list -> pattern 86 | val ptuple: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern 87 | 88 | val pnil: ?loc:loc -> ?attrs:attrs -> unit -> pattern 89 | val pcons: ?loc:loc -> ?attrs:attrs -> pattern -> pattern -> pattern 90 | val plist: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern 91 | 92 | val pstr: ?loc:loc -> ?attrs:attrs -> string -> pattern 93 | val pint: ?loc:loc -> ?attrs:attrs -> int -> pattern 94 | val pchar: ?loc:loc -> ?attrs:attrs -> char -> pattern 95 | val pfloat: ?loc:loc -> ?attrs:attrs -> float -> pattern 96 | 97 | val punit: ?loc:loc -> ?attrs:attrs -> unit -> pattern 98 | 99 | 100 | (** {2 Types} *) 101 | 102 | val tconstr: ?loc:loc -> ?attrs:attrs -> string -> core_type list -> core_type 103 | 104 | (** {2 AST deconstruction} *) 105 | 106 | val get_str: expression -> string option 107 | val get_str_with_quotation_delimiter: expression -> (string * string option) option 108 | val get_lid: expression -> string option 109 | 110 | val has_attr: string -> attributes -> bool 111 | val find_attr: string -> attributes -> payload option 112 | val find_attr_expr: string -> attributes -> expression option 113 | -------------------------------------------------------------------------------- /ast_convenience_408.ml: -------------------------------------------------------------------------------- 1 | open Migrate_parsetree.Ast_408 2 | 3 | (* This file is part of the ppx_tools package. It is released *) 4 | (* under the terms of the MIT license (see LICENSE file). *) 5 | (* Copyright 2013 Alain Frisch and LexiFi *) 6 | 7 | open Parsetree 8 | open Asttypes 9 | open Location 10 | open Ast_helper 11 | 12 | 13 | module Label = struct 14 | 15 | type t = Asttypes.arg_label 16 | 17 | type desc = Asttypes.arg_label = 18 | Nolabel 19 | | Labelled of string 20 | | Optional of string 21 | 22 | let explode x = x 23 | 24 | let nolabel = Nolabel 25 | let labelled x = Labelled x 26 | let optional x = Optional x 27 | 28 | end 29 | 30 | module Constant = struct 31 | type t = Parsetree.constant = 32 | Pconst_integer of string * char option 33 | | Pconst_char of char 34 | | Pconst_string of string * string option 35 | | Pconst_float of string * char option 36 | 37 | let of_constant x = x 38 | 39 | let to_constant x = x 40 | 41 | end 42 | 43 | let may_tuple ?loc tup = function 44 | | [] -> None 45 | | [x] -> Some x 46 | | l -> Some (tup ?loc ?attrs:None l) 47 | 48 | let lid ?(loc = !default_loc) s = mkloc (Longident.parse s) loc 49 | let constr ?loc ?attrs s args = Exp.construct ?loc ?attrs (lid ?loc s) (may_tuple ?loc Exp.tuple args) 50 | let nil ?loc ?attrs () = constr ?loc ?attrs "[]" [] 51 | let unit ?loc ?attrs () = constr ?loc ?attrs "()" [] 52 | let tuple ?loc ?attrs = function 53 | | [] -> unit ?loc ?attrs () 54 | | [x] -> x 55 | | xs -> Exp.tuple ?loc ?attrs xs 56 | let cons ?loc ?attrs hd tl = constr ?loc ?attrs "::" [hd; tl] 57 | let list ?loc ?attrs l = List.fold_right (cons ?loc ?attrs) l (nil ?loc ?attrs ()) 58 | let str ?loc ?attrs s = Exp.constant ?loc ?attrs (Pconst_string (s, None)) 59 | let int ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_integer (string_of_int x, None)) 60 | let int32 ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_integer (Int32.to_string x, Some 'l')) 61 | let int64 ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_integer (Int64.to_string x, Some 'L')) 62 | let char ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_char x) 63 | let float ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_float (string_of_float x, None)) 64 | let record ?loc ?attrs ?over l = 65 | Exp.record ?loc ?attrs (List.map (fun (s, e) -> (lid ~loc:e.pexp_loc s, e)) l) over 66 | let func ?loc ?attrs l = Exp.function_ ?loc ?attrs (List.map (fun (p, e) -> Exp.case p e) l) 67 | let lam ?loc ?attrs ?(label = Label.nolabel) ?default pat exp = Exp.fun_ ?loc ?attrs label default pat exp 68 | let app ?loc ?attrs f l = if l = [] then f else Exp.apply ?loc ?attrs f (List.map (fun a -> Label.nolabel, a) l) 69 | let evar ?loc ?attrs s = Exp.ident ?loc ?attrs (lid ?loc s) 70 | let let_in ?loc ?attrs ?(recursive = false) b body = 71 | Exp.let_ ?loc ?attrs (if recursive then Recursive else Nonrecursive) b body 72 | 73 | let sequence ?loc ?attrs = function 74 | | [] -> unit ?loc ?attrs () 75 | | hd :: tl -> List.fold_left (fun e1 e2 -> Exp.sequence ?loc ?attrs e1 e2) hd tl 76 | 77 | let pvar ?(loc = !default_loc) ?attrs s = Pat.var ~loc ?attrs (mkloc s loc) 78 | let pconstr ?loc ?attrs s args = Pat.construct ?loc ?attrs (lid ?loc s) (may_tuple ?loc Pat.tuple args) 79 | let precord ?loc ?attrs ?(closed = Open) l = 80 | Pat.record ?loc ?attrs (List.map (fun (s, e) -> (lid ~loc:e.ppat_loc s, e)) l) closed 81 | let pnil ?loc ?attrs () = pconstr ?loc ?attrs "[]" [] 82 | let pcons ?loc ?attrs hd tl = pconstr ?loc ?attrs "::" [hd; tl] 83 | let punit ?loc ?attrs () = pconstr ?loc ?attrs "()" [] 84 | let ptuple ?loc ?attrs = function 85 | | [] -> punit ?loc ?attrs () 86 | | [x] -> x 87 | | xs -> Pat.tuple ?loc ?attrs xs 88 | let plist ?loc ?attrs l = List.fold_right (pcons ?loc ?attrs) l (pnil ?loc ?attrs ()) 89 | 90 | let pstr ?loc ?attrs s = Pat.constant ?loc ?attrs (Pconst_string (s, None)) 91 | let pint ?loc ?attrs x = Pat.constant ?loc ?attrs (Pconst_integer (string_of_int x, None)) 92 | let pchar ?loc ?attrs x = Pat.constant ?loc ?attrs (Pconst_char x) 93 | let pfloat ?loc ?attrs x = Pat.constant ?loc ?attrs (Pconst_float (string_of_float x, None)) 94 | 95 | let tconstr ?loc ?attrs c l = Typ.constr ?loc ?attrs (lid ?loc c) l 96 | 97 | let get_str = function 98 | | {pexp_desc=Pexp_constant (Pconst_string (s, _)); _} -> Some s 99 | | _ -> None 100 | 101 | let get_str_with_quotation_delimiter = function 102 | | {pexp_desc=Pexp_constant (Pconst_string (s, d)); _} -> Some (s, d) 103 | | _ -> None 104 | 105 | let get_lid = function 106 | | {pexp_desc=Pexp_ident{txt=id;_};_} -> 107 | Some (String.concat "." (Longident.flatten id)) 108 | | _ -> None 109 | 110 | let find_attr s attrs = 111 | try Some ((List.find (fun {attr_name=x;_} -> x.txt = s) attrs).attr_payload) 112 | with Not_found -> None 113 | 114 | let expr_of_payload = function 115 | | PStr [{pstr_desc=Pstr_eval(e, _); _}] -> Some e 116 | | _ -> None 117 | 118 | let find_attr_expr s attrs = 119 | match find_attr s attrs with 120 | | Some e -> expr_of_payload e 121 | | None -> None 122 | 123 | let has_attr s attrs = 124 | find_attr s attrs <> None 125 | -------------------------------------------------------------------------------- /ast_convenience_408.mli: -------------------------------------------------------------------------------- 1 | open Migrate_parsetree.Ast_408 2 | 3 | (* This file is part of the ppx_tools package. It is released *) 4 | (* under the terms of the MIT license (see LICENSE file). *) 5 | (* Copyright 2013 Alain Frisch and LexiFi *) 6 | 7 | (** {1 Convenience functions to help build and deconstruct AST fragments.} *) 8 | 9 | open Asttypes 10 | open Ast_helper 11 | open Parsetree 12 | 13 | (** {2 Compatibility modules} *) 14 | 15 | module Label : sig 16 | type t = Asttypes.arg_label 17 | 18 | type desc = Asttypes.arg_label = 19 | Nolabel 20 | | Labelled of string 21 | | Optional of string 22 | 23 | val explode : t -> desc 24 | 25 | val nolabel : t 26 | val labelled : string -> t 27 | val optional : string -> t 28 | 29 | end 30 | 31 | (** {2 Provides a unified abstraction over differences in Parsetree.constant and Asttypes.constant 32 | * types defined in ocaml 4.03 and 4.02 respectively}*) 33 | module Constant : sig 34 | type t = Parsetree.constant = 35 | Pconst_integer of string * char option 36 | | Pconst_char of char 37 | | Pconst_string of string * string option 38 | | Pconst_float of string * char option 39 | 40 | (** Convert Asttypes.constant to Constant.t *) 41 | val of_constant : Parsetree.constant -> t 42 | 43 | (** Convert Constant.t to Asttypes.constant *) 44 | val to_constant : t -> Parsetree.constant 45 | 46 | end 47 | 48 | (** {2 Misc} *) 49 | 50 | val lid: ?loc:loc -> string -> lid 51 | 52 | (** {2 Expressions} *) 53 | 54 | val evar: ?loc:loc -> ?attrs:attrs -> string -> expression 55 | val let_in: ?loc:loc -> ?attrs:attrs -> ?recursive:bool -> value_binding list -> expression -> expression 56 | 57 | val constr: ?loc:loc -> ?attrs:attrs -> string -> expression list -> expression 58 | val record: ?loc:loc -> ?attrs:attrs -> ?over:expression -> (string * expression) list -> expression 59 | val tuple: ?loc:loc -> ?attrs:attrs -> expression list -> expression 60 | 61 | val nil: ?loc:loc -> ?attrs:attrs -> unit -> expression 62 | val cons: ?loc:loc -> ?attrs:attrs -> expression -> expression -> expression 63 | val list: ?loc:loc -> ?attrs:attrs -> expression list -> expression 64 | 65 | val unit: ?loc:loc -> ?attrs:attrs -> unit -> expression 66 | 67 | val func: ?loc:loc -> ?attrs:attrs -> (pattern * expression) list -> expression 68 | val lam: ?loc:loc -> ?attrs:attrs -> ?label:Label.t -> ?default:expression -> pattern -> expression -> expression 69 | val app: ?loc:loc -> ?attrs:attrs -> expression -> expression list -> expression 70 | 71 | val str: ?loc:loc -> ?attrs:attrs -> string -> expression 72 | val int: ?loc:loc -> ?attrs:attrs -> int -> expression 73 | val int32: ?loc:loc -> ?attrs:attrs -> int32 -> expression 74 | val int64: ?loc:loc -> ?attrs:attrs -> int64 -> expression 75 | val char: ?loc:loc -> ?attrs:attrs -> char -> expression 76 | val float: ?loc:loc -> ?attrs:attrs -> float -> expression 77 | 78 | val sequence: ?loc:loc -> ?attrs:attrs -> expression list -> expression 79 | (** Return [()] if the list is empty. Tail rec. *) 80 | 81 | (** {2 Patterns} *) 82 | 83 | val pvar: ?loc:loc -> ?attrs:attrs -> string -> pattern 84 | val pconstr: ?loc:loc -> ?attrs:attrs -> string -> pattern list -> pattern 85 | val precord: ?loc:loc -> ?attrs:attrs -> ?closed:closed_flag -> (string * pattern) list -> pattern 86 | val ptuple: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern 87 | 88 | val pnil: ?loc:loc -> ?attrs:attrs -> unit -> pattern 89 | val pcons: ?loc:loc -> ?attrs:attrs -> pattern -> pattern -> pattern 90 | val plist: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern 91 | 92 | val pstr: ?loc:loc -> ?attrs:attrs -> string -> pattern 93 | val pint: ?loc:loc -> ?attrs:attrs -> int -> pattern 94 | val pchar: ?loc:loc -> ?attrs:attrs -> char -> pattern 95 | val pfloat: ?loc:loc -> ?attrs:attrs -> float -> pattern 96 | 97 | val punit: ?loc:loc -> ?attrs:attrs -> unit -> pattern 98 | 99 | 100 | (** {2 Types} *) 101 | 102 | val tconstr: ?loc:loc -> ?attrs:attrs -> string -> core_type list -> core_type 103 | 104 | (** {2 AST deconstruction} *) 105 | 106 | val get_str: expression -> string option 107 | val get_str_with_quotation_delimiter: expression -> (string * string option) option 108 | val get_lid: expression -> string option 109 | 110 | val has_attr: string -> attributes -> bool 111 | val find_attr: string -> attributes -> payload option 112 | val find_attr_expr: string -> attributes -> expression option 113 | -------------------------------------------------------------------------------- /ast_convenience_409.ml: -------------------------------------------------------------------------------- 1 | open Migrate_parsetree.Ast_409 2 | 3 | (* This file is part of the ppx_tools package. It is released *) 4 | (* under the terms of the MIT license (see LICENSE file). *) 5 | (* Copyright 2013 Alain Frisch and LexiFi *) 6 | 7 | open Parsetree 8 | open Asttypes 9 | open Location 10 | open Ast_helper 11 | 12 | 13 | module Label = struct 14 | 15 | type t = Asttypes.arg_label 16 | 17 | type desc = Asttypes.arg_label = 18 | Nolabel 19 | | Labelled of string 20 | | Optional of string 21 | 22 | let explode x = x 23 | 24 | let nolabel = Nolabel 25 | let labelled x = Labelled x 26 | let optional x = Optional x 27 | 28 | end 29 | 30 | module Constant = struct 31 | type t = Parsetree.constant = 32 | Pconst_integer of string * char option 33 | | Pconst_char of char 34 | | Pconst_string of string * string option 35 | | Pconst_float of string * char option 36 | 37 | let of_constant x = x 38 | 39 | let to_constant x = x 40 | 41 | end 42 | 43 | let may_tuple ?loc tup = function 44 | | [] -> None 45 | | [x] -> Some x 46 | | l -> Some (tup ?loc ?attrs:None l) 47 | 48 | let lid ?(loc = !default_loc) s = mkloc (Longident.parse s) loc 49 | let constr ?loc ?attrs s args = Exp.construct ?loc ?attrs (lid ?loc s) (may_tuple ?loc Exp.tuple args) 50 | let nil ?loc ?attrs () = constr ?loc ?attrs "[]" [] 51 | let unit ?loc ?attrs () = constr ?loc ?attrs "()" [] 52 | let tuple ?loc ?attrs = function 53 | | [] -> unit ?loc ?attrs () 54 | | [x] -> x 55 | | xs -> Exp.tuple ?loc ?attrs xs 56 | let cons ?loc ?attrs hd tl = constr ?loc ?attrs "::" [hd; tl] 57 | let list ?loc ?attrs l = List.fold_right (cons ?loc ?attrs) l (nil ?loc ?attrs ()) 58 | let str ?loc ?attrs s = Exp.constant ?loc ?attrs (Pconst_string (s, None)) 59 | let int ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_integer (string_of_int x, None)) 60 | let int32 ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_integer (Int32.to_string x, Some 'l')) 61 | let int64 ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_integer (Int64.to_string x, Some 'L')) 62 | let char ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_char x) 63 | let float ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_float (string_of_float x, None)) 64 | let record ?loc ?attrs ?over l = 65 | Exp.record ?loc ?attrs (List.map (fun (s, e) -> (lid ~loc:e.pexp_loc s, e)) l) over 66 | let func ?loc ?attrs l = Exp.function_ ?loc ?attrs (List.map (fun (p, e) -> Exp.case p e) l) 67 | let lam ?loc ?attrs ?(label = Label.nolabel) ?default pat exp = Exp.fun_ ?loc ?attrs label default pat exp 68 | let app ?loc ?attrs f l = if l = [] then f else Exp.apply ?loc ?attrs f (List.map (fun a -> Label.nolabel, a) l) 69 | let evar ?loc ?attrs s = Exp.ident ?loc ?attrs (lid ?loc s) 70 | let let_in ?loc ?attrs ?(recursive = false) b body = 71 | Exp.let_ ?loc ?attrs (if recursive then Recursive else Nonrecursive) b body 72 | 73 | let sequence ?loc ?attrs = function 74 | | [] -> unit ?loc ?attrs () 75 | | hd :: tl -> List.fold_left (fun e1 e2 -> Exp.sequence ?loc ?attrs e1 e2) hd tl 76 | 77 | let pvar ?(loc = !default_loc) ?attrs s = Pat.var ~loc ?attrs (mkloc s loc) 78 | let pconstr ?loc ?attrs s args = Pat.construct ?loc ?attrs (lid ?loc s) (may_tuple ?loc Pat.tuple args) 79 | let precord ?loc ?attrs ?(closed = Open) l = 80 | Pat.record ?loc ?attrs (List.map (fun (s, e) -> (lid ~loc:e.ppat_loc s, e)) l) closed 81 | let pnil ?loc ?attrs () = pconstr ?loc ?attrs "[]" [] 82 | let pcons ?loc ?attrs hd tl = pconstr ?loc ?attrs "::" [hd; tl] 83 | let punit ?loc ?attrs () = pconstr ?loc ?attrs "()" [] 84 | let ptuple ?loc ?attrs = function 85 | | [] -> punit ?loc ?attrs () 86 | | [x] -> x 87 | | xs -> Pat.tuple ?loc ?attrs xs 88 | let plist ?loc ?attrs l = List.fold_right (pcons ?loc ?attrs) l (pnil ?loc ?attrs ()) 89 | 90 | let pstr ?loc ?attrs s = Pat.constant ?loc ?attrs (Pconst_string (s, None)) 91 | let pint ?loc ?attrs x = Pat.constant ?loc ?attrs (Pconst_integer (string_of_int x, None)) 92 | let pchar ?loc ?attrs x = Pat.constant ?loc ?attrs (Pconst_char x) 93 | let pfloat ?loc ?attrs x = Pat.constant ?loc ?attrs (Pconst_float (string_of_float x, None)) 94 | 95 | let tconstr ?loc ?attrs c l = Typ.constr ?loc ?attrs (lid ?loc c) l 96 | 97 | let get_str = function 98 | | {pexp_desc=Pexp_constant (Pconst_string (s, _)); _} -> Some s 99 | | _ -> None 100 | 101 | let get_str_with_quotation_delimiter = function 102 | | {pexp_desc=Pexp_constant (Pconst_string (s, d)); _} -> Some (s, d) 103 | | _ -> None 104 | 105 | let get_lid = function 106 | | {pexp_desc=Pexp_ident{txt=id;_};_} -> 107 | Some (String.concat "." (Longident.flatten id)) 108 | | _ -> None 109 | 110 | let find_attr s attrs = 111 | try Some ((List.find (fun {attr_name=x;_} -> x.txt = s) attrs).attr_payload) 112 | with Not_found -> None 113 | 114 | let expr_of_payload = function 115 | | PStr [{pstr_desc=Pstr_eval(e, _); _}] -> Some e 116 | | _ -> None 117 | 118 | let find_attr_expr s attrs = 119 | match find_attr s attrs with 120 | | Some e -> expr_of_payload e 121 | | None -> None 122 | 123 | let has_attr s attrs = 124 | find_attr s attrs <> None 125 | -------------------------------------------------------------------------------- /ast_convenience_409.mli: -------------------------------------------------------------------------------- 1 | open Migrate_parsetree.Ast_409 2 | 3 | (* This file is part of the ppx_tools package. It is released *) 4 | (* under the terms of the MIT license (see LICENSE file). *) 5 | (* Copyright 2013 Alain Frisch and LexiFi *) 6 | 7 | (** {1 Convenience functions to help build and deconstruct AST fragments.} *) 8 | 9 | open Asttypes 10 | open Ast_helper 11 | open Parsetree 12 | 13 | (** {2 Compatibility modules} *) 14 | 15 | module Label : sig 16 | type t = Asttypes.arg_label 17 | 18 | type desc = Asttypes.arg_label = 19 | Nolabel 20 | | Labelled of string 21 | | Optional of string 22 | 23 | val explode : t -> desc 24 | 25 | val nolabel : t 26 | val labelled : string -> t 27 | val optional : string -> t 28 | 29 | end 30 | 31 | (** {2 Provides a unified abstraction over differences in Parsetree.constant and Asttypes.constant 32 | * types defined in ocaml 4.03 and 4.02 respectively}*) 33 | module Constant : sig 34 | type t = Parsetree.constant = 35 | Pconst_integer of string * char option 36 | | Pconst_char of char 37 | | Pconst_string of string * string option 38 | | Pconst_float of string * char option 39 | 40 | (** Convert Asttypes.constant to Constant.t *) 41 | val of_constant : Parsetree.constant -> t 42 | 43 | (** Convert Constant.t to Asttypes.constant *) 44 | val to_constant : t -> Parsetree.constant 45 | 46 | end 47 | 48 | (** {2 Misc} *) 49 | 50 | val lid: ?loc:loc -> string -> lid 51 | 52 | (** {2 Expressions} *) 53 | 54 | val evar: ?loc:loc -> ?attrs:attrs -> string -> expression 55 | val let_in: ?loc:loc -> ?attrs:attrs -> ?recursive:bool -> value_binding list -> expression -> expression 56 | 57 | val constr: ?loc:loc -> ?attrs:attrs -> string -> expression list -> expression 58 | val record: ?loc:loc -> ?attrs:attrs -> ?over:expression -> (string * expression) list -> expression 59 | val tuple: ?loc:loc -> ?attrs:attrs -> expression list -> expression 60 | 61 | val nil: ?loc:loc -> ?attrs:attrs -> unit -> expression 62 | val cons: ?loc:loc -> ?attrs:attrs -> expression -> expression -> expression 63 | val list: ?loc:loc -> ?attrs:attrs -> expression list -> expression 64 | 65 | val unit: ?loc:loc -> ?attrs:attrs -> unit -> expression 66 | 67 | val func: ?loc:loc -> ?attrs:attrs -> (pattern * expression) list -> expression 68 | val lam: ?loc:loc -> ?attrs:attrs -> ?label:Label.t -> ?default:expression -> pattern -> expression -> expression 69 | val app: ?loc:loc -> ?attrs:attrs -> expression -> expression list -> expression 70 | 71 | val str: ?loc:loc -> ?attrs:attrs -> string -> expression 72 | val int: ?loc:loc -> ?attrs:attrs -> int -> expression 73 | val int32: ?loc:loc -> ?attrs:attrs -> int32 -> expression 74 | val int64: ?loc:loc -> ?attrs:attrs -> int64 -> expression 75 | val char: ?loc:loc -> ?attrs:attrs -> char -> expression 76 | val float: ?loc:loc -> ?attrs:attrs -> float -> expression 77 | 78 | val sequence: ?loc:loc -> ?attrs:attrs -> expression list -> expression 79 | (** Return [()] if the list is empty. Tail rec. *) 80 | 81 | (** {2 Patterns} *) 82 | 83 | val pvar: ?loc:loc -> ?attrs:attrs -> string -> pattern 84 | val pconstr: ?loc:loc -> ?attrs:attrs -> string -> pattern list -> pattern 85 | val precord: ?loc:loc -> ?attrs:attrs -> ?closed:closed_flag -> (string * pattern) list -> pattern 86 | val ptuple: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern 87 | 88 | val pnil: ?loc:loc -> ?attrs:attrs -> unit -> pattern 89 | val pcons: ?loc:loc -> ?attrs:attrs -> pattern -> pattern -> pattern 90 | val plist: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern 91 | 92 | val pstr: ?loc:loc -> ?attrs:attrs -> string -> pattern 93 | val pint: ?loc:loc -> ?attrs:attrs -> int -> pattern 94 | val pchar: ?loc:loc -> ?attrs:attrs -> char -> pattern 95 | val pfloat: ?loc:loc -> ?attrs:attrs -> float -> pattern 96 | 97 | val punit: ?loc:loc -> ?attrs:attrs -> unit -> pattern 98 | 99 | 100 | (** {2 Types} *) 101 | 102 | val tconstr: ?loc:loc -> ?attrs:attrs -> string -> core_type list -> core_type 103 | 104 | (** {2 AST deconstruction} *) 105 | 106 | val get_str: expression -> string option 107 | val get_str_with_quotation_delimiter: expression -> (string * string option) option 108 | val get_lid: expression -> string option 109 | 110 | val has_attr: string -> attributes -> bool 111 | val find_attr: string -> attributes -> payload option 112 | val find_attr_expr: string -> attributes -> expression option 113 | -------------------------------------------------------------------------------- /ast_convenience_410.ml: -------------------------------------------------------------------------------- 1 | open Migrate_parsetree.Ast_410 2 | 3 | (* This file is part of the ppx_tools package. It is released *) 4 | (* under the terms of the MIT license (see LICENSE file). *) 5 | (* Copyright 2013 Alain Frisch and LexiFi *) 6 | 7 | open Parsetree 8 | open Asttypes 9 | open Location 10 | open Ast_helper 11 | 12 | 13 | module Label = struct 14 | 15 | type t = Asttypes.arg_label 16 | 17 | type desc = Asttypes.arg_label = 18 | Nolabel 19 | | Labelled of string 20 | | Optional of string 21 | 22 | let explode x = x 23 | 24 | let nolabel = Nolabel 25 | let labelled x = Labelled x 26 | let optional x = Optional x 27 | 28 | end 29 | 30 | module Constant = struct 31 | type t = Parsetree.constant = 32 | Pconst_integer of string * char option 33 | | Pconst_char of char 34 | | Pconst_string of string * string option 35 | | Pconst_float of string * char option 36 | 37 | let of_constant x = x 38 | 39 | let to_constant x = x 40 | 41 | end 42 | 43 | let may_tuple ?loc tup = function 44 | | [] -> None 45 | | [x] -> Some x 46 | | l -> Some (tup ?loc ?attrs:None l) 47 | 48 | let lid ?(loc = !default_loc) s = mkloc (Longident.parse s) loc 49 | let constr ?loc ?attrs s args = Exp.construct ?loc ?attrs (lid ?loc s) (may_tuple ?loc Exp.tuple args) 50 | let nil ?loc ?attrs () = constr ?loc ?attrs "[]" [] 51 | let unit ?loc ?attrs () = constr ?loc ?attrs "()" [] 52 | let tuple ?loc ?attrs = function 53 | | [] -> unit ?loc ?attrs () 54 | | [x] -> x 55 | | xs -> Exp.tuple ?loc ?attrs xs 56 | let cons ?loc ?attrs hd tl = constr ?loc ?attrs "::" [hd; tl] 57 | let list ?loc ?attrs l = List.fold_right (cons ?loc ?attrs) l (nil ?loc ?attrs ()) 58 | let str ?loc ?attrs s = Exp.constant ?loc ?attrs (Pconst_string (s, None)) 59 | let int ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_integer (string_of_int x, None)) 60 | let int32 ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_integer (Int32.to_string x, Some 'l')) 61 | let int64 ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_integer (Int64.to_string x, Some 'L')) 62 | let char ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_char x) 63 | let float ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_float (string_of_float x, None)) 64 | let record ?loc ?attrs ?over l = 65 | Exp.record ?loc ?attrs (List.map (fun (s, e) -> (lid ~loc:e.pexp_loc s, e)) l) over 66 | let func ?loc ?attrs l = Exp.function_ ?loc ?attrs (List.map (fun (p, e) -> Exp.case p e) l) 67 | let lam ?loc ?attrs ?(label = Label.nolabel) ?default pat exp = Exp.fun_ ?loc ?attrs label default pat exp 68 | let app ?loc ?attrs f l = if l = [] then f else Exp.apply ?loc ?attrs f (List.map (fun a -> Label.nolabel, a) l) 69 | let evar ?loc ?attrs s = Exp.ident ?loc ?attrs (lid ?loc s) 70 | let let_in ?loc ?attrs ?(recursive = false) b body = 71 | Exp.let_ ?loc ?attrs (if recursive then Recursive else Nonrecursive) b body 72 | 73 | let sequence ?loc ?attrs = function 74 | | [] -> unit ?loc ?attrs () 75 | | hd :: tl -> List.fold_left (fun e1 e2 -> Exp.sequence ?loc ?attrs e1 e2) hd tl 76 | 77 | let pvar ?(loc = !default_loc) ?attrs s = Pat.var ~loc ?attrs (mkloc s loc) 78 | let pconstr ?loc ?attrs s args = Pat.construct ?loc ?attrs (lid ?loc s) (may_tuple ?loc Pat.tuple args) 79 | let precord ?loc ?attrs ?(closed = Open) l = 80 | Pat.record ?loc ?attrs (List.map (fun (s, e) -> (lid ~loc:e.ppat_loc s, e)) l) closed 81 | let pnil ?loc ?attrs () = pconstr ?loc ?attrs "[]" [] 82 | let pcons ?loc ?attrs hd tl = pconstr ?loc ?attrs "::" [hd; tl] 83 | let punit ?loc ?attrs () = pconstr ?loc ?attrs "()" [] 84 | let ptuple ?loc ?attrs = function 85 | | [] -> punit ?loc ?attrs () 86 | | [x] -> x 87 | | xs -> Pat.tuple ?loc ?attrs xs 88 | let plist ?loc ?attrs l = List.fold_right (pcons ?loc ?attrs) l (pnil ?loc ?attrs ()) 89 | 90 | let pstr ?loc ?attrs s = Pat.constant ?loc ?attrs (Pconst_string (s, None)) 91 | let pint ?loc ?attrs x = Pat.constant ?loc ?attrs (Pconst_integer (string_of_int x, None)) 92 | let pchar ?loc ?attrs x = Pat.constant ?loc ?attrs (Pconst_char x) 93 | let pfloat ?loc ?attrs x = Pat.constant ?loc ?attrs (Pconst_float (string_of_float x, None)) 94 | 95 | let tconstr ?loc ?attrs c l = Typ.constr ?loc ?attrs (lid ?loc c) l 96 | 97 | let get_str = function 98 | | {pexp_desc=Pexp_constant (Pconst_string (s, _)); _} -> Some s 99 | | _ -> None 100 | 101 | let get_str_with_quotation_delimiter = function 102 | | {pexp_desc=Pexp_constant (Pconst_string (s, d)); _} -> Some (s, d) 103 | | _ -> None 104 | 105 | let get_lid = function 106 | | {pexp_desc=Pexp_ident{txt=id;_};_} -> 107 | Some (String.concat "." (Longident.flatten id)) 108 | | _ -> None 109 | 110 | let find_attr s attrs = 111 | try Some ((List.find (fun {attr_name=x;_} -> x.txt = s) attrs).attr_payload) 112 | with Not_found -> None 113 | 114 | let expr_of_payload = function 115 | | PStr [{pstr_desc=Pstr_eval(e, _); _}] -> Some e 116 | | _ -> None 117 | 118 | let find_attr_expr s attrs = 119 | match find_attr s attrs with 120 | | Some e -> expr_of_payload e 121 | | None -> None 122 | 123 | let has_attr s attrs = 124 | find_attr s attrs <> None 125 | -------------------------------------------------------------------------------- /ast_convenience_410.mli: -------------------------------------------------------------------------------- 1 | open Migrate_parsetree.Ast_410 2 | 3 | (* This file is part of the ppx_tools package. It is released *) 4 | (* under the terms of the MIT license (see LICENSE file). *) 5 | (* Copyright 2013 Alain Frisch and LexiFi *) 6 | 7 | (** {1 Convenience functions to help build and deconstruct AST fragments.} *) 8 | 9 | open Asttypes 10 | open Ast_helper 11 | open Parsetree 12 | 13 | (** {2 Compatibility modules} *) 14 | 15 | module Label : sig 16 | type t = Asttypes.arg_label 17 | 18 | type desc = Asttypes.arg_label = 19 | Nolabel 20 | | Labelled of string 21 | | Optional of string 22 | 23 | val explode : t -> desc 24 | 25 | val nolabel : t 26 | val labelled : string -> t 27 | val optional : string -> t 28 | 29 | end 30 | 31 | (** {2 Provides a unified abstraction over differences in Parsetree.constant and Asttypes.constant 32 | * types defined in ocaml 4.03 and 4.02 respectively}*) 33 | module Constant : sig 34 | type t = Parsetree.constant = 35 | Pconst_integer of string * char option 36 | | Pconst_char of char 37 | | Pconst_string of string * string option 38 | | Pconst_float of string * char option 39 | 40 | (** Convert Asttypes.constant to Constant.t *) 41 | val of_constant : Parsetree.constant -> t 42 | 43 | (** Convert Constant.t to Asttypes.constant *) 44 | val to_constant : t -> Parsetree.constant 45 | 46 | end 47 | 48 | (** {2 Misc} *) 49 | 50 | val lid: ?loc:loc -> string -> lid 51 | 52 | (** {2 Expressions} *) 53 | 54 | val evar: ?loc:loc -> ?attrs:attrs -> string -> expression 55 | val let_in: ?loc:loc -> ?attrs:attrs -> ?recursive:bool -> value_binding list -> expression -> expression 56 | 57 | val constr: ?loc:loc -> ?attrs:attrs -> string -> expression list -> expression 58 | val record: ?loc:loc -> ?attrs:attrs -> ?over:expression -> (string * expression) list -> expression 59 | val tuple: ?loc:loc -> ?attrs:attrs -> expression list -> expression 60 | 61 | val nil: ?loc:loc -> ?attrs:attrs -> unit -> expression 62 | val cons: ?loc:loc -> ?attrs:attrs -> expression -> expression -> expression 63 | val list: ?loc:loc -> ?attrs:attrs -> expression list -> expression 64 | 65 | val unit: ?loc:loc -> ?attrs:attrs -> unit -> expression 66 | 67 | val func: ?loc:loc -> ?attrs:attrs -> (pattern * expression) list -> expression 68 | val lam: ?loc:loc -> ?attrs:attrs -> ?label:Label.t -> ?default:expression -> pattern -> expression -> expression 69 | val app: ?loc:loc -> ?attrs:attrs -> expression -> expression list -> expression 70 | 71 | val str: ?loc:loc -> ?attrs:attrs -> string -> expression 72 | val int: ?loc:loc -> ?attrs:attrs -> int -> expression 73 | val int32: ?loc:loc -> ?attrs:attrs -> int32 -> expression 74 | val int64: ?loc:loc -> ?attrs:attrs -> int64 -> expression 75 | val char: ?loc:loc -> ?attrs:attrs -> char -> expression 76 | val float: ?loc:loc -> ?attrs:attrs -> float -> expression 77 | 78 | val sequence: ?loc:loc -> ?attrs:attrs -> expression list -> expression 79 | (** Return [()] if the list is empty. Tail rec. *) 80 | 81 | (** {2 Patterns} *) 82 | 83 | val pvar: ?loc:loc -> ?attrs:attrs -> string -> pattern 84 | val pconstr: ?loc:loc -> ?attrs:attrs -> string -> pattern list -> pattern 85 | val precord: ?loc:loc -> ?attrs:attrs -> ?closed:closed_flag -> (string * pattern) list -> pattern 86 | val ptuple: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern 87 | 88 | val pnil: ?loc:loc -> ?attrs:attrs -> unit -> pattern 89 | val pcons: ?loc:loc -> ?attrs:attrs -> pattern -> pattern -> pattern 90 | val plist: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern 91 | 92 | val pstr: ?loc:loc -> ?attrs:attrs -> string -> pattern 93 | val pint: ?loc:loc -> ?attrs:attrs -> int -> pattern 94 | val pchar: ?loc:loc -> ?attrs:attrs -> char -> pattern 95 | val pfloat: ?loc:loc -> ?attrs:attrs -> float -> pattern 96 | 97 | val punit: ?loc:loc -> ?attrs:attrs -> unit -> pattern 98 | 99 | 100 | (** {2 Types} *) 101 | 102 | val tconstr: ?loc:loc -> ?attrs:attrs -> string -> core_type list -> core_type 103 | 104 | (** {2 AST deconstruction} *) 105 | 106 | val get_str: expression -> string option 107 | val get_str_with_quotation_delimiter: expression -> (string * string option) option 108 | val get_lid: expression -> string option 109 | 110 | val has_attr: string -> attributes -> bool 111 | val find_attr: string -> attributes -> payload option 112 | val find_attr_expr: string -> attributes -> expression option 113 | -------------------------------------------------------------------------------- /ast_convenience_411.ml: -------------------------------------------------------------------------------- 1 | open Migrate_parsetree.Ast_411 2 | 3 | (* This file is part of the ppx_tools package. It is released *) 4 | (* under the terms of the MIT license (see LICENSE file). *) 5 | (* Copyright 2013 Alain Frisch and LexiFi *) 6 | 7 | open Parsetree 8 | open Asttypes 9 | open Location 10 | open Ast_helper 11 | 12 | 13 | module Label = struct 14 | 15 | type t = Asttypes.arg_label 16 | 17 | type desc = Asttypes.arg_label = 18 | Nolabel 19 | | Labelled of string 20 | | Optional of string 21 | 22 | let explode x = x 23 | 24 | let nolabel = Nolabel 25 | let labelled x = Labelled x 26 | let optional x = Optional x 27 | 28 | end 29 | 30 | module Constant = struct 31 | type t = Parsetree.constant = 32 | Pconst_integer of string * char option 33 | | Pconst_char of char 34 | | Pconst_string of string * Location.t * string option 35 | | Pconst_float of string * char option 36 | 37 | let of_constant x = x 38 | 39 | let to_constant x = x 40 | 41 | end 42 | 43 | let may_tuple ?loc tup = function 44 | | [] -> None 45 | | [x] -> Some x 46 | | l -> Some (tup ?loc ?attrs:None l) 47 | 48 | let lid ?(loc = !default_loc) s = mkloc (Longident.parse s) loc 49 | let constr ?loc ?attrs s args = Exp.construct ?loc ?attrs (lid ?loc s) (may_tuple ?loc Exp.tuple args) 50 | let nil ?loc ?attrs () = constr ?loc ?attrs "[]" [] 51 | let unit ?loc ?attrs () = constr ?loc ?attrs "()" [] 52 | let tuple ?loc ?attrs = function 53 | | [] -> unit ?loc ?attrs () 54 | | [x] -> x 55 | | xs -> Exp.tuple ?loc ?attrs xs 56 | let cons ?loc ?attrs hd tl = constr ?loc ?attrs "::" [hd; tl] 57 | let list ?loc ?attrs l = List.fold_right (cons ?loc ?attrs) l (nil ?loc ?attrs ()) 58 | let str ?loc ?attrs s = 59 | let inner_loc = 60 | match loc with 61 | | None -> !default_loc 62 | | Some loc -> loc 63 | in 64 | Exp.constant ?loc ?attrs (Pconst_string (s, inner_loc, None)) 65 | let int ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_integer (string_of_int x, None)) 66 | let int32 ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_integer (Int32.to_string x, Some 'l')) 67 | let int64 ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_integer (Int64.to_string x, Some 'L')) 68 | let char ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_char x) 69 | let float ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_float (string_of_float x, None)) 70 | let record ?loc ?attrs ?over l = 71 | Exp.record ?loc ?attrs (List.map (fun (s, e) -> (lid ~loc:e.pexp_loc s, e)) l) over 72 | let func ?loc ?attrs l = Exp.function_ ?loc ?attrs (List.map (fun (p, e) -> Exp.case p e) l) 73 | let lam ?loc ?attrs ?(label = Label.nolabel) ?default pat exp = Exp.fun_ ?loc ?attrs label default pat exp 74 | let app ?loc ?attrs f l = if l = [] then f else Exp.apply ?loc ?attrs f (List.map (fun a -> Label.nolabel, a) l) 75 | let evar ?loc ?attrs s = Exp.ident ?loc ?attrs (lid ?loc s) 76 | let let_in ?loc ?attrs ?(recursive = false) b body = 77 | Exp.let_ ?loc ?attrs (if recursive then Recursive else Nonrecursive) b body 78 | 79 | let sequence ?loc ?attrs = function 80 | | [] -> unit ?loc ?attrs () 81 | | hd :: tl -> List.fold_left (fun e1 e2 -> Exp.sequence ?loc ?attrs e1 e2) hd tl 82 | 83 | let pvar ?(loc = !default_loc) ?attrs s = Pat.var ~loc ?attrs (mkloc s loc) 84 | let pconstr ?loc ?attrs s args = Pat.construct ?loc ?attrs (lid ?loc s) (may_tuple ?loc Pat.tuple args) 85 | let precord ?loc ?attrs ?(closed = Open) l = 86 | Pat.record ?loc ?attrs (List.map (fun (s, e) -> (lid ~loc:e.ppat_loc s, e)) l) closed 87 | let pnil ?loc ?attrs () = pconstr ?loc ?attrs "[]" [] 88 | let pcons ?loc ?attrs hd tl = pconstr ?loc ?attrs "::" [hd; tl] 89 | let punit ?loc ?attrs () = pconstr ?loc ?attrs "()" [] 90 | let ptuple ?loc ?attrs = function 91 | | [] -> punit ?loc ?attrs () 92 | | [x] -> x 93 | | xs -> Pat.tuple ?loc ?attrs xs 94 | let plist ?loc ?attrs l = List.fold_right (pcons ?loc ?attrs) l (pnil ?loc ?attrs ()) 95 | 96 | let pstr ?loc ?attrs s = 97 | let inner_loc = 98 | match loc with 99 | | None -> !default_loc 100 | | Some loc -> loc 101 | in 102 | Pat.constant ?loc ?attrs (Pconst_string (s, inner_loc, None)) 103 | let pint ?loc ?attrs x = Pat.constant ?loc ?attrs (Pconst_integer (string_of_int x, None)) 104 | let pchar ?loc ?attrs x = Pat.constant ?loc ?attrs (Pconst_char x) 105 | let pfloat ?loc ?attrs x = Pat.constant ?loc ?attrs (Pconst_float (string_of_float x, None)) 106 | 107 | let tconstr ?loc ?attrs c l = Typ.constr ?loc ?attrs (lid ?loc c) l 108 | 109 | let get_str = function 110 | | {pexp_desc=Pexp_constant (Pconst_string (s, _, _)); _} -> Some s 111 | | _ -> None 112 | 113 | let get_str_with_quotation_delimiter = function 114 | | {pexp_desc=Pexp_constant (Pconst_string (s, _, d)); _} -> Some (s, d) 115 | | _ -> None 116 | 117 | let get_lid = function 118 | | {pexp_desc=Pexp_ident{txt=id;_};_} -> 119 | Some (String.concat "." (Longident.flatten id)) 120 | | _ -> None 121 | 122 | let find_attr s attrs = 123 | try Some ((List.find (fun {attr_name=x;_} -> x.txt = s) attrs).attr_payload) 124 | with Not_found -> None 125 | 126 | let expr_of_payload = function 127 | | PStr [{pstr_desc=Pstr_eval(e, _); _}] -> Some e 128 | | _ -> None 129 | 130 | let find_attr_expr s attrs = 131 | match find_attr s attrs with 132 | | Some e -> expr_of_payload e 133 | | None -> None 134 | 135 | let has_attr s attrs = 136 | find_attr s attrs <> None 137 | -------------------------------------------------------------------------------- /ast_convenience_411.mli: -------------------------------------------------------------------------------- 1 | open Migrate_parsetree.Ast_411 2 | 3 | (* This file is part of the ppx_tools package. It is released *) 4 | (* under the terms of the MIT license (see LICENSE file). *) 5 | (* Copyright 2013 Alain Frisch and LexiFi *) 6 | 7 | (** {1 Convenience functions to help build and deconstruct AST fragments.} *) 8 | 9 | open Asttypes 10 | open Ast_helper 11 | open Parsetree 12 | 13 | (** {2 Compatibility modules} *) 14 | 15 | module Label : sig 16 | type t = Asttypes.arg_label 17 | 18 | type desc = Asttypes.arg_label = 19 | Nolabel 20 | | Labelled of string 21 | | Optional of string 22 | 23 | val explode : t -> desc 24 | 25 | val nolabel : t 26 | val labelled : string -> t 27 | val optional : string -> t 28 | 29 | end 30 | 31 | (** {2 Provides a unified abstraction over differences in Parsetree.constant and Asttypes.constant 32 | * types defined in ocaml 4.03 and 4.02 respectively}*) 33 | module Constant : sig 34 | type t = Parsetree.constant = 35 | Pconst_integer of string * char option 36 | | Pconst_char of char 37 | | Pconst_string of string * Location.t * string option 38 | | Pconst_float of string * char option 39 | 40 | (** Convert Asttypes.constant to Constant.t *) 41 | val of_constant : Parsetree.constant -> t 42 | 43 | (** Convert Constant.t to Asttypes.constant *) 44 | val to_constant : t -> Parsetree.constant 45 | 46 | end 47 | 48 | (** {2 Misc} *) 49 | 50 | val lid: ?loc:loc -> string -> lid 51 | 52 | (** {2 Expressions} *) 53 | 54 | val evar: ?loc:loc -> ?attrs:attrs -> string -> expression 55 | val let_in: ?loc:loc -> ?attrs:attrs -> ?recursive:bool -> value_binding list -> expression -> expression 56 | 57 | val constr: ?loc:loc -> ?attrs:attrs -> string -> expression list -> expression 58 | val record: ?loc:loc -> ?attrs:attrs -> ?over:expression -> (string * expression) list -> expression 59 | val tuple: ?loc:loc -> ?attrs:attrs -> expression list -> expression 60 | 61 | val nil: ?loc:loc -> ?attrs:attrs -> unit -> expression 62 | val cons: ?loc:loc -> ?attrs:attrs -> expression -> expression -> expression 63 | val list: ?loc:loc -> ?attrs:attrs -> expression list -> expression 64 | 65 | val unit: ?loc:loc -> ?attrs:attrs -> unit -> expression 66 | 67 | val func: ?loc:loc -> ?attrs:attrs -> (pattern * expression) list -> expression 68 | val lam: ?loc:loc -> ?attrs:attrs -> ?label:Label.t -> ?default:expression -> pattern -> expression -> expression 69 | val app: ?loc:loc -> ?attrs:attrs -> expression -> expression list -> expression 70 | 71 | val str: ?loc:loc -> ?attrs:attrs -> string -> expression 72 | val int: ?loc:loc -> ?attrs:attrs -> int -> expression 73 | val int32: ?loc:loc -> ?attrs:attrs -> int32 -> expression 74 | val int64: ?loc:loc -> ?attrs:attrs -> int64 -> expression 75 | val char: ?loc:loc -> ?attrs:attrs -> char -> expression 76 | val float: ?loc:loc -> ?attrs:attrs -> float -> expression 77 | 78 | val sequence: ?loc:loc -> ?attrs:attrs -> expression list -> expression 79 | (** Return [()] if the list is empty. Tail rec. *) 80 | 81 | (** {2 Patterns} *) 82 | 83 | val pvar: ?loc:loc -> ?attrs:attrs -> string -> pattern 84 | val pconstr: ?loc:loc -> ?attrs:attrs -> string -> pattern list -> pattern 85 | val precord: ?loc:loc -> ?attrs:attrs -> ?closed:closed_flag -> (string * pattern) list -> pattern 86 | val ptuple: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern 87 | 88 | val pnil: ?loc:loc -> ?attrs:attrs -> unit -> pattern 89 | val pcons: ?loc:loc -> ?attrs:attrs -> pattern -> pattern -> pattern 90 | val plist: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern 91 | 92 | val pstr: ?loc:loc -> ?attrs:attrs -> string -> pattern 93 | val pint: ?loc:loc -> ?attrs:attrs -> int -> pattern 94 | val pchar: ?loc:loc -> ?attrs:attrs -> char -> pattern 95 | val pfloat: ?loc:loc -> ?attrs:attrs -> float -> pattern 96 | 97 | val punit: ?loc:loc -> ?attrs:attrs -> unit -> pattern 98 | 99 | 100 | (** {2 Types} *) 101 | 102 | val tconstr: ?loc:loc -> ?attrs:attrs -> string -> core_type list -> core_type 103 | 104 | (** {2 AST deconstruction} *) 105 | 106 | val get_str: expression -> string option 107 | val get_str_with_quotation_delimiter: expression -> (string * string option) option 108 | val get_lid: expression -> string option 109 | 110 | val has_attr: string -> attributes -> bool 111 | val find_attr: string -> attributes -> payload option 112 | val find_attr_expr: string -> attributes -> expression option 113 | -------------------------------------------------------------------------------- /ast_mapper_class_402.mli: -------------------------------------------------------------------------------- 1 | open Migrate_parsetree.Ast_402 2 | 3 | (* This file is part of the ppx_tools package. It is released *) 4 | (* under the terms of the MIT license (see LICENSE file). *) 5 | (* Copyright 2013 Alain Frisch and LexiFi *) 6 | 7 | (** Class-based customizable mapper *) 8 | 9 | open Parsetree 10 | 11 | class mapper: 12 | object 13 | method attribute: attribute -> attribute 14 | method attributes: attribute list -> attribute list 15 | method case: case -> case 16 | method cases: case list -> case list 17 | method class_declaration: class_declaration -> class_declaration 18 | method class_description: class_description -> class_description 19 | method class_expr: class_expr -> class_expr 20 | method class_field: class_field -> class_field 21 | method class_signature: class_signature -> class_signature 22 | method class_structure: class_structure -> class_structure 23 | method class_type: class_type -> class_type 24 | method class_type_declaration: class_type_declaration -> class_type_declaration 25 | method class_type_field: class_type_field -> class_type_field 26 | method constructor_declaration: constructor_declaration -> constructor_declaration 27 | method expr: expression -> expression 28 | method extension: extension -> extension 29 | method extension_constructor: extension_constructor -> extension_constructor 30 | method include_declaration: include_declaration -> include_declaration 31 | method include_description: include_description -> include_description 32 | method label_declaration: label_declaration -> label_declaration 33 | method location: Location.t -> Location.t 34 | method module_binding: module_binding -> module_binding 35 | method module_declaration: module_declaration -> module_declaration 36 | method module_expr: module_expr -> module_expr 37 | method module_type: module_type -> module_type 38 | method module_type_declaration: module_type_declaration -> module_type_declaration 39 | method open_description: open_description -> open_description 40 | method pat: pattern -> pattern 41 | method payload: payload -> payload 42 | method signature: signature -> signature 43 | method signature_item: signature_item -> signature_item 44 | method structure: structure -> structure 45 | method structure_item: structure_item -> structure_item 46 | method typ: core_type -> core_type 47 | method type_declaration: type_declaration -> type_declaration 48 | method type_extension: type_extension -> type_extension 49 | method type_kind: type_kind -> type_kind 50 | method value_binding: value_binding -> value_binding 51 | method value_description: value_description -> value_description 52 | method with_constraint: with_constraint -> with_constraint 53 | end 54 | 55 | val to_mapper: #mapper -> Ast_mapper.mapper 56 | (** The resulting mapper is "closed", i.e. methods ignore 57 | their first argument. *) 58 | -------------------------------------------------------------------------------- /ast_mapper_class_403.mli: -------------------------------------------------------------------------------- 1 | open Migrate_parsetree.Ast_403 2 | 3 | (* This file is part of the ppx_tools package. It is released *) 4 | (* under the terms of the MIT license (see LICENSE file). *) 5 | (* Copyright 2013 Alain Frisch and LexiFi *) 6 | 7 | (** Class-based customizable mapper *) 8 | 9 | open Parsetree 10 | 11 | class mapper: 12 | object 13 | method attribute: attribute -> attribute 14 | method attributes: attribute list -> attribute list 15 | method case: case -> case 16 | method cases: case list -> case list 17 | method class_declaration: class_declaration -> class_declaration 18 | method class_description: class_description -> class_description 19 | method class_expr: class_expr -> class_expr 20 | method class_field: class_field -> class_field 21 | method class_signature: class_signature -> class_signature 22 | method class_structure: class_structure -> class_structure 23 | method class_type: class_type -> class_type 24 | method class_type_declaration: class_type_declaration -> class_type_declaration 25 | method class_type_field: class_type_field -> class_type_field 26 | method constructor_arguments: constructor_arguments -> constructor_arguments 27 | method constructor_declaration: constructor_declaration -> constructor_declaration 28 | method expr: expression -> expression 29 | method extension: extension -> extension 30 | method extension_constructor: extension_constructor -> extension_constructor 31 | method include_declaration: include_declaration -> include_declaration 32 | method include_description: include_description -> include_description 33 | method label_declaration: label_declaration -> label_declaration 34 | method location: Location.t -> Location.t 35 | method module_binding: module_binding -> module_binding 36 | method module_declaration: module_declaration -> module_declaration 37 | method module_expr: module_expr -> module_expr 38 | method module_type: module_type -> module_type 39 | method module_type_declaration: module_type_declaration -> module_type_declaration 40 | method open_description: open_description -> open_description 41 | method pat: pattern -> pattern 42 | method payload: payload -> payload 43 | method signature: signature -> signature 44 | method signature_item: signature_item -> signature_item 45 | method structure: structure -> structure 46 | method structure_item: structure_item -> structure_item 47 | method typ: core_type -> core_type 48 | method type_declaration: type_declaration -> type_declaration 49 | method type_extension: type_extension -> type_extension 50 | method type_kind: type_kind -> type_kind 51 | method value_binding: value_binding -> value_binding 52 | method value_description: value_description -> value_description 53 | method with_constraint: with_constraint -> with_constraint 54 | end 55 | 56 | val to_mapper: #mapper -> Ast_mapper.mapper 57 | (** The resulting mapper is "closed", i.e. methods ignore 58 | their first argument. *) 59 | -------------------------------------------------------------------------------- /ast_mapper_class_404.mli: -------------------------------------------------------------------------------- 1 | open Migrate_parsetree.Ast_404 2 | 3 | (* This file is part of the ppx_tools package. It is released *) 4 | (* under the terms of the MIT license (see LICENSE file). *) 5 | (* Copyright 2013 Alain Frisch and LexiFi *) 6 | 7 | (** Class-based customizable mapper *) 8 | 9 | open Parsetree 10 | 11 | class mapper: 12 | object 13 | method attribute: attribute -> attribute 14 | method attributes: attribute list -> attribute list 15 | method case: case -> case 16 | method cases: case list -> case list 17 | method class_declaration: class_declaration -> class_declaration 18 | method class_description: class_description -> class_description 19 | method class_expr: class_expr -> class_expr 20 | method class_field: class_field -> class_field 21 | method class_signature: class_signature -> class_signature 22 | method class_structure: class_structure -> class_structure 23 | method class_type: class_type -> class_type 24 | method class_type_declaration: class_type_declaration -> class_type_declaration 25 | method class_type_field: class_type_field -> class_type_field 26 | method constructor_arguments: constructor_arguments -> constructor_arguments 27 | method constructor_declaration: constructor_declaration -> constructor_declaration 28 | method expr: expression -> expression 29 | method extension: extension -> extension 30 | method extension_constructor: extension_constructor -> extension_constructor 31 | method include_declaration: include_declaration -> include_declaration 32 | method include_description: include_description -> include_description 33 | method label_declaration: label_declaration -> label_declaration 34 | method location: Location.t -> Location.t 35 | method module_binding: module_binding -> module_binding 36 | method module_declaration: module_declaration -> module_declaration 37 | method module_expr: module_expr -> module_expr 38 | method module_type: module_type -> module_type 39 | method module_type_declaration: module_type_declaration -> module_type_declaration 40 | method open_description: open_description -> open_description 41 | method pat: pattern -> pattern 42 | method payload: payload -> payload 43 | method signature: signature -> signature 44 | method signature_item: signature_item -> signature_item 45 | method structure: structure -> structure 46 | method structure_item: structure_item -> structure_item 47 | method typ: core_type -> core_type 48 | method type_declaration: type_declaration -> type_declaration 49 | method type_extension: type_extension -> type_extension 50 | method type_kind: type_kind -> type_kind 51 | method value_binding: value_binding -> value_binding 52 | method value_description: value_description -> value_description 53 | method with_constraint: with_constraint -> with_constraint 54 | end 55 | 56 | val to_mapper: #mapper -> Ast_mapper.mapper 57 | (** The resulting mapper is "closed", i.e. methods ignore 58 | their first argument. *) 59 | -------------------------------------------------------------------------------- /ast_mapper_class_405.mli: -------------------------------------------------------------------------------- 1 | open Migrate_parsetree.Ast_405 2 | 3 | (* This file is part of the ppx_tools package. It is released *) 4 | (* under the terms of the MIT license (see LICENSE file). *) 5 | (* Copyright 2013 Alain Frisch and LexiFi *) 6 | 7 | (** Class-based customizable mapper *) 8 | 9 | open Parsetree 10 | 11 | class mapper: 12 | object 13 | method attribute: attribute -> attribute 14 | method attributes: attribute list -> attribute list 15 | method case: case -> case 16 | method cases: case list -> case list 17 | method class_declaration: class_declaration -> class_declaration 18 | method class_description: class_description -> class_description 19 | method class_expr: class_expr -> class_expr 20 | method class_field: class_field -> class_field 21 | method class_signature: class_signature -> class_signature 22 | method class_structure: class_structure -> class_structure 23 | method class_type: class_type -> class_type 24 | method class_type_declaration: class_type_declaration -> class_type_declaration 25 | method class_type_field: class_type_field -> class_type_field 26 | method constructor_arguments: constructor_arguments -> constructor_arguments 27 | method constructor_declaration: constructor_declaration -> constructor_declaration 28 | method expr: expression -> expression 29 | method extension: extension -> extension 30 | method extension_constructor: extension_constructor -> extension_constructor 31 | method include_declaration: include_declaration -> include_declaration 32 | method include_description: include_description -> include_description 33 | method label_declaration: label_declaration -> label_declaration 34 | method location: Location.t -> Location.t 35 | method module_binding: module_binding -> module_binding 36 | method module_declaration: module_declaration -> module_declaration 37 | method module_expr: module_expr -> module_expr 38 | method module_type: module_type -> module_type 39 | method module_type_declaration: module_type_declaration -> module_type_declaration 40 | method open_description: open_description -> open_description 41 | method pat: pattern -> pattern 42 | method payload: payload -> payload 43 | method signature: signature -> signature 44 | method signature_item: signature_item -> signature_item 45 | method structure: structure -> structure 46 | method structure_item: structure_item -> structure_item 47 | method typ: core_type -> core_type 48 | method type_declaration: type_declaration -> type_declaration 49 | method type_extension: type_extension -> type_extension 50 | method type_kind: type_kind -> type_kind 51 | method value_binding: value_binding -> value_binding 52 | method value_description: value_description -> value_description 53 | method with_constraint: with_constraint -> with_constraint 54 | end 55 | 56 | val to_mapper: #mapper -> Ast_mapper.mapper 57 | (** The resulting mapper is "closed", i.e. methods ignore 58 | their first argument. *) 59 | -------------------------------------------------------------------------------- /ast_mapper_class_406.mli: -------------------------------------------------------------------------------- 1 | open Migrate_parsetree.Ast_406 2 | 3 | (* This file is part of the ppx_tools package. It is released *) 4 | (* under the terms of the MIT license (see LICENSE file). *) 5 | (* Copyright 2013 Alain Frisch and LexiFi *) 6 | 7 | (** Class-based customizable mapper *) 8 | 9 | open Parsetree 10 | 11 | class mapper: 12 | object 13 | method attribute: attribute -> attribute 14 | method attributes: attribute list -> attribute list 15 | method case: case -> case 16 | method cases: case list -> case list 17 | method class_declaration: class_declaration -> class_declaration 18 | method class_description: class_description -> class_description 19 | method class_expr: class_expr -> class_expr 20 | method class_field: class_field -> class_field 21 | method class_signature: class_signature -> class_signature 22 | method class_structure: class_structure -> class_structure 23 | method class_type: class_type -> class_type 24 | method class_type_declaration: class_type_declaration -> class_type_declaration 25 | method class_type_field: class_type_field -> class_type_field 26 | method constructor_arguments: constructor_arguments -> constructor_arguments 27 | method constructor_declaration: constructor_declaration -> constructor_declaration 28 | method expr: expression -> expression 29 | method extension: extension -> extension 30 | method extension_constructor: extension_constructor -> extension_constructor 31 | method include_declaration: include_declaration -> include_declaration 32 | method include_description: include_description -> include_description 33 | method label_declaration: label_declaration -> label_declaration 34 | method location: Location.t -> Location.t 35 | method module_binding: module_binding -> module_binding 36 | method module_declaration: module_declaration -> module_declaration 37 | method module_expr: module_expr -> module_expr 38 | method module_type: module_type -> module_type 39 | method module_type_declaration: module_type_declaration -> module_type_declaration 40 | method open_description: open_description -> open_description 41 | method pat: pattern -> pattern 42 | method payload: payload -> payload 43 | method signature: signature -> signature 44 | method signature_item: signature_item -> signature_item 45 | method structure: structure -> structure 46 | method structure_item: structure_item -> structure_item 47 | method typ: core_type -> core_type 48 | method type_declaration: type_declaration -> type_declaration 49 | method type_extension: type_extension -> type_extension 50 | method type_kind: type_kind -> type_kind 51 | method value_binding: value_binding -> value_binding 52 | method value_description: value_description -> value_description 53 | method with_constraint: with_constraint -> with_constraint 54 | end 55 | 56 | val to_mapper: #mapper -> Ast_mapper.mapper 57 | (** The resulting mapper is "closed", i.e. methods ignore 58 | their first argument. *) 59 | -------------------------------------------------------------------------------- /ast_mapper_class_407.mli: -------------------------------------------------------------------------------- 1 | open Migrate_parsetree.Ast_407 2 | 3 | (* This file is part of the ppx_tools package. It is released *) 4 | (* under the terms of the MIT license (see LICENSE file). *) 5 | (* Copyright 2013 Alain Frisch and LexiFi *) 6 | 7 | (** Class-based customizable mapper *) 8 | 9 | open Parsetree 10 | 11 | class mapper: 12 | object 13 | method attribute: attribute -> attribute 14 | method attributes: attribute list -> attribute list 15 | method case: case -> case 16 | method cases: case list -> case list 17 | method class_declaration: class_declaration -> class_declaration 18 | method class_description: class_description -> class_description 19 | method class_expr: class_expr -> class_expr 20 | method class_field: class_field -> class_field 21 | method class_signature: class_signature -> class_signature 22 | method class_structure: class_structure -> class_structure 23 | method class_type: class_type -> class_type 24 | method class_type_declaration: class_type_declaration -> class_type_declaration 25 | method class_type_field: class_type_field -> class_type_field 26 | method constructor_arguments: constructor_arguments -> constructor_arguments 27 | method constructor_declaration: constructor_declaration -> constructor_declaration 28 | method expr: expression -> expression 29 | method extension: extension -> extension 30 | method extension_constructor: extension_constructor -> extension_constructor 31 | method include_declaration: include_declaration -> include_declaration 32 | method include_description: include_description -> include_description 33 | method label_declaration: label_declaration -> label_declaration 34 | method location: Location.t -> Location.t 35 | method module_binding: module_binding -> module_binding 36 | method module_declaration: module_declaration -> module_declaration 37 | method module_expr: module_expr -> module_expr 38 | method module_type: module_type -> module_type 39 | method module_type_declaration: module_type_declaration -> module_type_declaration 40 | method open_description: open_description -> open_description 41 | method pat: pattern -> pattern 42 | method payload: payload -> payload 43 | method signature: signature -> signature 44 | method signature_item: signature_item -> signature_item 45 | method structure: structure -> structure 46 | method structure_item: structure_item -> structure_item 47 | method typ: core_type -> core_type 48 | method type_declaration: type_declaration -> type_declaration 49 | method type_extension: type_extension -> type_extension 50 | method type_kind: type_kind -> type_kind 51 | method value_binding: value_binding -> value_binding 52 | method value_description: value_description -> value_description 53 | method with_constraint: with_constraint -> with_constraint 54 | end 55 | 56 | val to_mapper: #mapper -> Ast_mapper.mapper 57 | (** The resulting mapper is "closed", i.e. methods ignore 58 | their first argument. *) 59 | -------------------------------------------------------------------------------- /ast_mapper_class_408.mli: -------------------------------------------------------------------------------- 1 | open Migrate_parsetree.Ast_408 2 | 3 | (* This file is part of the ppx_tools package. It is released *) 4 | (* under the terms of the MIT license (see LICENSE file). *) 5 | (* Copyright 2013 Alain Frisch and LexiFi *) 6 | 7 | (** Class-based customizable mapper *) 8 | 9 | open Parsetree 10 | 11 | class mapper: 12 | object 13 | method attribute: attribute -> attribute 14 | method attributes: attribute list -> attribute list 15 | method binding_op: binding_op -> binding_op 16 | method case: case -> case 17 | method cases: case list -> case list 18 | method class_declaration: class_declaration -> class_declaration 19 | method class_description: class_description -> class_description 20 | method class_expr: class_expr -> class_expr 21 | method class_field: class_field -> class_field 22 | method class_signature: class_signature -> class_signature 23 | method class_structure: class_structure -> class_structure 24 | method class_type: class_type -> class_type 25 | method class_type_declaration: class_type_declaration -> class_type_declaration 26 | method class_type_field: class_type_field -> class_type_field 27 | method constructor_arguments: constructor_arguments -> constructor_arguments 28 | method constructor_declaration: constructor_declaration -> constructor_declaration 29 | method expr: expression -> expression 30 | method extension: extension -> extension 31 | method extension_constructor: extension_constructor -> extension_constructor 32 | method include_declaration: include_declaration -> include_declaration 33 | method include_description: include_description -> include_description 34 | method label_declaration: label_declaration -> label_declaration 35 | method location: Location.t -> Location.t 36 | method module_binding: module_binding -> module_binding 37 | method module_declaration: module_declaration -> module_declaration 38 | method module_substitution: module_substitution -> module_substitution 39 | method module_expr: module_expr -> module_expr 40 | method module_type: module_type -> module_type 41 | method module_type_declaration: module_type_declaration -> module_type_declaration 42 | method open_declaration: open_declaration -> open_declaration 43 | method open_description: open_description -> open_description 44 | method pat: pattern -> pattern 45 | method payload: payload -> payload 46 | method signature: signature -> signature 47 | method signature_item: signature_item -> signature_item 48 | method structure: structure -> structure 49 | method structure_item: structure_item -> structure_item 50 | method typ: core_type -> core_type 51 | method type_declaration: type_declaration -> type_declaration 52 | method type_exception: type_exception -> type_exception 53 | method type_extension: type_extension -> type_extension 54 | method type_kind: type_kind -> type_kind 55 | method value_binding: value_binding -> value_binding 56 | method value_description: value_description -> value_description 57 | method with_constraint: with_constraint -> with_constraint 58 | end 59 | 60 | val to_mapper: #mapper -> Ast_mapper.mapper 61 | (** The resulting mapper is "closed", i.e. methods ignore 62 | their first argument. *) 63 | -------------------------------------------------------------------------------- /ast_mapper_class_409.mli: -------------------------------------------------------------------------------- 1 | open Migrate_parsetree.Ast_409 2 | 3 | (* This file is part of the ppx_tools package. It is released *) 4 | (* under the terms of the MIT license (see LICENSE file). *) 5 | (* Copyright 2013 Alain Frisch and LexiFi *) 6 | 7 | (** Class-based customizable mapper *) 8 | 9 | open Parsetree 10 | 11 | class mapper: 12 | object 13 | method attribute: attribute -> attribute 14 | method attributes: attribute list -> attribute list 15 | method binding_op: binding_op -> binding_op 16 | method case: case -> case 17 | method cases: case list -> case list 18 | method class_declaration: class_declaration -> class_declaration 19 | method class_description: class_description -> class_description 20 | method class_expr: class_expr -> class_expr 21 | method class_field: class_field -> class_field 22 | method class_signature: class_signature -> class_signature 23 | method class_structure: class_structure -> class_structure 24 | method class_type: class_type -> class_type 25 | method class_type_declaration: class_type_declaration -> class_type_declaration 26 | method class_type_field: class_type_field -> class_type_field 27 | method constructor_arguments: constructor_arguments -> constructor_arguments 28 | method constructor_declaration: constructor_declaration -> constructor_declaration 29 | method expr: expression -> expression 30 | method extension: extension -> extension 31 | method extension_constructor: extension_constructor -> extension_constructor 32 | method include_declaration: include_declaration -> include_declaration 33 | method include_description: include_description -> include_description 34 | method label_declaration: label_declaration -> label_declaration 35 | method location: Location.t -> Location.t 36 | method module_binding: module_binding -> module_binding 37 | method module_declaration: module_declaration -> module_declaration 38 | method module_substitution: module_substitution -> module_substitution 39 | method module_expr: module_expr -> module_expr 40 | method module_type: module_type -> module_type 41 | method module_type_declaration: module_type_declaration -> module_type_declaration 42 | method open_declaration: open_declaration -> open_declaration 43 | method open_description: open_description -> open_description 44 | method pat: pattern -> pattern 45 | method payload: payload -> payload 46 | method signature: signature -> signature 47 | method signature_item: signature_item -> signature_item 48 | method structure: structure -> structure 49 | method structure_item: structure_item -> structure_item 50 | method typ: core_type -> core_type 51 | method type_declaration: type_declaration -> type_declaration 52 | method type_exception: type_exception -> type_exception 53 | method type_extension: type_extension -> type_extension 54 | method type_kind: type_kind -> type_kind 55 | method value_binding: value_binding -> value_binding 56 | method value_description: value_description -> value_description 57 | method with_constraint: with_constraint -> with_constraint 58 | end 59 | 60 | val to_mapper: #mapper -> Ast_mapper.mapper 61 | (** The resulting mapper is "closed", i.e. methods ignore 62 | their first argument. *) 63 | -------------------------------------------------------------------------------- /ast_mapper_class_410.mli: -------------------------------------------------------------------------------- 1 | open Migrate_parsetree.Ast_410 2 | 3 | (* This file is part of the ppx_tools package. It is released *) 4 | (* under the terms of the MIT license (see LICENSE file). *) 5 | (* Copyright 2013 Alain Frisch and LexiFi *) 6 | 7 | (** Class-based customizable mapper *) 8 | 9 | open Parsetree 10 | 11 | class mapper: 12 | object 13 | method attribute: attribute -> attribute 14 | method attributes: attribute list -> attribute list 15 | method binding_op: binding_op -> binding_op 16 | method case: case -> case 17 | method cases: case list -> case list 18 | method class_declaration: class_declaration -> class_declaration 19 | method class_description: class_description -> class_description 20 | method class_expr: class_expr -> class_expr 21 | method class_field: class_field -> class_field 22 | method class_signature: class_signature -> class_signature 23 | method class_structure: class_structure -> class_structure 24 | method class_type: class_type -> class_type 25 | method class_type_declaration: class_type_declaration -> class_type_declaration 26 | method class_type_field: class_type_field -> class_type_field 27 | method constructor_arguments: constructor_arguments -> constructor_arguments 28 | method constructor_declaration: constructor_declaration -> constructor_declaration 29 | method expr: expression -> expression 30 | method extension: extension -> extension 31 | method extension_constructor: extension_constructor -> extension_constructor 32 | method include_declaration: include_declaration -> include_declaration 33 | method include_description: include_description -> include_description 34 | method label_declaration: label_declaration -> label_declaration 35 | method location: Location.t -> Location.t 36 | method module_binding: module_binding -> module_binding 37 | method module_declaration: module_declaration -> module_declaration 38 | method module_substitution: module_substitution -> module_substitution 39 | method module_expr: module_expr -> module_expr 40 | method module_type: module_type -> module_type 41 | method module_type_declaration: module_type_declaration -> module_type_declaration 42 | method open_declaration: open_declaration -> open_declaration 43 | method open_description: open_description -> open_description 44 | method pat: pattern -> pattern 45 | method payload: payload -> payload 46 | method signature: signature -> signature 47 | method signature_item: signature_item -> signature_item 48 | method structure: structure -> structure 49 | method structure_item: structure_item -> structure_item 50 | method typ: core_type -> core_type 51 | method type_declaration: type_declaration -> type_declaration 52 | method type_exception: type_exception -> type_exception 53 | method type_extension: type_extension -> type_extension 54 | method type_kind: type_kind -> type_kind 55 | method value_binding: value_binding -> value_binding 56 | method value_description: value_description -> value_description 57 | method with_constraint: with_constraint -> with_constraint 58 | end 59 | 60 | val to_mapper: #mapper -> Ast_mapper.mapper 61 | (** The resulting mapper is "closed", i.e. methods ignore 62 | their first argument. *) 63 | -------------------------------------------------------------------------------- /ast_mapper_class_411.mli: -------------------------------------------------------------------------------- 1 | open Migrate_parsetree.Ast_411 2 | 3 | (* This file is part of the ppx_tools package. It is released *) 4 | (* under the terms of the MIT license (see LICENSE file). *) 5 | (* Copyright 2013 Alain Frisch and LexiFi *) 6 | 7 | (** Class-based customizable mapper *) 8 | 9 | open Parsetree 10 | 11 | class mapper: 12 | object 13 | method attribute: attribute -> attribute 14 | method attributes: attribute list -> attribute list 15 | method binding_op: binding_op -> binding_op 16 | method case: case -> case 17 | method cases: case list -> case list 18 | method class_declaration: class_declaration -> class_declaration 19 | method class_description: class_description -> class_description 20 | method class_expr: class_expr -> class_expr 21 | method class_field: class_field -> class_field 22 | method class_signature: class_signature -> class_signature 23 | method class_structure: class_structure -> class_structure 24 | method class_type: class_type -> class_type 25 | method class_type_declaration: class_type_declaration -> class_type_declaration 26 | method class_type_field: class_type_field -> class_type_field 27 | method constant: constant -> constant 28 | method constructor_arguments: constructor_arguments -> constructor_arguments 29 | method constructor_declaration: constructor_declaration -> constructor_declaration 30 | method expr: expression -> expression 31 | method extension: extension -> extension 32 | method extension_constructor: extension_constructor -> extension_constructor 33 | method include_declaration: include_declaration -> include_declaration 34 | method include_description: include_description -> include_description 35 | method label_declaration: label_declaration -> label_declaration 36 | method location: Location.t -> Location.t 37 | method module_binding: module_binding -> module_binding 38 | method module_declaration: module_declaration -> module_declaration 39 | method module_substitution: module_substitution -> module_substitution 40 | method module_expr: module_expr -> module_expr 41 | method module_type: module_type -> module_type 42 | method module_type_declaration: module_type_declaration -> module_type_declaration 43 | method open_declaration: open_declaration -> open_declaration 44 | method open_description: open_description -> open_description 45 | method pat: pattern -> pattern 46 | method payload: payload -> payload 47 | method signature: signature -> signature 48 | method signature_item: signature_item -> signature_item 49 | method structure: structure -> structure 50 | method structure_item: structure_item -> structure_item 51 | method typ: core_type -> core_type 52 | method type_declaration: type_declaration -> type_declaration 53 | method type_exception: type_exception -> type_exception 54 | method type_extension: type_extension -> type_extension 55 | method type_kind: type_kind -> type_kind 56 | method value_binding: value_binding -> value_binding 57 | method value_description: value_description -> value_description 58 | method with_constraint: with_constraint -> with_constraint 59 | end 60 | 61 | val to_mapper: #mapper -> Ast_mapper.mapper 62 | (** The resulting mapper is "closed", i.e. methods ignore 63 | their first argument. *) 64 | -------------------------------------------------------------------------------- /dune: -------------------------------------------------------------------------------- 1 | (rule 2 | (with-stdout-to 3 | dune.inc.gen 4 | (run ocaml %{dep:gen/update_dune.ml}))) 5 | 6 | (alias 7 | (name runtest) 8 | (action 9 | (diff dune.inc dune.inc.gen))) 10 | 11 | (include dune.inc) 12 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 1.0) 2 | (name ppx_tools_versioned) 3 | -------------------------------------------------------------------------------- /dune-workspace.dev: -------------------------------------------------------------------------------- 1 | (lang dune 1.0) 2 | (context (opam (switch 4.02.3))) 3 | (context (opam (switch 4.03.0))) 4 | (context (opam (switch 4.04.2))) 5 | (context (opam (switch 4.05.0))) 6 | (context (opam (switch 4.06.1))) 7 | (context (opam (switch 4.07.1))) 8 | (context (opam (switch 4.08.0))) 9 | (context (opam (switch ocaml-variants.4.09.0+beta1))) 10 | -------------------------------------------------------------------------------- /dune.inc: -------------------------------------------------------------------------------- 1 | 2 | (library 3 | (name ppx_tools_versioned) 4 | (public_name ppx_tools_versioned) 5 | (synopsis "Tools for authors of ppx rewriters and other syntactic tools (with ocaml-migrate-parsetree support)") 6 | (libraries ocaml-migrate-parsetree) 7 | (flags (:standard -w +A-4-17-44-45-105-42 -safe-string)) 8 | (wrapped false) 9 | (modules ast_convenience_402 ast_mapper_class_402 ast_lifter_402 ppx_tools_402 10 | ast_convenience_403 ast_mapper_class_403 ast_lifter_403 ppx_tools_403 11 | ast_convenience_404 ast_mapper_class_404 ast_lifter_404 ppx_tools_404 12 | ast_convenience_405 ast_mapper_class_405 ast_lifter_405 ppx_tools_405 13 | ast_convenience_406 ast_mapper_class_406 ast_lifter_406 ppx_tools_406 14 | ast_convenience_407 ast_mapper_class_407 ast_lifter_407 ppx_tools_407 15 | ast_convenience_408 ast_mapper_class_408 ast_lifter_408 ppx_tools_408 16 | ast_convenience_409 ast_mapper_class_409 ast_lifter_409 ppx_tools_409 17 | ast_convenience_410 ast_mapper_class_410 ast_lifter_410 ppx_tools_410 18 | ast_convenience_411 ast_mapper_class_411 ast_lifter_411 ppx_tools_411)) 19 | 20 | (library 21 | (name ppx_tools_versioned_metaquot_402) 22 | (public_name ppx_tools_versioned.metaquot_402) 23 | (synopsis "Meta-quotation: 4.02 parsetree quotation") 24 | (libraries ocaml-migrate-parsetree ppx_tools_versioned) 25 | (kind ppx_rewriter) 26 | (wrapped false) 27 | (modules ppx_metaquot_402) 28 | (flags (:standard -w +A-4-17-44-45-105-42 -safe-string))) 29 | 30 | (library 31 | (name ppx_tools_versioned_metaquot_403) 32 | (public_name ppx_tools_versioned.metaquot_403) 33 | (synopsis "Meta-quotation: 4.03 parsetree quotation") 34 | (libraries ocaml-migrate-parsetree ppx_tools_versioned) 35 | (kind ppx_rewriter) 36 | (wrapped false) 37 | (modules ppx_metaquot_403) 38 | (flags (:standard -w +A-4-17-44-45-105-42 -safe-string))) 39 | 40 | (library 41 | (name ppx_tools_versioned_metaquot_404) 42 | (public_name ppx_tools_versioned.metaquot_404) 43 | (synopsis "Meta-quotation: 4.04 parsetree quotation") 44 | (libraries ocaml-migrate-parsetree ppx_tools_versioned) 45 | (kind ppx_rewriter) 46 | (wrapped false) 47 | (modules ppx_metaquot_404) 48 | (flags (:standard -w +A-4-17-44-45-105-42 -safe-string))) 49 | 50 | (library 51 | (name ppx_tools_versioned_metaquot_405) 52 | (public_name ppx_tools_versioned.metaquot_405) 53 | (synopsis "Meta-quotation: 4.05 parsetree quotation") 54 | (libraries ocaml-migrate-parsetree ppx_tools_versioned) 55 | (kind ppx_rewriter) 56 | (wrapped false) 57 | (modules ppx_metaquot_405) 58 | (flags (:standard -w +A-4-17-44-45-105-42 -safe-string))) 59 | 60 | (library 61 | (name ppx_tools_versioned_metaquot_406) 62 | (public_name ppx_tools_versioned.metaquot_406) 63 | (synopsis "Meta-quotation: 4.06 parsetree quotation") 64 | (libraries ocaml-migrate-parsetree ppx_tools_versioned) 65 | (kind ppx_rewriter) 66 | (wrapped false) 67 | (modules ppx_metaquot_406) 68 | (flags (:standard -w +A-4-17-44-45-105-42 -safe-string))) 69 | 70 | (library 71 | (name ppx_tools_versioned_metaquot_407) 72 | (public_name ppx_tools_versioned.metaquot_407) 73 | (synopsis "Meta-quotation: 4.07 parsetree quotation") 74 | (libraries ocaml-migrate-parsetree ppx_tools_versioned) 75 | (kind ppx_rewriter) 76 | (wrapped false) 77 | (modules ppx_metaquot_407) 78 | (flags (:standard -w +A-4-17-44-45-105-42 -safe-string))) 79 | 80 | (library 81 | (name ppx_tools_versioned_metaquot_408) 82 | (public_name ppx_tools_versioned.metaquot_408) 83 | (synopsis "Meta-quotation: 4.08 parsetree quotation") 84 | (libraries ocaml-migrate-parsetree ppx_tools_versioned) 85 | (kind ppx_rewriter) 86 | (wrapped false) 87 | (modules ppx_metaquot_408) 88 | (flags (:standard -w +A-4-17-44-45-105-42 -safe-string))) 89 | 90 | (library 91 | (name ppx_tools_versioned_metaquot_409) 92 | (public_name ppx_tools_versioned.metaquot_409) 93 | (synopsis "Meta-quotation: 4.09 parsetree quotation") 94 | (libraries ocaml-migrate-parsetree ppx_tools_versioned) 95 | (kind ppx_rewriter) 96 | (wrapped false) 97 | (modules ppx_metaquot_409) 98 | (flags (:standard -w +A-4-17-44-45-105-42 -safe-string))) 99 | 100 | (library 101 | (name ppx_tools_versioned_metaquot_410) 102 | (public_name ppx_tools_versioned.metaquot_410) 103 | (synopsis "Meta-quotation: 4.10 parsetree quotation") 104 | (libraries ocaml-migrate-parsetree ppx_tools_versioned) 105 | (kind ppx_rewriter) 106 | (wrapped false) 107 | (modules ppx_metaquot_410) 108 | (flags (:standard -w +A-4-17-44-45-105-42 -safe-string))) 109 | 110 | (library 111 | (name ppx_tools_versioned_metaquot_411) 112 | (public_name ppx_tools_versioned.metaquot_411) 113 | (synopsis "Meta-quotation: 4.11 parsetree quotation") 114 | (libraries ocaml-migrate-parsetree ppx_tools_versioned) 115 | (kind ppx_rewriter) 116 | (wrapped false) 117 | (modules ppx_metaquot_411) 118 | (flags (:standard -w +A-4-17-44-45-105-42 -safe-string))) 119 | -------------------------------------------------------------------------------- /example/ppx_once/.merlin: -------------------------------------------------------------------------------- 1 | PKG compiler-libs ocaml-migrate-parsetree ppx_tools_versioned.metaquot_405 2 | 3 | FLG -safe-string 4 | -------------------------------------------------------------------------------- /example/ppx_once/META: -------------------------------------------------------------------------------- 1 | description = "once: execute expressions only once" 2 | version = "1.0" 3 | requires(custom_ppx) = "ocaml-migrate-parsetree" 4 | ppx(-custom_ppx,-ppx_driver) = "./ppx_once --as-ppx" 5 | archive(byte,ppx_driver) = "ppx_once.cmo" 6 | archive(native,ppx_driver) = "ppx_once.cmx" 7 | plugin(byte,ppx_driver) = "ppx_once.cma" 8 | plugin(native,ppx_driver) = "ppx_once.cmxs" 9 | -------------------------------------------------------------------------------- /example/ppx_once/Makefile: -------------------------------------------------------------------------------- 1 | PACKAGE=ppx_once 2 | OCAMLC=ocamlfind c 3 | OCAMLOPT=ocamlfind opt 4 | FLAGS=-package ocaml-migrate-parsetree,ppx_tools_versioned.metaquot_405 5 | TARGETS=ppx_once ppx_once.cmo ppx_once.cmx ppx_once.cmxs 6 | 7 | all: build 8 | 9 | clean: 10 | rm -f *.o *.cm* $(TARGETS) 11 | 12 | build: $(TARGETS) 13 | 14 | install: build 15 | ocamlfind install $(PACKAGE) META $(TARGETS) 16 | 17 | uninstall: 18 | ocamlfind remove $(PACKAGE) 19 | 20 | reinstall: 21 | $(MAKE) uninstall 22 | $(MAKE) install 23 | 24 | %.cmo: %.ml 25 | $(OCAMLC) $(FLAGS) -c $^ 26 | 27 | %.cmx: %.ml 28 | $(OCAMLOPT) $(FLAGS) -c $^ 29 | 30 | ppx_once.cmxs: ppx_once.cmx 31 | $(OCAMLOPT) -o $@ -shared $^ 32 | 33 | ppx_once: ppx_once.cmx standalone.ml 34 | $(OCAMLOPT) $(FLAGS) -o $@ -linkpkg $^ 35 | -------------------------------------------------------------------------------- /example/ppx_once/ppx_once.ml: -------------------------------------------------------------------------------- 1 | open Migrate_parsetree 2 | open Ast_405 3 | open Ppx_tools_405 4 | 5 | (* 6 | * This ppx rewrites expression extension of the form [%once expr]. 7 | * The first time the expression is evaluated, its result is cached. 8 | * After that, the evaluation will be skipped and the result reused. 9 | * 10 | * The ppx introduces references at the top-level to cache the results. 11 | *) 12 | 13 | let inject_once var code = 14 | [%expr match ![%e var] with 15 | | Some result -> result 16 | | None -> 17 | let result = [%e code] in 18 | [%e var] := Some result; 19 | result] 20 | [@metaloc {code.Parsetree.pexp_loc with Location.loc_ghost = true}] 21 | 22 | let mapper _config _cookies = 23 | let open Ast_mapper in 24 | let toplevel = ref true in 25 | let uid = ref 0 in 26 | let insert = ref [] in 27 | let make_option name = [%str let [%p Ast_helper.Pat.var name] = ref None] in 28 | let toplevel_structure mapper str = 29 | let items = List.fold_left (fun acc x -> 30 | let x' = mapper.structure_item mapper x in 31 | let items = List.map make_option !insert in 32 | insert := []; 33 | x' :: List.concat items @ acc 34 | ) [] str 35 | in 36 | List.rev items 37 | in 38 | let expr mapper pexp = 39 | let open Parsetree in 40 | match pexp.pexp_desc with 41 | | Pexp_extension ( 42 | {Location. txt = "once"; loc}, 43 | payload 44 | ) -> 45 | begin match payload with 46 | | PStr [{pstr_desc = Pstr_eval (body, []) }] -> 47 | incr uid; 48 | let name = "__ppx_once_" ^ string_of_int !uid in 49 | insert := Location.mkloc name loc :: !insert; 50 | inject_once 51 | (Ast_helper.Exp.ident (Location.mkloc (Longident.Lident name) loc)) 52 | (mapper.expr mapper body) 53 | | _ -> default_mapper.expr mapper pexp 54 | end; 55 | | _ -> default_mapper.expr mapper pexp 56 | in 57 | let structure mapper str = 58 | if !toplevel then ( 59 | uid := 0; 60 | insert := []; 61 | toplevel := false; 62 | match toplevel_structure mapper str with 63 | | result -> toplevel := true; result 64 | | exception exn -> toplevel := true; raise exn 65 | ) else 66 | default_mapper.structure mapper str 67 | in 68 | {default_mapper with structure; expr} 69 | 70 | let () = Driver.register ~name:"ppx_once" Versions.ocaml_405 mapper 71 | -------------------------------------------------------------------------------- /example/ppx_once/standalone.ml: -------------------------------------------------------------------------------- 1 | open Migrate_parsetree 2 | 3 | (* To run as a standalone binary, run the registered drivers *) 4 | let () = Driver.run_main () 5 | -------------------------------------------------------------------------------- /gen/update_dune.ml: -------------------------------------------------------------------------------- 1 | let versions = 2 | ["402"; "403"; "404"; "405"; "406"; "407"; "408"; "409"; "410"; "411"] 3 | 4 | let flags = "(:standard -w +A-4-17-44-45-105-42 -safe-string)" 5 | 6 | let ppx_tools_versioned_modules = 7 | versions 8 | |> List.map (fun v -> 9 | [ "ast_convenience" 10 | ; "ast_mapper_class" 11 | ; "ast_lifter" 12 | ; "ppx_tools" ] 13 | |> List.map (fun m -> Printf.sprintf "%s_%s" m v) 14 | |> String.concat " " 15 | ) 16 | |> String.concat "\n" 17 | 18 | let () = 19 | Printf.printf 20 | {sexp| 21 | (library 22 | (name ppx_tools_versioned) 23 | (public_name ppx_tools_versioned) 24 | (synopsis "Tools for authors of ppx rewriters and other syntactic tools (with ocaml-migrate-parsetree support)") 25 | (libraries ocaml-migrate-parsetree) 26 | (flags %s) 27 | (wrapped false) 28 | (modules %s)) 29 | |sexp} flags ppx_tools_versioned_modules 30 | 31 | let synopsis_v v = 32 | Printf.sprintf "%c.%s" v.[0] (String.sub v 1 (String.length v - 1)) 33 | 34 | let () = 35 | List.iter (fun version -> 36 | Printf.printf 37 | {sexp| 38 | (library 39 | (name ppx_tools_versioned_metaquot_%s) 40 | (public_name ppx_tools_versioned.metaquot_%s) 41 | (synopsis "Meta-quotation: %s parsetree quotation") 42 | (libraries ocaml-migrate-parsetree ppx_tools_versioned) 43 | (kind ppx_rewriter) 44 | (wrapped false) 45 | (modules ppx_metaquot_%s) 46 | (flags %s)) 47 | |sexp} version version (synopsis_v version) version flags 48 | ) versions 49 | -------------------------------------------------------------------------------- /ppx_metaquot_402.ml: -------------------------------------------------------------------------------- 1 | open Migrate_parsetree.Ast_402 2 | 3 | (* This file is part of the ppx_tools package. It is released *) 4 | (* under the terms of the MIT license (see LICENSE file). *) 5 | (* Copyright 2013 Alain Frisch and LexiFi *) 6 | 7 | (* A -ppx rewriter to be used to write Parsetree-generating code 8 | (including other -ppx rewriters) using concrete syntax. 9 | 10 | We support the following extensions in expression position: 11 | 12 | [%expr ...] maps to code which creates the expression represented by ... 13 | [%pat? ...] maps to code which creates the pattern represented by ... 14 | [%str ...] maps to code which creates the structure represented by ... 15 | [%stri ...] maps to code which creates the structure item represented by ... 16 | [%type: ...] maps to code which creates the core type represented by ... 17 | 18 | Quoted code can refer to expressions representing AST fragments, 19 | using the following extensions: 20 | 21 | [%e ...] where ... is an expression of type Parsetree.expression 22 | [%t ...] where ... is an expression of type Parsetree.core_type 23 | [%p ...] where ... is an expression of type Parsetree.pattern 24 | 25 | 26 | All locations generated by the meta quotation are by default set 27 | to [Ast_helper.default_loc]. This can be overriden by providing a custom 28 | expression which will be inserted whereever a location is required 29 | in the generated AST. This expression can be specified globally 30 | (for the current structure) as a structure item attribute: 31 | 32 | ;;[@@metaloc ...] 33 | 34 | or locally for the scope of an expression: 35 | 36 | e [@metaloc ...] 37 | 38 | 39 | 40 | Support is also provided to use concrete syntax in pattern 41 | position. The location and attribute fields are currently ignored 42 | by patterns generated from meta quotations. 43 | 44 | We support the following extensions in pattern position: 45 | 46 | [%expr ...] maps to code which creates the expression represented by ... 47 | [%pat? ...] maps to code which creates the pattern represented by ... 48 | [%str ...] maps to code which creates the structure represented by ... 49 | [%type: ...] maps to code which creates the core type represented by ... 50 | 51 | Quoted code can refer to expressions representing AST fragments, 52 | using the following extensions: 53 | 54 | [%e? ...] where ... is a pattern of type Parsetree.expression 55 | [%t? ...] where ... is a pattern of type Parsetree.core_type 56 | [%p? ...] where ... is a pattern of type Parsetree.pattern 57 | 58 | *) 59 | 60 | module Main : sig end = struct 61 | open Asttypes 62 | open Parsetree 63 | open Ast_helper 64 | open Ast_convenience_402 65 | 66 | let prefix ty s = 67 | let open Longident in 68 | match parse ty with 69 | | Ldot(m, _) -> String.concat "." (Longident.flatten m) ^ "." ^ s 70 | | _ -> s 71 | 72 | class exp_builder = 73 | object 74 | method record ty x = record (List.map (fun (l, e) -> prefix ty l, e) x) 75 | method constr ty (c, args) = constr (prefix ty c) args 76 | method list l = list l 77 | method tuple l = tuple l 78 | method int i = int i 79 | method string s = str s 80 | method char c = char c 81 | method int32 x = Exp.constant (Const_int32 x) 82 | method int64 x = Exp.constant (Const_int64 x) 83 | method nativeint x = Exp.constant (Const_nativeint x) 84 | end 85 | 86 | class pat_builder = 87 | object 88 | method record ty x = precord ~closed:Closed (List.map (fun (l, e) -> prefix ty l, e) x) 89 | method constr ty (c, args) = pconstr (prefix ty c) args 90 | method list l = plist l 91 | method tuple l = ptuple l 92 | method int i = pint i 93 | method string s = pstr s 94 | method char c = pchar c 95 | method int32 x = Pat.constant (Const_int32 x) 96 | method int64 x = Pat.constant (Const_int64 x) 97 | method nativeint x = Pat.constant (Const_nativeint x) 98 | end 99 | 100 | 101 | let get_exp loc = function 102 | | PStr [ {pstr_desc=Pstr_eval (e, _); _} ] -> e 103 | | _ -> 104 | Format.eprintf "%aError: Expression expected@." 105 | Location.print_loc loc; 106 | exit 2 107 | 108 | let get_typ loc = function 109 | | PTyp t -> t 110 | | _ -> 111 | Format.eprintf "%aError: Type expected@." 112 | Location.print_loc loc; 113 | exit 2 114 | 115 | let get_pat loc = function 116 | | PPat (t, None) -> t 117 | | _ -> 118 | Format.eprintf "%aError: Pattern expected@." 119 | Location.print_loc loc; 120 | exit 2 121 | 122 | let exp_lifter loc map = 123 | let map = map.Ast_mapper.expr map in 124 | object 125 | inherit [_] Ast_lifter_402.lifter as super 126 | inherit exp_builder 127 | 128 | (* Special support for location in the generated AST *) 129 | method! lift_Location_t _ = loc 130 | 131 | (* Support for antiquotations *) 132 | method! lift_Parsetree_expression = function 133 | | {pexp_desc=Pexp_extension({txt="e";loc}, e); _} -> map (get_exp loc e) 134 | | x -> super # lift_Parsetree_expression x 135 | 136 | method! lift_Parsetree_pattern = function 137 | | {ppat_desc=Ppat_extension({txt="p";loc}, e); _} -> map (get_exp loc e) 138 | | x -> super # lift_Parsetree_pattern x 139 | 140 | method! lift_Parsetree_core_type = function 141 | | {ptyp_desc=Ptyp_extension({txt="t";loc}, e); _} -> map (get_exp loc e) 142 | | x -> super # lift_Parsetree_core_type x 143 | end 144 | 145 | let pat_lifter map = 146 | let map = map.Ast_mapper.pat map in 147 | object 148 | inherit [_] Ast_lifter_402.lifter as super 149 | inherit pat_builder 150 | 151 | (* Special support for location and attributes in the generated AST *) 152 | method! lift_Location_t _ = Pat.any () 153 | method! lift_Parsetree_attributes _ = Pat.any () 154 | 155 | (* Support for antiquotations *) 156 | method! lift_Parsetree_expression = function 157 | | {pexp_desc=Pexp_extension({txt="e";loc}, e); _} -> map (get_pat loc e) 158 | | x -> super # lift_Parsetree_expression x 159 | 160 | method! lift_Parsetree_pattern = function 161 | | {ppat_desc=Ppat_extension({txt="p";loc}, e); _} -> map (get_pat loc e) 162 | | x -> super # lift_Parsetree_pattern x 163 | 164 | method! lift_Parsetree_core_type = function 165 | | {ptyp_desc=Ptyp_extension({txt="t";loc}, e); _} -> map (get_pat loc e) 166 | | x -> super # lift_Parsetree_core_type x 167 | end 168 | 169 | let loc = ref (Exp.field (evar "Ast_helper.default_loc") (lid "contents")) 170 | 171 | let handle_attr = function 172 | | {txt="metaloc";loc=l}, e -> loc := get_exp l e 173 | | _ -> () 174 | 175 | let with_loc ?(attrs = []) f = 176 | let old_loc = !loc in 177 | List.iter handle_attr attrs; 178 | let r = f () in 179 | loc := old_loc; 180 | r 181 | 182 | let expander _config _cookies = 183 | let open Ast_mapper in 184 | let super = default_mapper in 185 | let expr this e = 186 | with_loc ~attrs:e.pexp_attributes 187 | (fun () -> 188 | match e.pexp_desc with 189 | | Pexp_extension({txt="expr";loc=l}, e) -> 190 | (exp_lifter !loc this) # lift_Parsetree_expression (get_exp l e) 191 | | Pexp_extension({txt="pat";loc=l}, e) -> 192 | (exp_lifter !loc this) # lift_Parsetree_pattern (get_pat l e) 193 | | Pexp_extension({txt="str";_}, PStr e) -> 194 | (exp_lifter !loc this) # lift_Parsetree_structure e 195 | | Pexp_extension({txt="stri";_}, PStr [e]) -> 196 | (exp_lifter !loc this) # lift_Parsetree_structure_item e 197 | | Pexp_extension({txt="type";loc=l}, e) -> 198 | (exp_lifter !loc this) # lift_Parsetree_core_type (get_typ l e) 199 | | _ -> 200 | super.expr this e 201 | ) 202 | and pat this p = 203 | with_loc ~attrs:p.ppat_attributes 204 | (fun () -> 205 | match p.ppat_desc with 206 | | Ppat_extension({txt="expr";loc=l}, e) -> 207 | (pat_lifter this) # lift_Parsetree_expression (get_exp l e) 208 | | Ppat_extension({txt="pat";loc=l}, e) -> 209 | (pat_lifter this) # lift_Parsetree_pattern (get_pat l e) 210 | | Ppat_extension({txt="str";_}, PStr e) -> 211 | (pat_lifter this) # lift_Parsetree_structure e 212 | | Ppat_extension({txt="stri";_}, PStr [e]) -> 213 | (pat_lifter this) # lift_Parsetree_structure_item e 214 | | Ppat_extension({txt="type";loc=l}, e) -> 215 | (pat_lifter this) # lift_Parsetree_core_type (get_typ l e) 216 | | _ -> 217 | super.pat this p 218 | ) 219 | and structure this l = 220 | with_loc 221 | (fun () -> super.structure this l) 222 | 223 | and structure_item this x = 224 | begin match x.pstr_desc with 225 | | Pstr_attribute x -> handle_attr x 226 | | _ -> () 227 | end; 228 | super.structure_item this x 229 | 230 | in 231 | {super with expr; pat; structure; structure_item} 232 | 233 | let () = 234 | let open Migrate_parsetree in 235 | Driver.register ~name:"metaquot_402" Versions.ocaml_402 expander 236 | end 237 | -------------------------------------------------------------------------------- /ppx_metaquot_403.ml: -------------------------------------------------------------------------------- 1 | open Migrate_parsetree.Ast_403 2 | 3 | (* This file is part of the ppx_tools package. It is released *) 4 | (* under the terms of the MIT license (see LICENSE file). *) 5 | (* Copyright 2013 Alain Frisch and LexiFi *) 6 | 7 | (* A -ppx rewriter to be used to write Parsetree-generating code 8 | (including other -ppx rewriters) using concrete syntax. 9 | 10 | We support the following extensions in expression position: 11 | 12 | [%expr ...] maps to code which creates the expression represented by ... 13 | [%pat? ...] maps to code which creates the pattern represented by ... 14 | [%str ...] maps to code which creates the structure represented by ... 15 | [%stri ...] maps to code which creates the structure item represented by ... 16 | [%type: ...] maps to code which creates the core type represented by ... 17 | 18 | Quoted code can refer to expressions representing AST fragments, 19 | using the following extensions: 20 | 21 | [%e ...] where ... is an expression of type Parsetree.expression 22 | [%t ...] where ... is an expression of type Parsetree.core_type 23 | [%p ...] where ... is an expression of type Parsetree.pattern 24 | 25 | 26 | All locations generated by the meta quotation are by default set 27 | to [Ast_helper.default_loc]. This can be overriden by providing a custom 28 | expression which will be inserted whereever a location is required 29 | in the generated AST. This expression can be specified globally 30 | (for the current structure) as a structure item attribute: 31 | 32 | ;;[@@metaloc ...] 33 | 34 | or locally for the scope of an expression: 35 | 36 | e [@metaloc ...] 37 | 38 | 39 | 40 | Support is also provided to use concrete syntax in pattern 41 | position. The location and attribute fields are currently ignored 42 | by patterns generated from meta quotations. 43 | 44 | We support the following extensions in pattern position: 45 | 46 | [%expr ...] maps to code which creates the expression represented by ... 47 | [%pat? ...] maps to code which creates the pattern represented by ... 48 | [%str ...] maps to code which creates the structure represented by ... 49 | [%type: ...] maps to code which creates the core type represented by ... 50 | 51 | Quoted code can refer to expressions representing AST fragments, 52 | using the following extensions: 53 | 54 | [%e? ...] where ... is a pattern of type Parsetree.expression 55 | [%t? ...] where ... is a pattern of type Parsetree.core_type 56 | [%p? ...] where ... is a pattern of type Parsetree.pattern 57 | 58 | *) 59 | 60 | module Main : sig end = struct 61 | open Asttypes 62 | open Parsetree 63 | open Ast_helper 64 | open Ast_convenience_403 65 | 66 | let prefix ty s = 67 | let open Longident in 68 | match parse ty with 69 | | Ldot(m, _) -> String.concat "." (Longident.flatten m) ^ "." ^ s 70 | | _ -> s 71 | 72 | class exp_builder = 73 | object 74 | method record ty x = record (List.map (fun (l, e) -> prefix ty l, e) x) 75 | method constr ty (c, args) = constr (prefix ty c) args 76 | method list l = list l 77 | method tuple l = tuple l 78 | method int i = int i 79 | method string s = str s 80 | method char c = char c 81 | method int32 x = Exp.constant (Const.int32 x) 82 | method int64 x = Exp.constant (Const.int64 x) 83 | method nativeint x = Exp.constant (Const.nativeint x) 84 | end 85 | 86 | class pat_builder = 87 | object 88 | method record ty x = precord ~closed:Closed (List.map (fun (l, e) -> prefix ty l, e) x) 89 | method constr ty (c, args) = pconstr (prefix ty c) args 90 | method list l = plist l 91 | method tuple l = ptuple l 92 | method int i = pint i 93 | method string s = pstr s 94 | method char c = pchar c 95 | method int32 x = Pat.constant (Const.int32 x) 96 | method int64 x = Pat.constant (Const.int64 x) 97 | method nativeint x = Pat.constant (Const.nativeint x) 98 | end 99 | 100 | 101 | let get_exp loc = function 102 | | PStr [ {pstr_desc=Pstr_eval (e, _); _} ] -> e 103 | | _ -> 104 | Format.eprintf "%aError: Expression expected@." 105 | Location.print_loc loc; 106 | exit 2 107 | 108 | let get_typ loc = function 109 | | PTyp t -> t 110 | | _ -> 111 | Format.eprintf "%aError: Type expected@." 112 | Location.print_loc loc; 113 | exit 2 114 | 115 | let get_pat loc = function 116 | | PPat (t, None) -> t 117 | | _ -> 118 | Format.eprintf "%aError: Pattern expected@." 119 | Location.print_loc loc; 120 | exit 2 121 | 122 | let exp_lifter loc map = 123 | let map = map.Ast_mapper.expr map in 124 | object 125 | inherit [_] Ast_lifter_403.lifter as super 126 | inherit exp_builder 127 | 128 | (* Special support for location in the generated AST *) 129 | method! lift_Location_t _ = loc 130 | 131 | (* Support for antiquotations *) 132 | method! lift_Parsetree_expression = function 133 | | {pexp_desc=Pexp_extension({txt="e";loc}, e); _} -> map (get_exp loc e) 134 | | x -> super # lift_Parsetree_expression x 135 | 136 | method! lift_Parsetree_pattern = function 137 | | {ppat_desc=Ppat_extension({txt="p";loc}, e); _} -> map (get_exp loc e) 138 | | x -> super # lift_Parsetree_pattern x 139 | 140 | method! lift_Parsetree_core_type = function 141 | | {ptyp_desc=Ptyp_extension({txt="t";loc}, e); _} -> map (get_exp loc e) 142 | | x -> super # lift_Parsetree_core_type x 143 | end 144 | 145 | let pat_lifter map = 146 | let map = map.Ast_mapper.pat map in 147 | object 148 | inherit [_] Ast_lifter_403.lifter as super 149 | inherit pat_builder 150 | 151 | (* Special support for location and attributes in the generated AST *) 152 | method! lift_Location_t _ = Pat.any () 153 | method! lift_Parsetree_attributes _ = Pat.any () 154 | 155 | (* Support for antiquotations *) 156 | method! lift_Parsetree_expression = function 157 | | {pexp_desc=Pexp_extension({txt="e";loc}, e); _} -> map (get_pat loc e) 158 | | x -> super # lift_Parsetree_expression x 159 | 160 | method! lift_Parsetree_pattern = function 161 | | {ppat_desc=Ppat_extension({txt="p";loc}, e); _} -> map (get_pat loc e) 162 | | x -> super # lift_Parsetree_pattern x 163 | 164 | method! lift_Parsetree_core_type = function 165 | | {ptyp_desc=Ptyp_extension({txt="t";loc}, e); _} -> map (get_pat loc e) 166 | | x -> super # lift_Parsetree_core_type x 167 | end 168 | 169 | let loc = ref (Exp.field (evar "Ast_helper.default_loc") (lid "contents")) 170 | 171 | let handle_attr = function 172 | | {txt="metaloc";loc=l}, e -> loc := get_exp l e 173 | | _ -> () 174 | 175 | let with_loc ?(attrs = []) f = 176 | let old_loc = !loc in 177 | List.iter handle_attr attrs; 178 | let r = f () in 179 | loc := old_loc; 180 | r 181 | 182 | let expander _config _cookies = 183 | let open Ast_mapper in 184 | let super = default_mapper in 185 | let expr this e = 186 | with_loc ~attrs:e.pexp_attributes 187 | (fun () -> 188 | match e.pexp_desc with 189 | | Pexp_extension({txt="expr";loc=l}, e) -> 190 | (exp_lifter !loc this) # lift_Parsetree_expression (get_exp l e) 191 | | Pexp_extension({txt="pat";loc=l}, e) -> 192 | (exp_lifter !loc this) # lift_Parsetree_pattern (get_pat l e) 193 | | Pexp_extension({txt="str";_}, PStr e) -> 194 | (exp_lifter !loc this) # lift_Parsetree_structure e 195 | | Pexp_extension({txt="stri";_}, PStr [e]) -> 196 | (exp_lifter !loc this) # lift_Parsetree_structure_item e 197 | | Pexp_extension({txt="type";loc=l}, e) -> 198 | (exp_lifter !loc this) # lift_Parsetree_core_type (get_typ l e) 199 | | _ -> 200 | super.expr this e 201 | ) 202 | and pat this p = 203 | with_loc ~attrs:p.ppat_attributes 204 | (fun () -> 205 | match p.ppat_desc with 206 | | Ppat_extension({txt="expr";loc=l}, e) -> 207 | (pat_lifter this) # lift_Parsetree_expression (get_exp l e) 208 | | Ppat_extension({txt="pat";loc=l}, e) -> 209 | (pat_lifter this) # lift_Parsetree_pattern (get_pat l e) 210 | | Ppat_extension({txt="str";_}, PStr e) -> 211 | (pat_lifter this) # lift_Parsetree_structure e 212 | | Ppat_extension({txt="stri";_}, PStr [e]) -> 213 | (pat_lifter this) # lift_Parsetree_structure_item e 214 | | Ppat_extension({txt="type";loc=l}, e) -> 215 | (pat_lifter this) # lift_Parsetree_core_type (get_typ l e) 216 | | _ -> 217 | super.pat this p 218 | ) 219 | and structure this l = 220 | with_loc 221 | (fun () -> super.structure this l) 222 | 223 | and structure_item this x = 224 | begin match x.pstr_desc with 225 | | Pstr_attribute x -> handle_attr x 226 | | _ -> () 227 | end; 228 | super.structure_item this x 229 | 230 | in 231 | {super with expr; pat; structure; structure_item} 232 | 233 | let () = 234 | let open Migrate_parsetree in 235 | Driver.register ~name:"metaquot_403" Versions.ocaml_403 expander 236 | end 237 | -------------------------------------------------------------------------------- /ppx_metaquot_404.ml: -------------------------------------------------------------------------------- 1 | open Migrate_parsetree.Ast_404 2 | 3 | (* This file is part of the ppx_tools package. It is released *) 4 | (* under the terms of the MIT license (see LICENSE file). *) 5 | (* Copyright 2013 Alain Frisch and LexiFi *) 6 | 7 | (* A -ppx rewriter to be used to write Parsetree-generating code 8 | (including other -ppx rewriters) using concrete syntax. 9 | 10 | We support the following extensions in expression position: 11 | 12 | [%expr ...] maps to code which creates the expression represented by ... 13 | [%pat? ...] maps to code which creates the pattern represented by ... 14 | [%str ...] maps to code which creates the structure represented by ... 15 | [%stri ...] maps to code which creates the structure item represented by ... 16 | [%sig: ...] maps to code which creates the signature represented by ... 17 | [%sigi: ...] maps to code which creates the signature item represented by ... 18 | [%type: ...] maps to code which creates the core type represented by ... 19 | 20 | Quoted code can refer to expressions representing AST fragments, 21 | using the following extensions: 22 | 23 | [%e ...] where ... is an expression of type Parsetree.expression 24 | [%t ...] where ... is an expression of type Parsetree.core_type 25 | [%p ...] where ... is an expression of type Parsetree.pattern 26 | [%%s ...] where ... is an expression of type Parsetree.structure 27 | or Parsetree.signature depending on the context. 28 | 29 | 30 | All locations generated by the meta quotation are by default set 31 | to [Ast_helper.default_loc]. This can be overriden by providing a custom 32 | expression which will be inserted whereever a location is required 33 | in the generated AST. This expression can be specified globally 34 | (for the current structure) as a structure item attribute: 35 | 36 | ;;[@@metaloc ...] 37 | 38 | or locally for the scope of an expression: 39 | 40 | e [@metaloc ...] 41 | 42 | 43 | 44 | Support is also provided to use concrete syntax in pattern 45 | position. The location and attribute fields are currently ignored 46 | by patterns generated from meta quotations. 47 | 48 | We support the following extensions in pattern position: 49 | 50 | [%expr ...] maps to code which creates the expression represented by ... 51 | [%pat? ...] maps to code which creates the pattern represented by ... 52 | [%str ...] maps to code which creates the structure represented by ... 53 | [%type: ...] maps to code which creates the core type represented by ... 54 | 55 | Quoted code can refer to expressions representing AST fragments, 56 | using the following extensions: 57 | 58 | [%e? ...] where ... is a pattern of type Parsetree.expression 59 | [%t? ...] where ... is a pattern of type Parsetree.core_type 60 | [%p? ...] where ... is a pattern of type Parsetree.pattern 61 | 62 | *) 63 | 64 | module Main : sig end = struct 65 | open Asttypes 66 | open Parsetree 67 | open Ast_helper 68 | open Ast_convenience_404 69 | 70 | let prefix ty s = 71 | let open Longident in 72 | match parse ty with 73 | | Ldot(m, _) -> String.concat "." (Longident.flatten m) ^ "." ^ s 74 | | _ -> s 75 | 76 | let append ?loc ?attrs e e' = 77 | let fn = Location.mknoloc (Longident.(Ldot (Lident "List", "append"))) in 78 | Exp.apply ?loc ?attrs (Exp.ident fn) [Nolabel, e; Nolabel, e'] 79 | 80 | class exp_builder = 81 | object 82 | method record ty x = record (List.map (fun (l, e) -> prefix ty l, e) x) 83 | method constr ty (c, args) = constr (prefix ty c) args 84 | method list l = list l 85 | method tuple l = tuple l 86 | method int i = int i 87 | method string s = str s 88 | method char c = char c 89 | method int32 x = Exp.constant (Const.int32 x) 90 | method int64 x = Exp.constant (Const.int64 x) 91 | method nativeint x = Exp.constant (Const.nativeint x) 92 | end 93 | 94 | class pat_builder = 95 | object 96 | method record ty x = precord ~closed:Closed (List.map (fun (l, e) -> prefix ty l, e) x) 97 | method constr ty (c, args) = pconstr (prefix ty c) args 98 | method list l = plist l 99 | method tuple l = ptuple l 100 | method int i = pint i 101 | method string s = pstr s 102 | method char c = pchar c 103 | method int32 x = Pat.constant (Const.int32 x) 104 | method int64 x = Pat.constant (Const.int64 x) 105 | method nativeint x = Pat.constant (Const.nativeint x) 106 | end 107 | 108 | 109 | let get_exp loc = function 110 | | PStr [ {pstr_desc=Pstr_eval (e, _); _} ] -> e 111 | | _ -> 112 | Format.eprintf "%aError: Expression expected@." 113 | Location.print_loc loc; 114 | exit 2 115 | 116 | let get_typ loc = function 117 | | PTyp t -> t 118 | | _ -> 119 | Format.eprintf "%aError: Type expected@." 120 | Location.print_loc loc; 121 | exit 2 122 | 123 | let get_pat loc = function 124 | | PPat (t, None) -> t 125 | | _ -> 126 | Format.eprintf "%aError: Pattern expected@." 127 | Location.print_loc loc; 128 | exit 2 129 | 130 | let exp_lifter loc map = 131 | let map = map.Ast_mapper.expr map in 132 | object 133 | inherit [_] Ast_lifter_404.lifter as super 134 | inherit exp_builder 135 | 136 | (* Special support for location in the generated AST *) 137 | method! lift_Location_t _ = loc 138 | 139 | (* Support for antiquotations *) 140 | method! lift_Parsetree_expression = function 141 | | {pexp_desc=Pexp_extension({txt="e";loc}, e); _} -> map (get_exp loc e) 142 | | x -> super # lift_Parsetree_expression x 143 | 144 | method! lift_Parsetree_pattern = function 145 | | {ppat_desc=Ppat_extension({txt="p";loc}, e); _} -> map (get_exp loc e) 146 | | x -> super # lift_Parsetree_pattern x 147 | 148 | method! lift_Parsetree_structure str = 149 | List.fold_right 150 | (function 151 | | {pstr_desc=Pstr_extension(({txt="s";loc}, e), _); _} -> 152 | append (get_exp loc e) 153 | | x -> 154 | cons (super # lift_Parsetree_structure_item x)) 155 | str (nil ()) 156 | 157 | method! lift_Parsetree_signature sign = 158 | List.fold_right 159 | (function 160 | | {psig_desc=Psig_extension(({txt="s";loc}, e), _); _} -> 161 | append (get_exp loc e) 162 | | x -> 163 | cons (super # lift_Parsetree_signature_item x)) 164 | sign (nil ()) 165 | 166 | method! lift_Parsetree_core_type = function 167 | | {ptyp_desc=Ptyp_extension({txt="t";loc}, e); _} -> map (get_exp loc e) 168 | | x -> super # lift_Parsetree_core_type x 169 | end 170 | 171 | let pat_lifter map = 172 | let map = map.Ast_mapper.pat map in 173 | object 174 | inherit [_] Ast_lifter_404.lifter as super 175 | inherit pat_builder 176 | 177 | (* Special support for location and attributes in the generated AST *) 178 | method! lift_Location_t _ = Pat.any () 179 | method! lift_Parsetree_attributes _ = Pat.any () 180 | 181 | (* Support for antiquotations *) 182 | method! lift_Parsetree_expression = function 183 | | {pexp_desc=Pexp_extension({txt="e";loc}, e); _} -> map (get_pat loc e) 184 | | x -> super # lift_Parsetree_expression x 185 | 186 | method! lift_Parsetree_pattern = function 187 | | {ppat_desc=Ppat_extension({txt="p";loc}, e); _} -> map (get_pat loc e) 188 | | x -> super # lift_Parsetree_pattern x 189 | 190 | method! lift_Parsetree_core_type = function 191 | | {ptyp_desc=Ptyp_extension({txt="t";loc}, e); _} -> map (get_pat loc e) 192 | | x -> super # lift_Parsetree_core_type x 193 | end 194 | 195 | let loc = ref (Exp.field (evar "Ast_helper.default_loc") (lid "contents")) 196 | 197 | let handle_attr = function 198 | | {txt="metaloc";loc=l}, e -> loc := get_exp l e 199 | | _ -> () 200 | 201 | let with_loc ?(attrs = []) f = 202 | let old_loc = !loc in 203 | List.iter handle_attr attrs; 204 | let r = f () in 205 | loc := old_loc; 206 | r 207 | 208 | let expander _config _cookies = 209 | let open Ast_mapper in 210 | let super = default_mapper in 211 | let expr this e = 212 | with_loc ~attrs:e.pexp_attributes 213 | (fun () -> 214 | match e.pexp_desc with 215 | | Pexp_extension({txt="expr";loc=l}, e) -> 216 | (exp_lifter !loc this) # lift_Parsetree_expression (get_exp l e) 217 | | Pexp_extension({txt="pat";loc=l}, e) -> 218 | (exp_lifter !loc this) # lift_Parsetree_pattern (get_pat l e) 219 | | Pexp_extension({txt="str";_}, PStr e) -> 220 | (exp_lifter !loc this) # lift_Parsetree_structure e 221 | | Pexp_extension({txt="stri";_}, PStr [e]) -> 222 | (exp_lifter !loc this) # lift_Parsetree_structure_item e 223 | | Pexp_extension({txt="sig";_}, PSig e) -> 224 | (exp_lifter !loc this) # lift_Parsetree_signature e 225 | | Pexp_extension({txt="sigi";_}, PSig [e]) -> 226 | (exp_lifter !loc this) # lift_Parsetree_signature_item e 227 | | Pexp_extension({txt="type";loc=l}, e) -> 228 | (exp_lifter !loc this) # lift_Parsetree_core_type (get_typ l e) 229 | | _ -> 230 | super.expr this e 231 | ) 232 | and pat this p = 233 | with_loc ~attrs:p.ppat_attributes 234 | (fun () -> 235 | match p.ppat_desc with 236 | | Ppat_extension({txt="expr";loc=l}, e) -> 237 | (pat_lifter this) # lift_Parsetree_expression (get_exp l e) 238 | | Ppat_extension({txt="pat";loc=l}, e) -> 239 | (pat_lifter this) # lift_Parsetree_pattern (get_pat l e) 240 | | Ppat_extension({txt="str";_}, PStr e) -> 241 | (pat_lifter this) # lift_Parsetree_structure e 242 | | Ppat_extension({txt="stri";_}, PStr [e]) -> 243 | (pat_lifter this) # lift_Parsetree_structure_item e 244 | | Ppat_extension({txt="sig";_}, PSig e) -> 245 | (pat_lifter this) # lift_Parsetree_signature e 246 | | Ppat_extension({txt="sigi";_}, PSig [e]) -> 247 | (pat_lifter this) # lift_Parsetree_signature_item e 248 | | Ppat_extension({txt="type";loc=l}, e) -> 249 | (pat_lifter this) # lift_Parsetree_core_type (get_typ l e) 250 | | _ -> 251 | super.pat this p 252 | ) 253 | and structure this l = 254 | with_loc 255 | (fun () -> super.structure this l) 256 | 257 | and structure_item this x = 258 | begin match x.pstr_desc with 259 | | Pstr_attribute x -> handle_attr x 260 | | _ -> () 261 | end; 262 | super.structure_item this x 263 | 264 | and signature this l = 265 | with_loc 266 | (fun () -> super.signature this l) 267 | 268 | and signature_item this x = 269 | begin match x.psig_desc with 270 | | Psig_attribute x -> handle_attr x 271 | | _ -> () 272 | end; 273 | super.signature_item this x 274 | 275 | in 276 | {super with expr; pat; structure; structure_item; signature; signature_item} 277 | 278 | let () = 279 | let open Migrate_parsetree in 280 | Driver.register ~name:"metaquot_404" Versions.ocaml_404 expander 281 | end 282 | -------------------------------------------------------------------------------- /ppx_metaquot_405.ml: -------------------------------------------------------------------------------- 1 | open Migrate_parsetree.Ast_405 2 | 3 | (* This file is part of the ppx_tools package. It is released *) 4 | (* under the terms of the MIT license (see LICENSE file). *) 5 | (* Copyright 2013 Alain Frisch and LexiFi *) 6 | 7 | (* A -ppx rewriter to be used to write Parsetree-generating code 8 | (including other -ppx rewriters) using concrete syntax. 9 | 10 | We support the following extensions in expression position: 11 | 12 | [%expr ...] maps to code which creates the expression represented by ... 13 | [%pat? ...] maps to code which creates the pattern represented by ... 14 | [%str ...] maps to code which creates the structure represented by ... 15 | [%stri ...] maps to code which creates the structure item represented by ... 16 | [%sig: ...] maps to code which creates the signature represented by ... 17 | [%sigi: ...] maps to code which creates the signature item represented by ... 18 | [%type: ...] maps to code which creates the core type represented by ... 19 | 20 | Quoted code can refer to expressions representing AST fragments, 21 | using the following extensions: 22 | 23 | [%e ...] where ... is an expression of type Parsetree.expression 24 | [%t ...] where ... is an expression of type Parsetree.core_type 25 | [%p ...] where ... is an expression of type Parsetree.pattern 26 | [%%s ...] where ... is an expression of type Parsetree.structure 27 | or Parsetree.signature depending on the context. 28 | 29 | 30 | All locations generated by the meta quotation are by default set 31 | to [Ast_helper.default_loc]. This can be overriden by providing a custom 32 | expression which will be inserted whereever a location is required 33 | in the generated AST. This expression can be specified globally 34 | (for the current structure) as a structure item attribute: 35 | 36 | ;;[@@metaloc ...] 37 | 38 | or locally for the scope of an expression: 39 | 40 | e [@metaloc ...] 41 | 42 | 43 | 44 | Support is also provided to use concrete syntax in pattern 45 | position. The location and attribute fields are currently ignored 46 | by patterns generated from meta quotations. 47 | 48 | We support the following extensions in pattern position: 49 | 50 | [%expr ...] maps to code which creates the expression represented by ... 51 | [%pat? ...] maps to code which creates the pattern represented by ... 52 | [%str ...] maps to code which creates the structure represented by ... 53 | [%type: ...] maps to code which creates the core type represented by ... 54 | 55 | Quoted code can refer to expressions representing AST fragments, 56 | using the following extensions: 57 | 58 | [%e? ...] where ... is a pattern of type Parsetree.expression 59 | [%t? ...] where ... is a pattern of type Parsetree.core_type 60 | [%p? ...] where ... is a pattern of type Parsetree.pattern 61 | 62 | *) 63 | 64 | module Main : sig end = struct 65 | open Asttypes 66 | open Parsetree 67 | open Ast_helper 68 | open Ast_convenience_405 69 | 70 | let prefix ty s = 71 | let open Longident in 72 | match parse ty with 73 | | Ldot(m, _) -> String.concat "." (Longident.flatten m) ^ "." ^ s 74 | | _ -> s 75 | 76 | let append ?loc ?attrs e e' = 77 | let fn = Location.mknoloc (Longident.(Ldot (Lident "List", "append"))) in 78 | Exp.apply ?loc ?attrs (Exp.ident fn) [Nolabel, e; Nolabel, e'] 79 | 80 | class exp_builder = 81 | object 82 | method record ty x = record (List.map (fun (l, e) -> prefix ty l, e) x) 83 | method constr ty (c, args) = constr (prefix ty c) args 84 | method list l = list l 85 | method tuple l = tuple l 86 | method int i = int i 87 | method string s = str s 88 | method char c = char c 89 | method int32 x = Exp.constant (Const.int32 x) 90 | method int64 x = Exp.constant (Const.int64 x) 91 | method nativeint x = Exp.constant (Const.nativeint x) 92 | end 93 | 94 | class pat_builder = 95 | object 96 | method record ty x = precord ~closed:Closed (List.map (fun (l, e) -> prefix ty l, e) x) 97 | method constr ty (c, args) = pconstr (prefix ty c) args 98 | method list l = plist l 99 | method tuple l = ptuple l 100 | method int i = pint i 101 | method string s = pstr s 102 | method char c = pchar c 103 | method int32 x = Pat.constant (Const.int32 x) 104 | method int64 x = Pat.constant (Const.int64 x) 105 | method nativeint x = Pat.constant (Const.nativeint x) 106 | end 107 | 108 | 109 | let get_exp loc = function 110 | | PStr [ {pstr_desc=Pstr_eval (e, _); _} ] -> e 111 | | _ -> 112 | Format.eprintf "%aError: Expression expected@." 113 | Location.print_loc loc; 114 | exit 2 115 | 116 | let get_typ loc = function 117 | | PTyp t -> t 118 | | _ -> 119 | Format.eprintf "%aError: Type expected@." 120 | Location.print_loc loc; 121 | exit 2 122 | 123 | let get_pat loc = function 124 | | PPat (t, None) -> t 125 | | _ -> 126 | Format.eprintf "%aError: Pattern expected@." 127 | Location.print_loc loc; 128 | exit 2 129 | 130 | let exp_lifter loc map = 131 | let map = map.Ast_mapper.expr map in 132 | object 133 | inherit [_] Ast_lifter_405.lifter as super 134 | inherit exp_builder 135 | 136 | (* Special support for location in the generated AST *) 137 | method! lift_Location_t _ = loc 138 | 139 | (* Support for antiquotations *) 140 | method! lift_Parsetree_expression = function 141 | | {pexp_desc=Pexp_extension({txt="e";loc}, e); _} -> map (get_exp loc e) 142 | | x -> super # lift_Parsetree_expression x 143 | 144 | method! lift_Parsetree_pattern = function 145 | | {ppat_desc=Ppat_extension({txt="p";loc}, e); _} -> map (get_exp loc e) 146 | | x -> super # lift_Parsetree_pattern x 147 | 148 | method! lift_Parsetree_structure str = 149 | List.fold_right 150 | (function 151 | | {pstr_desc=Pstr_extension(({txt="s";loc}, e), _); _} -> 152 | append (get_exp loc e) 153 | | x -> 154 | cons (super # lift_Parsetree_structure_item x)) 155 | str (nil ()) 156 | 157 | method! lift_Parsetree_signature sign = 158 | List.fold_right 159 | (function 160 | | {psig_desc=Psig_extension(({txt="s";loc}, e), _); _} -> 161 | append (get_exp loc e) 162 | | x -> 163 | cons (super # lift_Parsetree_signature_item x)) 164 | sign (nil ()) 165 | 166 | method! lift_Parsetree_core_type = function 167 | | {ptyp_desc=Ptyp_extension({txt="t";loc}, e); _} -> map (get_exp loc e) 168 | | x -> super # lift_Parsetree_core_type x 169 | end 170 | 171 | let pat_lifter map = 172 | let map = map.Ast_mapper.pat map in 173 | object 174 | inherit [_] Ast_lifter_405.lifter as super 175 | inherit pat_builder 176 | 177 | (* Special support for location and attributes in the generated AST *) 178 | method! lift_Location_t _ = Pat.any () 179 | method! lift_Parsetree_attributes _ = Pat.any () 180 | 181 | (* Support for antiquotations *) 182 | method! lift_Parsetree_expression = function 183 | | {pexp_desc=Pexp_extension({txt="e";loc}, e); _} -> map (get_pat loc e) 184 | | x -> super # lift_Parsetree_expression x 185 | 186 | method! lift_Parsetree_pattern = function 187 | | {ppat_desc=Ppat_extension({txt="p";loc}, e); _} -> map (get_pat loc e) 188 | | x -> super # lift_Parsetree_pattern x 189 | 190 | method! lift_Parsetree_core_type = function 191 | | {ptyp_desc=Ptyp_extension({txt="t";loc}, e); _} -> map (get_pat loc e) 192 | | x -> super # lift_Parsetree_core_type x 193 | end 194 | 195 | let loc = ref (Exp.field (evar "Ast_helper.default_loc") (lid "contents")) 196 | 197 | let handle_attr = function 198 | | {txt="metaloc";loc=l}, e -> loc := get_exp l e 199 | | _ -> () 200 | 201 | let with_loc ?(attrs = []) f = 202 | let old_loc = !loc in 203 | List.iter handle_attr attrs; 204 | let r = f () in 205 | loc := old_loc; 206 | r 207 | 208 | let expander _config _cookies = 209 | let open Ast_mapper in 210 | let super = default_mapper in 211 | let expr this e = 212 | with_loc ~attrs:e.pexp_attributes 213 | (fun () -> 214 | match e.pexp_desc with 215 | | Pexp_extension({txt="expr";loc=l}, e) -> 216 | (exp_lifter !loc this) # lift_Parsetree_expression (get_exp l e) 217 | | Pexp_extension({txt="pat";loc=l}, e) -> 218 | (exp_lifter !loc this) # lift_Parsetree_pattern (get_pat l e) 219 | | Pexp_extension({txt="str";_}, PStr e) -> 220 | (exp_lifter !loc this) # lift_Parsetree_structure e 221 | | Pexp_extension({txt="stri";_}, PStr [e]) -> 222 | (exp_lifter !loc this) # lift_Parsetree_structure_item e 223 | | Pexp_extension({txt="sig";_}, PSig e) -> 224 | (exp_lifter !loc this) # lift_Parsetree_signature e 225 | | Pexp_extension({txt="sigi";_}, PSig [e]) -> 226 | (exp_lifter !loc this) # lift_Parsetree_signature_item e 227 | | Pexp_extension({txt="type";loc=l}, e) -> 228 | (exp_lifter !loc this) # lift_Parsetree_core_type (get_typ l e) 229 | | _ -> 230 | super.expr this e 231 | ) 232 | and pat this p = 233 | with_loc ~attrs:p.ppat_attributes 234 | (fun () -> 235 | match p.ppat_desc with 236 | | Ppat_extension({txt="expr";loc=l}, e) -> 237 | (pat_lifter this) # lift_Parsetree_expression (get_exp l e) 238 | | Ppat_extension({txt="pat";loc=l}, e) -> 239 | (pat_lifter this) # lift_Parsetree_pattern (get_pat l e) 240 | | Ppat_extension({txt="str";_}, PStr e) -> 241 | (pat_lifter this) # lift_Parsetree_structure e 242 | | Ppat_extension({txt="stri";_}, PStr [e]) -> 243 | (pat_lifter this) # lift_Parsetree_structure_item e 244 | | Ppat_extension({txt="sig";_}, PSig e) -> 245 | (pat_lifter this) # lift_Parsetree_signature e 246 | | Ppat_extension({txt="sigi";_}, PSig [e]) -> 247 | (pat_lifter this) # lift_Parsetree_signature_item e 248 | | Ppat_extension({txt="type";loc=l}, e) -> 249 | (pat_lifter this) # lift_Parsetree_core_type (get_typ l e) 250 | | _ -> 251 | super.pat this p 252 | ) 253 | and structure this l = 254 | with_loc 255 | (fun () -> super.structure this l) 256 | 257 | and structure_item this x = 258 | begin match x.pstr_desc with 259 | | Pstr_attribute x -> handle_attr x 260 | | _ -> () 261 | end; 262 | super.structure_item this x 263 | 264 | and signature this l = 265 | with_loc 266 | (fun () -> super.signature this l) 267 | 268 | and signature_item this x = 269 | begin match x.psig_desc with 270 | | Psig_attribute x -> handle_attr x 271 | | _ -> () 272 | end; 273 | super.signature_item this x 274 | 275 | in 276 | {super with expr; pat; structure; structure_item; signature; signature_item} 277 | 278 | let () = 279 | let open Migrate_parsetree in 280 | Driver.register ~name:"metaquot_405" Versions.ocaml_405 expander 281 | end 282 | -------------------------------------------------------------------------------- /ppx_metaquot_406.ml: -------------------------------------------------------------------------------- 1 | open Migrate_parsetree.Ast_406 2 | 3 | (* This file is part of the ppx_tools package. It is released *) 4 | (* under the terms of the MIT license (see LICENSE file). *) 5 | (* Copyright 2013 Alain Frisch and LexiFi *) 6 | 7 | (* A -ppx rewriter to be used to write Parsetree-generating code 8 | (including other -ppx rewriters) using concrete syntax. 9 | 10 | We support the following extensions in expression position: 11 | 12 | [%expr ...] maps to code which creates the expression represented by ... 13 | [%pat? ...] maps to code which creates the pattern represented by ... 14 | [%str ...] maps to code which creates the structure represented by ... 15 | [%stri ...] maps to code which creates the structure item represented by ... 16 | [%sig: ...] maps to code which creates the signature represented by ... 17 | [%sigi: ...] maps to code which creates the signature item represented by ... 18 | [%type: ...] maps to code which creates the core type represented by ... 19 | 20 | Quoted code can refer to expressions representing AST fragments, 21 | using the following extensions: 22 | 23 | [%e ...] where ... is an expression of type Parsetree.expression 24 | [%t ...] where ... is an expression of type Parsetree.core_type 25 | [%p ...] where ... is an expression of type Parsetree.pattern 26 | [%%s ...] where ... is an expression of type Parsetree.structure 27 | or Parsetree.signature depending on the context. 28 | 29 | 30 | All locations generated by the meta quotation are by default set 31 | to [Ast_helper.default_loc]. This can be overriden by providing a custom 32 | expression which will be inserted whereever a location is required 33 | in the generated AST. This expression can be specified globally 34 | (for the current structure) as a structure item attribute: 35 | 36 | ;;[@@metaloc ...] 37 | 38 | or locally for the scope of an expression: 39 | 40 | e [@metaloc ...] 41 | 42 | 43 | 44 | Support is also provided to use concrete syntax in pattern 45 | position. The location and attribute fields are currently ignored 46 | by patterns generated from meta quotations. 47 | 48 | We support the following extensions in pattern position: 49 | 50 | [%expr ...] maps to code which creates the expression represented by ... 51 | [%pat? ...] maps to code which creates the pattern represented by ... 52 | [%str ...] maps to code which creates the structure represented by ... 53 | [%type: ...] maps to code which creates the core type represented by ... 54 | 55 | Quoted code can refer to expressions representing AST fragments, 56 | using the following extensions: 57 | 58 | [%e? ...] where ... is a pattern of type Parsetree.expression 59 | [%t? ...] where ... is a pattern of type Parsetree.core_type 60 | [%p? ...] where ... is a pattern of type Parsetree.pattern 61 | 62 | *) 63 | 64 | module Main : sig end = struct 65 | open Asttypes 66 | open Parsetree 67 | open Ast_helper 68 | open Ast_convenience_406 69 | 70 | let prefix ty s = 71 | let open Longident in 72 | match parse ty with 73 | | Ldot(m, _) -> String.concat "." (Longident.flatten m) ^ "." ^ s 74 | | _ -> s 75 | 76 | let append ?loc ?attrs e e' = 77 | let fn = Location.mknoloc (Longident.(Ldot (Lident "List", "append"))) in 78 | Exp.apply ?loc ?attrs (Exp.ident fn) [Nolabel, e; Nolabel, e'] 79 | 80 | class exp_builder = 81 | object 82 | method record ty x = record (List.map (fun (l, e) -> prefix ty l, e) x) 83 | method constr ty (c, args) = constr (prefix ty c) args 84 | method list l = list l 85 | method tuple l = tuple l 86 | method int i = int i 87 | method string s = str s 88 | method char c = char c 89 | method int32 x = Exp.constant (Const.int32 x) 90 | method int64 x = Exp.constant (Const.int64 x) 91 | method nativeint x = Exp.constant (Const.nativeint x) 92 | end 93 | 94 | class pat_builder = 95 | object 96 | method record ty x = precord ~closed:Closed (List.map (fun (l, e) -> prefix ty l, e) x) 97 | method constr ty (c, args) = pconstr (prefix ty c) args 98 | method list l = plist l 99 | method tuple l = ptuple l 100 | method int i = pint i 101 | method string s = pstr s 102 | method char c = pchar c 103 | method int32 x = Pat.constant (Const.int32 x) 104 | method int64 x = Pat.constant (Const.int64 x) 105 | method nativeint x = Pat.constant (Const.nativeint x) 106 | end 107 | 108 | 109 | let get_exp loc = function 110 | | PStr [ {pstr_desc=Pstr_eval (e, _); _} ] -> e 111 | | _ -> 112 | Format.eprintf "%aError: Expression expected@." 113 | Location.print_loc loc; 114 | exit 2 115 | 116 | let get_typ loc = function 117 | | PTyp t -> t 118 | | _ -> 119 | Format.eprintf "%aError: Type expected@." 120 | Location.print_loc loc; 121 | exit 2 122 | 123 | let get_pat loc = function 124 | | PPat (t, None) -> t 125 | | _ -> 126 | Format.eprintf "%aError: Pattern expected@." 127 | Location.print_loc loc; 128 | exit 2 129 | 130 | let exp_lifter loc map = 131 | let map = map.Ast_mapper.expr map in 132 | object 133 | inherit [_] Ast_lifter_406.lifter as super 134 | inherit exp_builder 135 | 136 | (* Special support for location in the generated AST *) 137 | method! lift_Location_t _ = loc 138 | 139 | (* Support for antiquotations *) 140 | method! lift_Parsetree_expression = function 141 | | {pexp_desc=Pexp_extension({txt="e";loc}, e); _} -> map (get_exp loc e) 142 | | x -> super # lift_Parsetree_expression x 143 | 144 | method! lift_Parsetree_pattern = function 145 | | {ppat_desc=Ppat_extension({txt="p";loc}, e); _} -> map (get_exp loc e) 146 | | x -> super # lift_Parsetree_pattern x 147 | 148 | method! lift_Parsetree_structure str = 149 | List.fold_right 150 | (function 151 | | {pstr_desc=Pstr_extension(({txt="s";loc}, e), _); _} -> 152 | append (get_exp loc e) 153 | | x -> 154 | cons (super # lift_Parsetree_structure_item x)) 155 | str (nil ()) 156 | 157 | method! lift_Parsetree_signature sign = 158 | List.fold_right 159 | (function 160 | | {psig_desc=Psig_extension(({txt="s";loc}, e), _); _} -> 161 | append (get_exp loc e) 162 | | x -> 163 | cons (super # lift_Parsetree_signature_item x)) 164 | sign (nil ()) 165 | 166 | method! lift_Parsetree_core_type = function 167 | | {ptyp_desc=Ptyp_extension({txt="t";loc}, e); _} -> map (get_exp loc e) 168 | | x -> super # lift_Parsetree_core_type x 169 | end 170 | 171 | let pat_lifter map = 172 | let map = map.Ast_mapper.pat map in 173 | object 174 | inherit [_] Ast_lifter_406.lifter as super 175 | inherit pat_builder 176 | 177 | (* Special support for location and attributes in the generated AST *) 178 | method! lift_Location_t _ = Pat.any () 179 | method! lift_Parsetree_attributes _ = Pat.any () 180 | 181 | (* Support for antiquotations *) 182 | method! lift_Parsetree_expression = function 183 | | {pexp_desc=Pexp_extension({txt="e";loc}, e); _} -> map (get_pat loc e) 184 | | x -> super # lift_Parsetree_expression x 185 | 186 | method! lift_Parsetree_pattern = function 187 | | {ppat_desc=Ppat_extension({txt="p";loc}, e); _} -> map (get_pat loc e) 188 | | x -> super # lift_Parsetree_pattern x 189 | 190 | method! lift_Parsetree_core_type = function 191 | | {ptyp_desc=Ptyp_extension({txt="t";loc}, e); _} -> map (get_pat loc e) 192 | | x -> super # lift_Parsetree_core_type x 193 | end 194 | 195 | let loc = ref (Exp.field (evar "Ast_helper.default_loc") (lid "contents")) 196 | 197 | let handle_attr = function 198 | | {txt="metaloc";loc=l}, e -> loc := get_exp l e 199 | | _ -> () 200 | 201 | let with_loc ?(attrs = []) f = 202 | let old_loc = !loc in 203 | List.iter handle_attr attrs; 204 | let r = f () in 205 | loc := old_loc; 206 | r 207 | 208 | let expander _config _cookies = 209 | let open Ast_mapper in 210 | let super = default_mapper in 211 | let expr this e = 212 | with_loc ~attrs:e.pexp_attributes 213 | (fun () -> 214 | match e.pexp_desc with 215 | | Pexp_extension({txt="expr";loc=l}, e) -> 216 | (exp_lifter !loc this) # lift_Parsetree_expression (get_exp l e) 217 | | Pexp_extension({txt="pat";loc=l}, e) -> 218 | (exp_lifter !loc this) # lift_Parsetree_pattern (get_pat l e) 219 | | Pexp_extension({txt="str";_}, PStr e) -> 220 | (exp_lifter !loc this) # lift_Parsetree_structure e 221 | | Pexp_extension({txt="stri";_}, PStr [e]) -> 222 | (exp_lifter !loc this) # lift_Parsetree_structure_item e 223 | | Pexp_extension({txt="sig";_}, PSig e) -> 224 | (exp_lifter !loc this) # lift_Parsetree_signature e 225 | | Pexp_extension({txt="sigi";_}, PSig [e]) -> 226 | (exp_lifter !loc this) # lift_Parsetree_signature_item e 227 | | Pexp_extension({txt="type";loc=l}, e) -> 228 | (exp_lifter !loc this) # lift_Parsetree_core_type (get_typ l e) 229 | | _ -> 230 | super.expr this e 231 | ) 232 | and pat this p = 233 | with_loc ~attrs:p.ppat_attributes 234 | (fun () -> 235 | match p.ppat_desc with 236 | | Ppat_extension({txt="expr";loc=l}, e) -> 237 | (pat_lifter this) # lift_Parsetree_expression (get_exp l e) 238 | | Ppat_extension({txt="pat";loc=l}, e) -> 239 | (pat_lifter this) # lift_Parsetree_pattern (get_pat l e) 240 | | Ppat_extension({txt="str";_}, PStr e) -> 241 | (pat_lifter this) # lift_Parsetree_structure e 242 | | Ppat_extension({txt="stri";_}, PStr [e]) -> 243 | (pat_lifter this) # lift_Parsetree_structure_item e 244 | | Ppat_extension({txt="sig";_}, PSig e) -> 245 | (pat_lifter this) # lift_Parsetree_signature e 246 | | Ppat_extension({txt="sigi";_}, PSig [e]) -> 247 | (pat_lifter this) # lift_Parsetree_signature_item e 248 | | Ppat_extension({txt="type";loc=l}, e) -> 249 | (pat_lifter this) # lift_Parsetree_core_type (get_typ l e) 250 | | _ -> 251 | super.pat this p 252 | ) 253 | and structure this l = 254 | with_loc 255 | (fun () -> super.structure this l) 256 | 257 | and structure_item this x = 258 | begin match x.pstr_desc with 259 | | Pstr_attribute x -> handle_attr x 260 | | _ -> () 261 | end; 262 | super.structure_item this x 263 | 264 | and signature this l = 265 | with_loc 266 | (fun () -> super.signature this l) 267 | 268 | and signature_item this x = 269 | begin match x.psig_desc with 270 | | Psig_attribute x -> handle_attr x 271 | | _ -> () 272 | end; 273 | super.signature_item this x 274 | 275 | in 276 | {super with expr; pat; structure; structure_item; signature; signature_item} 277 | 278 | let () = 279 | let open Migrate_parsetree in 280 | Driver.register ~name:"metaquot_406" Versions.ocaml_406 expander 281 | end 282 | -------------------------------------------------------------------------------- /ppx_metaquot_407.ml: -------------------------------------------------------------------------------- 1 | open Migrate_parsetree.Ast_407 2 | 3 | (* This file is part of the ppx_tools package. It is released *) 4 | (* under the terms of the MIT license (see LICENSE file). *) 5 | (* Copyright 2013 Alain Frisch and LexiFi *) 6 | 7 | (* A -ppx rewriter to be used to write Parsetree-generating code 8 | (including other -ppx rewriters) using concrete syntax. 9 | 10 | We support the following extensions in expression position: 11 | 12 | [%expr ...] maps to code which creates the expression represented by ... 13 | [%pat? ...] maps to code which creates the pattern represented by ... 14 | [%str ...] maps to code which creates the structure represented by ... 15 | [%stri ...] maps to code which creates the structure item represented by ... 16 | [%sig: ...] maps to code which creates the signature represented by ... 17 | [%sigi: ...] maps to code which creates the signature item represented by ... 18 | [%type: ...] maps to code which creates the core type represented by ... 19 | 20 | Quoted code can refer to expressions representing AST fragments, 21 | using the following extensions: 22 | 23 | [%e ...] where ... is an expression of type Parsetree.expression 24 | [%t ...] where ... is an expression of type Parsetree.core_type 25 | [%p ...] where ... is an expression of type Parsetree.pattern 26 | [%%s ...] where ... is an expression of type Parsetree.structure 27 | or Parsetree.signature depending on the context. 28 | 29 | 30 | All locations generated by the meta quotation are by default set 31 | to [Ast_helper.default_loc]. This can be overriden by providing a custom 32 | expression which will be inserted whereever a location is required 33 | in the generated AST. This expression can be specified globally 34 | (for the current structure) as a structure item attribute: 35 | 36 | ;;[@@metaloc ...] 37 | 38 | or locally for the scope of an expression: 39 | 40 | e [@metaloc ...] 41 | 42 | 43 | 44 | Support is also provided to use concrete syntax in pattern 45 | position. The location and attribute fields are currently ignored 46 | by patterns generated from meta quotations. 47 | 48 | We support the following extensions in pattern position: 49 | 50 | [%expr ...] maps to code which creates the expression represented by ... 51 | [%pat? ...] maps to code which creates the pattern represented by ... 52 | [%str ...] maps to code which creates the structure represented by ... 53 | [%type: ...] maps to code which creates the core type represented by ... 54 | 55 | Quoted code can refer to expressions representing AST fragments, 56 | using the following extensions: 57 | 58 | [%e? ...] where ... is a pattern of type Parsetree.expression 59 | [%t? ...] where ... is a pattern of type Parsetree.core_type 60 | [%p? ...] where ... is a pattern of type Parsetree.pattern 61 | 62 | *) 63 | 64 | module Main : sig end = struct 65 | open Asttypes 66 | open Parsetree 67 | open Ast_helper 68 | open Ast_convenience_407 69 | 70 | let prefix ty s = 71 | let open Longident in 72 | match parse ty with 73 | | Ldot(m, _) -> String.concat "." (Longident.flatten m) ^ "." ^ s 74 | | _ -> s 75 | 76 | let append ?loc ?attrs e e' = 77 | let fn = Location.mknoloc (Longident.(Ldot (Lident "List", "append"))) in 78 | Exp.apply ?loc ?attrs (Exp.ident fn) [Nolabel, e; Nolabel, e'] 79 | 80 | class exp_builder = 81 | object 82 | method record ty x = record (List.map (fun (l, e) -> prefix ty l, e) x) 83 | method constr ty (c, args) = constr (prefix ty c) args 84 | method list l = list l 85 | method tuple l = tuple l 86 | method int i = int i 87 | method string s = str s 88 | method char c = char c 89 | method int32 x = Exp.constant (Const.int32 x) 90 | method int64 x = Exp.constant (Const.int64 x) 91 | method nativeint x = Exp.constant (Const.nativeint x) 92 | end 93 | 94 | class pat_builder = 95 | object 96 | method record ty x = precord ~closed:Closed (List.map (fun (l, e) -> prefix ty l, e) x) 97 | method constr ty (c, args) = pconstr (prefix ty c) args 98 | method list l = plist l 99 | method tuple l = ptuple l 100 | method int i = pint i 101 | method string s = pstr s 102 | method char c = pchar c 103 | method int32 x = Pat.constant (Const.int32 x) 104 | method int64 x = Pat.constant (Const.int64 x) 105 | method nativeint x = Pat.constant (Const.nativeint x) 106 | end 107 | 108 | 109 | let get_exp loc = function 110 | | PStr [ {pstr_desc=Pstr_eval (e, _); _} ] -> e 111 | | _ -> 112 | Format.eprintf "%aError: Expression expected@." 113 | Location.print_loc loc; 114 | exit 2 115 | 116 | let get_typ loc = function 117 | | PTyp t -> t 118 | | _ -> 119 | Format.eprintf "%aError: Type expected@." 120 | Location.print_loc loc; 121 | exit 2 122 | 123 | let get_pat loc = function 124 | | PPat (t, None) -> t 125 | | _ -> 126 | Format.eprintf "%aError: Pattern expected@." 127 | Location.print_loc loc; 128 | exit 2 129 | 130 | let exp_lifter loc map = 131 | let map = map.Ast_mapper.expr map in 132 | object 133 | inherit [_] Ast_lifter_407.lifter as super 134 | inherit exp_builder 135 | 136 | (* Special support for location in the generated AST *) 137 | method! lift_Location_t _ = loc 138 | 139 | (* Support for antiquotations *) 140 | method! lift_Parsetree_expression = function 141 | | {pexp_desc=Pexp_extension({txt="e";loc}, e); _} -> map (get_exp loc e) 142 | | x -> super # lift_Parsetree_expression x 143 | 144 | method! lift_Parsetree_pattern = function 145 | | {ppat_desc=Ppat_extension({txt="p";loc}, e); _} -> map (get_exp loc e) 146 | | x -> super # lift_Parsetree_pattern x 147 | 148 | method! lift_Parsetree_structure str = 149 | List.fold_right 150 | (function 151 | | {pstr_desc=Pstr_extension(({txt="s";loc}, e), _); _} -> 152 | append (get_exp loc e) 153 | | x -> 154 | cons (super # lift_Parsetree_structure_item x)) 155 | str (nil ()) 156 | 157 | method! lift_Parsetree_signature sign = 158 | List.fold_right 159 | (function 160 | | {psig_desc=Psig_extension(({txt="s";loc}, e), _); _} -> 161 | append (get_exp loc e) 162 | | x -> 163 | cons (super # lift_Parsetree_signature_item x)) 164 | sign (nil ()) 165 | 166 | method! lift_Parsetree_core_type = function 167 | | {ptyp_desc=Ptyp_extension({txt="t";loc}, e); _} -> map (get_exp loc e) 168 | | x -> super # lift_Parsetree_core_type x 169 | end 170 | 171 | let pat_lifter map = 172 | let map = map.Ast_mapper.pat map in 173 | object 174 | inherit [_] Ast_lifter_407.lifter as super 175 | inherit pat_builder 176 | 177 | (* Special support for location and attributes in the generated AST *) 178 | method! lift_Location_t _ = Pat.any () 179 | method! lift_Parsetree_attributes _ = Pat.any () 180 | 181 | (* Support for antiquotations *) 182 | method! lift_Parsetree_expression = function 183 | | {pexp_desc=Pexp_extension({txt="e";loc}, e); _} -> map (get_pat loc e) 184 | | x -> super # lift_Parsetree_expression x 185 | 186 | method! lift_Parsetree_pattern = function 187 | | {ppat_desc=Ppat_extension({txt="p";loc}, e); _} -> map (get_pat loc e) 188 | | x -> super # lift_Parsetree_pattern x 189 | 190 | method! lift_Parsetree_core_type = function 191 | | {ptyp_desc=Ptyp_extension({txt="t";loc}, e); _} -> map (get_pat loc e) 192 | | x -> super # lift_Parsetree_core_type x 193 | end 194 | 195 | let loc = ref (Exp.field (evar "Ast_helper.default_loc") (lid "contents")) 196 | 197 | let handle_attr = function 198 | | {txt="metaloc";loc=l}, e -> loc := get_exp l e 199 | | _ -> () 200 | 201 | let with_loc ?(attrs = []) f = 202 | let old_loc = !loc in 203 | List.iter handle_attr attrs; 204 | let r = f () in 205 | loc := old_loc; 206 | r 207 | 208 | let expander _config _cookies = 209 | let open Ast_mapper in 210 | let super = default_mapper in 211 | let expr this e = 212 | with_loc ~attrs:e.pexp_attributes 213 | (fun () -> 214 | match e.pexp_desc with 215 | | Pexp_extension({txt="expr";loc=l}, e) -> 216 | (exp_lifter !loc this) # lift_Parsetree_expression (get_exp l e) 217 | | Pexp_extension({txt="pat";loc=l}, e) -> 218 | (exp_lifter !loc this) # lift_Parsetree_pattern (get_pat l e) 219 | | Pexp_extension({txt="str";_}, PStr e) -> 220 | (exp_lifter !loc this) # lift_Parsetree_structure e 221 | | Pexp_extension({txt="stri";_}, PStr [e]) -> 222 | (exp_lifter !loc this) # lift_Parsetree_structure_item e 223 | | Pexp_extension({txt="sig";_}, PSig e) -> 224 | (exp_lifter !loc this) # lift_Parsetree_signature e 225 | | Pexp_extension({txt="sigi";_}, PSig [e]) -> 226 | (exp_lifter !loc this) # lift_Parsetree_signature_item e 227 | | Pexp_extension({txt="type";loc=l}, e) -> 228 | (exp_lifter !loc this) # lift_Parsetree_core_type (get_typ l e) 229 | | _ -> 230 | super.expr this e 231 | ) 232 | and pat this p = 233 | with_loc ~attrs:p.ppat_attributes 234 | (fun () -> 235 | match p.ppat_desc with 236 | | Ppat_extension({txt="expr";loc=l}, e) -> 237 | (pat_lifter this) # lift_Parsetree_expression (get_exp l e) 238 | | Ppat_extension({txt="pat";loc=l}, e) -> 239 | (pat_lifter this) # lift_Parsetree_pattern (get_pat l e) 240 | | Ppat_extension({txt="str";_}, PStr e) -> 241 | (pat_lifter this) # lift_Parsetree_structure e 242 | | Ppat_extension({txt="stri";_}, PStr [e]) -> 243 | (pat_lifter this) # lift_Parsetree_structure_item e 244 | | Ppat_extension({txt="sig";_}, PSig e) -> 245 | (pat_lifter this) # lift_Parsetree_signature e 246 | | Ppat_extension({txt="sigi";_}, PSig [e]) -> 247 | (pat_lifter this) # lift_Parsetree_signature_item e 248 | | Ppat_extension({txt="type";loc=l}, e) -> 249 | (pat_lifter this) # lift_Parsetree_core_type (get_typ l e) 250 | | _ -> 251 | super.pat this p 252 | ) 253 | and structure this l = 254 | with_loc 255 | (fun () -> super.structure this l) 256 | 257 | and structure_item this x = 258 | begin match x.pstr_desc with 259 | | Pstr_attribute x -> handle_attr x 260 | | _ -> () 261 | end; 262 | super.structure_item this x 263 | 264 | and signature this l = 265 | with_loc 266 | (fun () -> super.signature this l) 267 | 268 | and signature_item this x = 269 | begin match x.psig_desc with 270 | | Psig_attribute x -> handle_attr x 271 | | _ -> () 272 | end; 273 | super.signature_item this x 274 | 275 | in 276 | {super with expr; pat; structure; structure_item; signature; signature_item} 277 | 278 | let () = 279 | let open Migrate_parsetree in 280 | Driver.register ~name:"metaquot_407" Versions.ocaml_407 expander 281 | end 282 | -------------------------------------------------------------------------------- /ppx_metaquot_408.ml: -------------------------------------------------------------------------------- 1 | open Migrate_parsetree.Ast_408 2 | 3 | (* This file is part of the ppx_tools package. It is released *) 4 | (* under the terms of the MIT license (see LICENSE file). *) 5 | (* Copyright 2013 Alain Frisch and LexiFi *) 6 | 7 | (* A -ppx rewriter to be used to write Parsetree-generating code 8 | (including other -ppx rewriters) using concrete syntax. 9 | 10 | We support the following extensions in expression position: 11 | 12 | [%expr ...] maps to code which creates the expression represented by ... 13 | [%pat? ...] maps to code which creates the pattern represented by ... 14 | [%str ...] maps to code which creates the structure represented by ... 15 | [%stri ...] maps to code which creates the structure item represented by ... 16 | [%sig: ...] maps to code which creates the signature represented by ... 17 | [%sigi: ...] maps to code which creates the signature item represented by ... 18 | [%type: ...] maps to code which creates the core type represented by ... 19 | 20 | Quoted code can refer to expressions representing AST fragments, 21 | using the following extensions: 22 | 23 | [%e ...] where ... is an expression of type Parsetree.expression 24 | [%t ...] where ... is an expression of type Parsetree.core_type 25 | [%p ...] where ... is an expression of type Parsetree.pattern 26 | [%%s ...] where ... is an expression of type Parsetree.structure 27 | or Parsetree.signature depending on the context. 28 | 29 | 30 | All locations generated by the meta quotation are by default set 31 | to [Ast_helper.default_loc]. This can be overriden by providing a custom 32 | expression which will be inserted whereever a location is required 33 | in the generated AST. This expression can be specified globally 34 | (for the current structure) as a structure item attribute: 35 | 36 | ;;[@@metaloc ...] 37 | 38 | or locally for the scope of an expression: 39 | 40 | e [@metaloc ...] 41 | 42 | 43 | 44 | Support is also provided to use concrete syntax in pattern 45 | position. The location and attribute fields are currently ignored 46 | by patterns generated from meta quotations. 47 | 48 | We support the following extensions in pattern position: 49 | 50 | [%expr ...] maps to code which creates the expression represented by ... 51 | [%pat? ...] maps to code which creates the pattern represented by ... 52 | [%str ...] maps to code which creates the structure represented by ... 53 | [%type: ...] maps to code which creates the core type represented by ... 54 | 55 | Quoted code can refer to expressions representing AST fragments, 56 | using the following extensions: 57 | 58 | [%e? ...] where ... is a pattern of type Parsetree.expression 59 | [%t? ...] where ... is a pattern of type Parsetree.core_type 60 | [%p? ...] where ... is a pattern of type Parsetree.pattern 61 | 62 | *) 63 | 64 | module Main : sig end = struct 65 | open Asttypes 66 | open Parsetree 67 | open Ast_helper 68 | open Ast_convenience_408 69 | 70 | let prefix ty s = 71 | let open Longident in 72 | match parse ty with 73 | | Ldot(m, _) -> String.concat "." (Longident.flatten m) ^ "." ^ s 74 | | _ -> s 75 | 76 | let append ?loc ?attrs e e' = 77 | let fn = Location.mknoloc (Longident.(Ldot (Lident "List", "append"))) in 78 | Exp.apply ?loc ?attrs (Exp.ident fn) [Nolabel, e; Nolabel, e'] 79 | 80 | class exp_builder = 81 | object 82 | method record ty x = record (List.map (fun (l, e) -> prefix ty l, e) x) 83 | method constr ty (c, args) = constr (prefix ty c) args 84 | method list l = list l 85 | method tuple l = tuple l 86 | method int i = int i 87 | method string s = str s 88 | method char c = char c 89 | method int32 x = Exp.constant (Const.int32 x) 90 | method int64 x = Exp.constant (Const.int64 x) 91 | method nativeint x = Exp.constant (Const.nativeint x) 92 | end 93 | 94 | class pat_builder = 95 | object 96 | method record ty x = precord ~closed:Closed (List.map (fun (l, e) -> prefix ty l, e) x) 97 | method constr ty (c, args) = pconstr (prefix ty c) args 98 | method list l = plist l 99 | method tuple l = ptuple l 100 | method int i = pint i 101 | method string s = pstr s 102 | method char c = pchar c 103 | method int32 x = Pat.constant (Const.int32 x) 104 | method int64 x = Pat.constant (Const.int64 x) 105 | method nativeint x = Pat.constant (Const.nativeint x) 106 | end 107 | 108 | 109 | let get_exp loc = function 110 | | PStr [ {pstr_desc=Pstr_eval (e, _); _} ] -> e 111 | | _ -> 112 | Format.eprintf "%aError: Expression expected@." 113 | Location.print_loc loc; 114 | exit 2 115 | 116 | let get_typ loc = function 117 | | PTyp t -> t 118 | | _ -> 119 | Format.eprintf "%aError: Type expected@." 120 | Location.print_loc loc; 121 | exit 2 122 | 123 | let get_pat loc = function 124 | | PPat (t, None) -> t 125 | | _ -> 126 | Format.eprintf "%aError: Pattern expected@." 127 | Location.print_loc loc; 128 | exit 2 129 | 130 | let exp_lifter loc map = 131 | let map = map.Ast_mapper.expr map in 132 | object 133 | inherit [_] Ast_lifter_408.lifter as super 134 | inherit exp_builder 135 | 136 | (* Special support for location in the generated AST *) 137 | method! lift_Location_t _ = loc 138 | 139 | (* Support for antiquotations *) 140 | method! lift_Parsetree_expression = function 141 | | {pexp_desc=Pexp_extension({txt="e";loc}, e); _} -> map (get_exp loc e) 142 | | x -> super # lift_Parsetree_expression x 143 | 144 | method! lift_Parsetree_pattern = function 145 | | {ppat_desc=Ppat_extension({txt="p";loc}, e); _} -> map (get_exp loc e) 146 | | x -> super # lift_Parsetree_pattern x 147 | 148 | method! lift_Parsetree_structure str = 149 | List.fold_right 150 | (function 151 | | {pstr_desc=Pstr_extension(({txt="s";loc}, e), _); _} -> 152 | append (get_exp loc e) 153 | | x -> 154 | cons (super # lift_Parsetree_structure_item x)) 155 | str (nil ()) 156 | 157 | method! lift_Parsetree_signature sign = 158 | List.fold_right 159 | (function 160 | | {psig_desc=Psig_extension(({txt="s";loc}, e), _); _} -> 161 | append (get_exp loc e) 162 | | x -> 163 | cons (super # lift_Parsetree_signature_item x)) 164 | sign (nil ()) 165 | 166 | method! lift_Parsetree_core_type = function 167 | | {ptyp_desc=Ptyp_extension({txt="t";loc}, e); _} -> map (get_exp loc e) 168 | | x -> super # lift_Parsetree_core_type x 169 | end 170 | 171 | let pat_lifter map = 172 | let map = map.Ast_mapper.pat map in 173 | object 174 | inherit [_] Ast_lifter_408.lifter as super 175 | inherit pat_builder 176 | 177 | (* Special support for location and attributes in the generated AST *) 178 | method! lift_Location_t _ = Pat.any () 179 | method! lift_Parsetree_attributes _ = Pat.any () 180 | method! lift_loc_stack _ = Pat.any () 181 | 182 | 183 | (* Support for antiquotations *) 184 | method! lift_Parsetree_expression = function 185 | | {pexp_desc=Pexp_extension({txt="e";loc}, e); _} -> map (get_pat loc e) 186 | | x -> super # lift_Parsetree_expression x 187 | 188 | method! lift_Parsetree_pattern = function 189 | | {ppat_desc=Ppat_extension({txt="p";loc}, e); _} -> map (get_pat loc e) 190 | | x -> super # lift_Parsetree_pattern x 191 | 192 | method! lift_Parsetree_core_type = function 193 | | {ptyp_desc=Ptyp_extension({txt="t";loc}, e); _} -> map (get_pat loc e) 194 | | x -> super # lift_Parsetree_core_type x 195 | end 196 | 197 | let loc = ref (Exp.field (evar "Ast_helper.default_loc") (lid "contents")) 198 | 199 | let handle_attr = function 200 | | { attr_name = {txt="metaloc";loc=l} 201 | ; attr_payload = e 202 | ; attr_loc = _ } -> loc := get_exp l e 203 | | _ -> () 204 | 205 | let with_loc ?(attrs = []) f = 206 | let old_loc = !loc in 207 | List.iter handle_attr attrs; 208 | let r = f () in 209 | loc := old_loc; 210 | r 211 | 212 | let expander _config _cookies = 213 | let open Ast_mapper in 214 | let super = default_mapper in 215 | let expr this e = 216 | with_loc ~attrs:e.pexp_attributes 217 | (fun () -> 218 | match e.pexp_desc with 219 | | Pexp_extension({txt="expr";loc=l}, e) -> 220 | (exp_lifter !loc this) # lift_Parsetree_expression (get_exp l e) 221 | | Pexp_extension({txt="pat";loc=l}, e) -> 222 | (exp_lifter !loc this) # lift_Parsetree_pattern (get_pat l e) 223 | | Pexp_extension({txt="str";_}, PStr e) -> 224 | (exp_lifter !loc this) # lift_Parsetree_structure e 225 | | Pexp_extension({txt="stri";_}, PStr [e]) -> 226 | (exp_lifter !loc this) # lift_Parsetree_structure_item e 227 | | Pexp_extension({txt="sig";_}, PSig e) -> 228 | (exp_lifter !loc this) # lift_Parsetree_signature e 229 | | Pexp_extension({txt="sigi";_}, PSig [e]) -> 230 | (exp_lifter !loc this) # lift_Parsetree_signature_item e 231 | | Pexp_extension({txt="type";loc=l}, e) -> 232 | (exp_lifter !loc this) # lift_Parsetree_core_type (get_typ l e) 233 | | _ -> 234 | super.expr this e 235 | ) 236 | and pat this p = 237 | with_loc ~attrs:p.ppat_attributes 238 | (fun () -> 239 | match p.ppat_desc with 240 | | Ppat_extension({txt="expr";loc=l}, e) -> 241 | (pat_lifter this) # lift_Parsetree_expression (get_exp l e) 242 | | Ppat_extension({txt="pat";loc=l}, e) -> 243 | (pat_lifter this) # lift_Parsetree_pattern (get_pat l e) 244 | | Ppat_extension({txt="str";_}, PStr e) -> 245 | (pat_lifter this) # lift_Parsetree_structure e 246 | | Ppat_extension({txt="stri";_}, PStr [e]) -> 247 | (pat_lifter this) # lift_Parsetree_structure_item e 248 | | Ppat_extension({txt="sig";_}, PSig e) -> 249 | (pat_lifter this) # lift_Parsetree_signature e 250 | | Ppat_extension({txt="sigi";_}, PSig [e]) -> 251 | (pat_lifter this) # lift_Parsetree_signature_item e 252 | | Ppat_extension({txt="type";loc=l}, e) -> 253 | (pat_lifter this) # lift_Parsetree_core_type (get_typ l e) 254 | | _ -> 255 | super.pat this p 256 | ) 257 | and structure this l = 258 | with_loc 259 | (fun () -> super.structure this l) 260 | 261 | and structure_item this x = 262 | begin match x.pstr_desc with 263 | | Pstr_attribute x -> handle_attr x 264 | | _ -> () 265 | end; 266 | super.structure_item this x 267 | 268 | and signature this l = 269 | with_loc 270 | (fun () -> super.signature this l) 271 | 272 | and signature_item this x = 273 | begin match x.psig_desc with 274 | | Psig_attribute x -> handle_attr x 275 | | _ -> () 276 | end; 277 | super.signature_item this x 278 | 279 | in 280 | {super with expr; pat; structure; structure_item; signature; signature_item} 281 | 282 | let () = 283 | let open Migrate_parsetree in 284 | Driver.register ~name:"metaquot_408" Versions.ocaml_408 expander 285 | end 286 | -------------------------------------------------------------------------------- /ppx_metaquot_run.ml: -------------------------------------------------------------------------------- 1 | let () = Migrate_parsetree.Driver.run_main () 2 | -------------------------------------------------------------------------------- /ppx_tools_402.ml: -------------------------------------------------------------------------------- 1 | module Ast_convenience = Ast_convenience_402 2 | module Ast_mapper_class = Ast_mapper_class_402 3 | -------------------------------------------------------------------------------- /ppx_tools_403.ml: -------------------------------------------------------------------------------- 1 | module Ast_convenience = Ast_convenience_403 2 | module Ast_mapper_class = Ast_mapper_class_403 3 | -------------------------------------------------------------------------------- /ppx_tools_404.ml: -------------------------------------------------------------------------------- 1 | module Ast_convenience = Ast_convenience_404 2 | module Ast_mapper_class = Ast_mapper_class_404 3 | -------------------------------------------------------------------------------- /ppx_tools_405.ml: -------------------------------------------------------------------------------- 1 | module Ast_convenience = Ast_convenience_405 2 | module Ast_mapper_class = Ast_mapper_class_405 3 | -------------------------------------------------------------------------------- /ppx_tools_406.ml: -------------------------------------------------------------------------------- 1 | module Ast_convenience = Ast_convenience_406 2 | module Ast_mapper_class = Ast_mapper_class_406 3 | -------------------------------------------------------------------------------- /ppx_tools_407.ml: -------------------------------------------------------------------------------- 1 | module Ast_convenience = Ast_convenience_407 2 | module Ast_mapper_class = Ast_mapper_class_407 3 | -------------------------------------------------------------------------------- /ppx_tools_408.ml: -------------------------------------------------------------------------------- 1 | module Ast_convenience = Ast_convenience_408 2 | module Ast_mapper_class = Ast_mapper_class_408 3 | -------------------------------------------------------------------------------- /ppx_tools_409.ml: -------------------------------------------------------------------------------- 1 | module Ast_convenience = Ast_convenience_409 2 | module Ast_mapper_class = Ast_mapper_class_409 3 | -------------------------------------------------------------------------------- /ppx_tools_410.ml: -------------------------------------------------------------------------------- 1 | module Ast_convenience = Ast_convenience_410 2 | module Ast_mapper_class = Ast_mapper_class_410 3 | -------------------------------------------------------------------------------- /ppx_tools_411.ml: -------------------------------------------------------------------------------- 1 | module Ast_convenience = Ast_convenience_411 2 | module Ast_mapper_class = Ast_mapper_class_411 3 | -------------------------------------------------------------------------------- /ppx_tools_versioned.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | version: "5.4.0" 3 | maintainer: "frederic.bour@lakaban.net" 4 | authors: [ 5 | "Frédéric Bour " 6 | "Alain Frisch " 7 | ] 8 | license: "MIT" 9 | homepage: "https://github.com/ocaml-ppx/ppx_tools_versioned" 10 | bug-reports: "https://github.com/ocaml-ppx/ppx_tools_versioned/issues" 11 | dev-repo: "git://github.com/ocaml-ppx/ppx_tools_versioned.git" 12 | tags: [ "syntax" ] 13 | build: [ 14 | ["dune" "subst"] {pinned} 15 | ["dune" "build" "-p" name "-j" jobs] 16 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 17 | ] 18 | depends: [ 19 | "ocaml" {>= "4.02.0"} 20 | "dune" {>= "1.0"} 21 | "ocaml-migrate-parsetree" {>= "1.7.0"} 22 | ] 23 | synopsis: "A variant of ppx_tools based on ocaml-migrate-parsetree" 24 | --------------------------------------------------------------------------------