├── .gitignore ├── LICENSE.txt ├── Makefile ├── README.md ├── _tags ├── bin └── main.ml ├── lib ├── camlp4_to_ppx.ml └── camlp4_to_ppx.mli └── plugins ├── pa_bench.ml ├── pa_js.ml ├── pa_lwt.ml ├── pa_macro.ml ├── pa_ounit.ml └── pa_type_conv.ml /.gitignore: -------------------------------------------------------------------------------- 1 | main.native 2 | _build 3 | -------------------------------------------------------------------------------- /LICENSE.txt: -------------------------------------------------------------------------------- 1 | 2 | Apache License 3 | Version 2.0, January 2004 4 | http://www.apache.org/licenses/ 5 | 6 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 7 | 8 | 1. Definitions. 9 | 10 | "License" shall mean the terms and conditions for use, reproduction, 11 | and distribution as defined by Sections 1 through 9 of this document. 12 | 13 | "Licensor" shall mean the copyright owner or entity authorized by 14 | the copyright owner that is granting the License. 15 | 16 | "Legal Entity" shall mean the union of the acting entity and all 17 | other entities that control, are controlled by, or are under common 18 | control with that entity. For the purposes of this definition, 19 | "control" means (i) the power, direct or indirect, to cause the 20 | direction or management of such entity, whether by contract or 21 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 22 | outstanding shares, or (iii) beneficial ownership of such entity. 23 | 24 | "You" (or "Your") shall mean an individual or Legal Entity 25 | exercising permissions granted by this License. 26 | 27 | "Source" form shall mean the preferred form for making modifications, 28 | including but not limited to software source code, documentation 29 | source, and configuration files. 30 | 31 | "Object" form shall mean any form resulting from mechanical 32 | transformation or translation of a Source form, including but 33 | not limited to compiled object code, generated documentation, 34 | and conversions to other media types. 35 | 36 | "Work" shall mean the work of authorship, whether in Source or 37 | Object form, made available under the License, as indicated by a 38 | copyright notice that is included in or attached to the work 39 | (an example is provided in the Appendix below). 40 | 41 | "Derivative Works" shall mean any work, whether in Source or Object 42 | form, that is based on (or derived from) the Work and for which the 43 | editorial revisions, annotations, elaborations, or other modifications 44 | represent, as a whole, an original work of authorship. For the purposes 45 | of this License, Derivative Works shall not include works that remain 46 | separable from, or merely link (or bind by name) to the interfaces of, 47 | the Work and Derivative Works thereof. 48 | 49 | "Contribution" shall mean any work of authorship, including 50 | the original version of the Work and any modifications or additions 51 | to that Work or Derivative Works thereof, that is intentionally 52 | submitted to Licensor for inclusion in the Work by the copyright owner 53 | or by an individual or Legal Entity authorized to submit on behalf of 54 | the copyright owner. For the purposes of this definition, "submitted" 55 | means any form of electronic, verbal, or written communication sent 56 | to the Licensor or its representatives, including but not limited to 57 | communication on electronic mailing lists, source code control systems, 58 | and issue tracking systems that are managed by, or on behalf of, the 59 | Licensor for the purpose of discussing and improving the Work, but 60 | excluding communication that is conspicuously marked or otherwise 61 | designated in writing by the copyright owner as "Not a Contribution." 62 | 63 | "Contributor" shall mean Licensor and any individual or Legal Entity 64 | on behalf of whom a Contribution has been received by Licensor and 65 | subsequently incorporated within the Work. 66 | 67 | 2. Grant of Copyright License. Subject to the terms and conditions of 68 | this License, each Contributor hereby grants to You a perpetual, 69 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 70 | copyright license to reproduce, prepare Derivative Works of, 71 | publicly display, publicly perform, sublicense, and distribute the 72 | Work and such Derivative Works in Source or Object form. 73 | 74 | 3. Grant of Patent License. Subject to the terms and conditions of 75 | this License, each Contributor hereby grants to You a perpetual, 76 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 77 | (except as stated in this section) patent license to make, have made, 78 | use, offer to sell, sell, import, and otherwise transfer the Work, 79 | where such license applies only to those patent claims licensable 80 | by such Contributor that are necessarily infringed by their 81 | Contribution(s) alone or by combination of their Contribution(s) 82 | with the Work to which such Contribution(s) was submitted. If You 83 | institute patent litigation against any entity (including a 84 | cross-claim or counterclaim in a lawsuit) alleging that the Work 85 | or a Contribution incorporated within the Work constitutes direct 86 | or contributory patent infringement, then any patent licenses 87 | granted to You under this License for that Work shall terminate 88 | as of the date such litigation is filed. 89 | 90 | 4. Redistribution. You may reproduce and distribute copies of the 91 | Work or Derivative Works thereof in any medium, with or without 92 | modifications, and in Source or Object form, provided that You 93 | meet the following conditions: 94 | 95 | (a) You must give any other recipients of the Work or 96 | Derivative Works a copy of this License; and 97 | 98 | (b) You must cause any modified files to carry prominent notices 99 | stating that You changed the files; and 100 | 101 | (c) You must retain, in the Source form of any Derivative Works 102 | that You distribute, all copyright, patent, trademark, and 103 | attribution notices from the Source form of the Work, 104 | excluding those notices that do not pertain to any part of 105 | the Derivative Works; and 106 | 107 | (d) If the Work includes a "NOTICE" text file as part of its 108 | distribution, then any Derivative Works that You distribute must 109 | include a readable copy of the attribution notices contained 110 | within such NOTICE file, excluding those notices that do not 111 | pertain to any part of the Derivative Works, in at least one 112 | of the following places: within a NOTICE text file distributed 113 | as part of the Derivative Works; within the Source form or 114 | documentation, if provided along with the Derivative Works; or, 115 | within a display generated by the Derivative Works, if and 116 | wherever such third-party notices normally appear. The contents 117 | of the NOTICE file are for informational purposes only and 118 | do not modify the License. You may add Your own attribution 119 | notices within Derivative Works that You distribute, alongside 120 | or as an addendum to the NOTICE text from the Work, provided 121 | that such additional attribution notices cannot be construed 122 | as modifying the License. 123 | 124 | You may add Your own copyright statement to Your modifications and 125 | may provide additional or different license terms and conditions 126 | for use, reproduction, or distribution of Your modifications, or 127 | for any such Derivative Works as a whole, provided Your use, 128 | reproduction, and distribution of the Work otherwise complies with 129 | the conditions stated in this License. 130 | 131 | 5. Submission of Contributions. Unless You explicitly state otherwise, 132 | any Contribution intentionally submitted for inclusion in the Work 133 | by You to the Licensor shall be under the terms and conditions of 134 | this License, without any additional terms or conditions. 135 | Notwithstanding the above, nothing herein shall supersede or modify 136 | the terms of any separate license agreement you may have executed 137 | with Licensor regarding such Contributions. 138 | 139 | 6. Trademarks. This License does not grant permission to use the trade 140 | names, trademarks, service marks, or product names of the Licensor, 141 | except as required for reasonable and customary use in describing the 142 | origin of the Work and reproducing the content of the NOTICE file. 143 | 144 | 7. Disclaimer of Warranty. Unless required by applicable law or 145 | agreed to in writing, Licensor provides the Work (and each 146 | Contributor provides its Contributions) on an "AS IS" BASIS, 147 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 148 | implied, including, without limitation, any warranties or conditions 149 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 150 | PARTICULAR PURPOSE. You are solely responsible for determining the 151 | appropriateness of using or redistributing the Work and assume any 152 | risks associated with Your exercise of permissions under this License. 153 | 154 | 8. Limitation of Liability. In no event and under no legal theory, 155 | whether in tort (including negligence), contract, or otherwise, 156 | unless required by applicable law (such as deliberate and grossly 157 | negligent acts) or agreed to in writing, shall any Contributor be 158 | liable to You for damages, including any direct, indirect, special, 159 | incidental, or consequential damages of any character arising as a 160 | result of this License or out of the use or inability to use the 161 | Work (including but not limited to damages for loss of goodwill, 162 | work stoppage, computer failure or malfunction, or any and all 163 | other commercial damages or losses), even if such Contributor 164 | has been advised of the possibility of such damages. 165 | 166 | 9. Accepting Warranty or Additional Liability. While redistributing 167 | the Work or Derivative Works thereof, You may choose to offer, 168 | and charge a fee for, acceptance of support, warranty, indemnity, 169 | or other liability obligations and/or rights consistent with this 170 | License. However, in accepting such obligations, You may act only 171 | on Your own behalf and on Your sole responsibility, not on behalf 172 | of any other Contributor, and only if You agree to indemnify, 173 | defend, and hold each Contributor harmless for any liability 174 | incurred by, or claims asserted against, such Contributor by reason 175 | of your accepting any such warranty or additional liability. 176 | 177 | END OF TERMS AND CONDITIONS 178 | 179 | APPENDIX: How to apply the Apache License to your work. 180 | 181 | To apply the Apache License to your work, attach the following 182 | boilerplate notice, with the fields enclosed by brackets "[]" 183 | replaced with your own identifying information. (Don't include 184 | the brackets!) The text should be enclosed in the appropriate 185 | comment syntax for the file format. We also recommend that a 186 | file or class name and description of purpose be included on the 187 | same "printed page" as the copyright notice for easier 188 | identification within third-party archives. 189 | 190 | Copyright [yyyy] [name of copyright owner] 191 | 192 | Licensed under the Apache License, Version 2.0 (the "License"); 193 | you may not use this file except in compliance with the License. 194 | You may obtain a copy of the License at 195 | 196 | http://www.apache.org/licenses/LICENSE-2.0 197 | 198 | Unless required by applicable law or agreed to in writing, software 199 | distributed under the License is distributed on an "AS IS" BASIS, 200 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 201 | See the License for the specific language governing permissions and 202 | limitations under the License. 203 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | ocamlbuild bin/main.native 3 | 4 | clean: 5 | ocamlbuild -clean 6 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Camlp4 to PPX conversion tool 2 | ============================= 3 | 4 | The aim of this project is to automatically convert OCaml source files 5 | using camlp4 syntax extensions to their equivalent in the ppx world 6 | while preserving comments and the layout. We used a variation of this 7 | tool at Jane Street to convert our code base. 8 | 9 | For instance it will translate: 10 | 11 | ```ocaml 12 | type t = 13 | | A of int (* blah *) 14 | | B of string 15 | with sexp, bin_io 16 | 17 | let x = <:sexp_of< t * int >> (A 42, 10) 18 | ``` 19 | 20 | into: 21 | 22 | ```ocaml 23 | type t = 24 | | A of int (* blah *) 25 | | B of string 26 | [@@deriving sexp, bin_io] 27 | 28 | let x = [%sexp_of: t * int ] (A 42, 10) 29 | ``` 30 | 31 | For each syntax extension to convert a plugin needs to be written. 32 | 33 | Plugins 34 | ------- 35 | 36 | This repository has plugins for all old jane street camlp4 syntax extensions. 37 | The [ocsigen fork](https://github.com/ocsigen/camlp4-to-ppx/tree/ocsigen) has 38 | plugins for deriving, eliom, and other ocsigen related syntax extensions. 39 | 40 | How does it work? 41 | ----------------- 42 | 43 | It works by writing a dummy camlp4 syntax extension that only register 44 | substitutions using locations. After parsing the input file all the 45 | substitutions are applied to the original file and the result is 46 | printed. 47 | 48 | To add a new plugin, add a file to the plugins/ directory and the 49 | corresponding line in `bin/main.ml`. `pa_ounit.ml` should be a good 50 | model to understand how it works. 51 | -------------------------------------------------------------------------------- /_tags: -------------------------------------------------------------------------------- 1 | <**/*>: use_dynlink, use_camlp4_full 2 | <{lib,plugins}/*.ml>: camlp4of 3 | "lib": include 4 | "plugins": include 5 | -------------------------------------------------------------------------------- /bin/main.ml: -------------------------------------------------------------------------------- 1 | let () = Pa_macro.linkme 2 | let () = Pa_ounit.linkme 3 | let () = Pa_bench.linkme 4 | let () = Pa_type_conv.linkme 5 | let () = Pa_js.linkme 6 | 7 | let () = Camlp4_to_ppx.main () 8 | -------------------------------------------------------------------------------- /lib/camlp4_to_ppx.ml: -------------------------------------------------------------------------------- 1 | open Printf 2 | open StdLabels 3 | open Camlp4.PreCast 4 | open Syntax 5 | 6 | let module M = 7 | Camlp4OCamlParser.Make(Camlp4OCamlRevisedParser.Make(Camlp4.PreCast.Syntax)) 8 | in () 9 | 10 | let program_name = Filename.basename Sys.executable_name 11 | 12 | let input_file = 13 | match Sys.argv with 14 | | [| _; fname |] -> fname 15 | | _ -> 16 | Printf.eprintf "Usage: %s FILE\n" program_name; 17 | exit 2 18 | 19 | type kind = Signature | Structure 20 | 21 | let kind = 22 | if Filename.check_suffix input_file ".mli" then Signature else 23 | if Filename.check_suffix input_file ".ml" then Structure else begin 24 | Printf.eprintf "%s: unknown suffix in filename: %s\n" 25 | program_name input_file; 26 | exit 2 27 | end 28 | 29 | let file_contents = 30 | let ic = open_in input_file in 31 | let len = in_channel_length ic in 32 | let str = Bytes.create len in 33 | really_input ic str 0 len; 34 | Bytes.to_string str 35 | 36 | type subst = 37 | { start : int 38 | ; stop : int 39 | ; repl : string 40 | } 41 | 42 | let substs = ref [] 43 | 44 | let do_output () = 45 | let rec loop pos substs = 46 | match substs with 47 | | [] -> 48 | output_substring stdout file_contents pos (String.length file_contents - pos) 49 | | { start; stop; repl } :: rest -> 50 | assert (pos <= start && start <= stop); 51 | output_substring stdout file_contents pos (start - pos); 52 | output_string stdout repl; 53 | loop stop rest 54 | in 55 | let substs = List.sort !substs ~cmp:(fun a b -> 56 | let d = compare a.start b.start in 57 | if d = 0 then 58 | (* This happens with 0-length substitutions *) 59 | compare a.stop b.stop 60 | else 61 | d) 62 | in 63 | loop 0 substs 64 | ;; 65 | 66 | let add_subst ~start ~stop ~repl = 67 | substs := { start; stop; repl } :: !substs 68 | 69 | let replace loc s = 70 | add_subst ~start:(Loc.start_off loc) ~stop:(Loc.stop_off loc) ~repl:s 71 | 72 | let print_at ~pos s = 73 | add_subst ~start:pos ~stop:pos ~repl:s 74 | 75 | let print_before loc s = 76 | print_at ~pos:(Loc.start_off loc) s 77 | 78 | let print_after loc s = 79 | print_at ~pos:(Loc.stop_off loc) s 80 | 81 | let erase_keyword loc = 82 | let start = Loc.start_off loc in 83 | let stop = Loc.stop_off loc in 84 | if start > 0 && file_contents.[start - 1] = ' ' && 85 | stop < String.length file_contents && file_contents.[stop ] = ' ' then 86 | add_subst ~start ~stop:(stop + 1) ~repl:"" 87 | else 88 | add_subst ~start ~stop ~repl:"" 89 | 90 | let skip_trailing_semi loc = 91 | let stop = Loc.stop_off loc in 92 | if stop > 0 && file_contents.[stop - 1] = ';' then 93 | add_subst ~start:(stop-1) ~stop ~repl:"" 94 | 95 | DELETE_RULE Gram let_binding: ipatt; fun_binding END 96 | 97 | (* [let _ a = a] is a syntax error in ocaml because a single underscore is a pattern, 98 | but not an identifier as required by the ocaml parser in a function-style binding. 99 | 100 | However, if camlp4 is used to preprocess, the illegal syntax is masked by camlp4's 101 | more permissive grammar. In effect the example gets rewritten as [let _ = fun a -> a] 102 | 103 | We do the same translation as camlp4. *) 104 | EXTEND Gram 105 | GLOBAL: let_binding; 106 | 107 | equal: [ [ "=" -> _loc ] ]; 108 | 109 | unquoted_typevars: 110 | [ LEFTA 111 | [ SELF; SELF -> () 112 | | a_ident -> () 113 | ] ] ; 114 | 115 | cvalue_binding: 116 | [ [ l = equal; expr -> l 117 | | ":"; "type"; unquoted_typevars; "." ; ctyp ; l = equal; expr -> l 118 | | ":"; poly_type; l = equal; expr -> l 119 | | ":"; poly_type; ":>"; ctyp; l = equal; expr -> l 120 | | ":>"; ctyp; l = equal; expr -> l ] ]; 121 | 122 | fun_binding: 123 | [ RIGHTA 124 | [ TRY ["("; "type"]; a_LIDENT; ")"; (n, x) = SELF -> (n + 1, x) 125 | | TRY labeled_ipatt; (n, x) = SELF -> (n + 1, x) 126 | | x = cvalue_binding -> (0, x) 127 | ] ]; 128 | 129 | let_binding: 130 | [ [ p = ipatt; (n, loc_eq) = fun_binding -> 131 | begin match p with 132 | | <:patt@ploc< _ >> when n > 0 -> 133 | print_after ploc " = fun"; 134 | replace loc_eq "->" 135 | | _ -> () 136 | end; 137 | <:binding< >> 138 | ] ] ; 139 | END 140 | 141 | DELETE_RULE Gram expr: `LABEL _; SELF END; 142 | 143 | EXTEND Gram 144 | GLOBAL: expr; 145 | 146 | located_expr: [[expr -> _loc]]; 147 | 148 | expr: LEVEL "label" 149 | [[ `LABEL _; expr LEVEL "." -> <:expr< >> 150 | | `LABEL _; e_loc = located_expr -> 151 | begin 152 | if not (file_contents.[Loc.start_off e_loc] = '(') then ( 153 | print_before e_loc "("; 154 | print_after e_loc ")"; 155 | ); 156 | <:expr< >> 157 | end 158 | ]]; 159 | END 160 | 161 | type payload_kind = Str | Typ | Pat 162 | 163 | let payload_kinds = Hashtbl.create 128 164 | 165 | let set_payload_kind ~quotation_name kind = 166 | Hashtbl.add payload_kinds quotation_name kind 167 | 168 | (* Update quotations *) 169 | let () = DELETE_RULE Gram expr: `QUOTATION _ END 170 | EXTEND Gram 171 | expr: LEVEL "simple" 172 | [[ `QUOTATION q -> 173 | let { Camlp4.Sig. q_name; q_contents; q_loc=_; q_shift=_ } = q in 174 | let kind_marker = 175 | match Hashtbl.find payload_kinds q_name with 176 | | exception Not_found -> ":" 177 | | Typ -> ":" 178 | | Pat -> "?" 179 | | Str -> "" 180 | in 181 | let start = Loc.start_off _loc in 182 | let stop = Loc.stop_off _loc in 183 | add_subst ~start ~stop:(start + 2) ~repl:"[%"; 184 | (let start = start + 2 + String.length q_name in 185 | add_subst ~start ~stop:(start + 1) ~repl:kind_marker); 186 | add_subst ~start:(stop - 2) ~stop ~repl:"]"; 187 | <:expr< >> 188 | ]]; 189 | END 190 | 191 | external not_filtered : 'a -> 'a Gram.not_filtered = "%identity" 192 | external filtered : 'a Gram.not_filtered -> 'a = "%identity" 193 | 194 | let fix_lexer_stream stream = 195 | let maybe_last = ref None in 196 | (* Fix the Camlp4 lexer. Start locations are often wrong but end locations are always 197 | correct. *) 198 | let next _i = 199 | (* [loc] is this location, [loc'] is the last location *) 200 | let tok, loc = Stream.next stream in 201 | match !maybe_last with 202 | | None -> 203 | maybe_last := Some loc; 204 | Some (tok, loc) 205 | | Some loc' -> 206 | maybe_last := Some loc; 207 | if Loc.file_name loc' = Loc.file_name loc then 208 | let _, _, _, _, a, b, c, _ = Loc.to_tuple loc' 209 | and n, _, _, _, d, e, f, g = Loc.to_tuple loc in 210 | Some (tok, Loc.of_tuple (n, a, b, c, d, e, f, g)) 211 | else 212 | Some (tok, loc) 213 | in 214 | Stream.from next 215 | 216 | let rec parse entry token_stream = 217 | let _, stopped_at_directive = Gram.parse_tokens_before_filter entry token_stream in 218 | match stopped_at_directive with 219 | | Some (_ : Loc.t) -> 220 | parse entry token_stream 221 | | None -> 222 | () 223 | 224 | let main_internal () = 225 | let token_stream = Gram.lex_string (Loc.mk input_file) file_contents in 226 | let token_stream = 227 | token_stream 228 | |> filtered 229 | |> fix_lexer_stream 230 | |> not_filtered 231 | in 232 | (match kind with 233 | | Structure -> parse Syntax.implem token_stream 234 | | Signature -> parse Syntax.interf token_stream); 235 | do_output() 236 | 237 | let main () = 238 | try 239 | main_internal () 240 | with exn -> 241 | Format.eprintf "@[%a@]@." Camlp4.ErrorHandler.print exn; 242 | exit 2 243 | -------------------------------------------------------------------------------- /lib/camlp4_to_ppx.mli: -------------------------------------------------------------------------------- 1 | open Camlp4.PreCast 2 | 3 | (** Input file contents *) 4 | val file_contents : string 5 | 6 | (** Add a substitution to the input file. When {!main} is called the program will print 7 | the input with all substitutions applied. *) 8 | val add_subst : start:int -> stop:int -> repl:string -> unit 9 | 10 | val replace : Loc.t -> string -> unit 11 | val print_before : Loc.t -> string -> unit 12 | val print_after : Loc.t -> string -> unit 13 | 14 | (** Replace the given location by nothing, and if the location is preceded and followed by 15 | a space, remove the space after as well. *) 16 | val erase_keyword : Loc.t -> unit 17 | 18 | (** If the last character at given location is a semi-colon, erase it. *) 19 | val skip_trailing_semi : Loc.t -> unit 20 | 21 | type payload_kind = Str | Typ | Pat 22 | 23 | (** We need to know what kind of payload to use to replace quotations by extensions 24 | (i.e. what to put after the id: a ':', a '?' or nothing). 25 | 26 | By default quotations are expected to contain a type. 27 | *) 28 | val set_payload_kind : quotation_name:string -> payload_kind -> unit 29 | 30 | val main : unit -> unit 31 | -------------------------------------------------------------------------------- /plugins/pa_bench.ml: -------------------------------------------------------------------------------- 1 | open Camlp4.PreCast 2 | open Syntax 3 | open Camlp4_to_ppx 4 | 5 | EXTEND Gram 6 | GLOBAL: str_item; 7 | 8 | name: [ [ `STRING (_, _) -> () ] ]; 9 | 10 | bench: [ [ "BENCH" -> replace _loc "let%bench" ] ]; 11 | bench_fun: [ [ "BENCH_FUN" -> replace _loc "let%bench_fun" ] ]; 12 | bench_indexed: [ [ "BENCH_INDEXED" -> replace _loc "let%bench_fun" ] ]; 13 | bench_module: [ [ "BENCH_MODULE" -> replace _loc "let%bench_module" ] ]; 14 | 15 | var: [ [ a_LIDENT -> 16 | print_before _loc "[@indexed "; 17 | print_after _loc " =" 18 | ] ]; 19 | args: [ [ expr LEVEL "^" -> print_after _loc "]" ] ]; 20 | 21 | module_expr2: [ [ module_expr -> 22 | print_before _loc "(module "; 23 | print_after _loc ")" 24 | ] ]; 25 | 26 | str_item: 27 | [[ bench; name; "="; expr -> 28 | <:str_item< >> 29 | | bench_fun; name; "="; expr -> 30 | <:str_item< >> 31 | | bench_indexed; name; var; args; "="; expr -> 32 | <:str_item< >> 33 | | bench_module; name; "="; module_expr2 -> 34 | <:str_item< >> 35 | ]]; 36 | END 37 | 38 | let linkme = () 39 | -------------------------------------------------------------------------------- /plugins/pa_js.ml: -------------------------------------------------------------------------------- 1 | open Camlp4.PreCast 2 | open Syntax 3 | open Camlp4_to_ppx 4 | 5 | (* js_of_ocaml : pa_js *) 6 | let loc_end_to_end x y = 7 | let _, _, _, _, a, b, c, _ = Loc.to_tuple x in 8 | let n, _, _, _, d, e, f, g = Loc.to_tuple y in 9 | Loc.of_tuple (n, a, b, c, d, e, f, g) 10 | 11 | EXTEND Gram 12 | GLOBAL: expr; 13 | jsmeth: [[loc_op = [ "##" -> _loc ]; loc_label = [ label -> _loc] -> (loc_op,loc_label) ]]; 14 | opt_class_self_patt_jsoo: 15 | [[ "("; p = patt; ")" -> p 16 | | "("; p = patt; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >> 17 | | -> <:patt<_>> ]]; 18 | 19 | expr_within_comma_separated_list: 20 | [[ e = expr LEVEL ":=" -> 21 | begin match e with 22 | | <:expr< $lid:_$ >> -> _loc 23 | | <:expr< $uid:_$ >> -> _loc 24 | | _ -> 25 | print_before _loc "("; 26 | print_after _loc ")"; 27 | _loc 28 | end 29 | ]]; 30 | 31 | comma_exprs: 32 | [[ first_loc = expr_within_comma_separated_list ; comma_loc = [ "," -> _loc ]; self_loc = SELF -> 33 | let self_loc = match self_loc with Some x -> x | _ -> assert false in 34 | if Loc.stop_off first_loc = Loc.start_off self_loc - 1 35 | then replace comma_loc " " 36 | else replace comma_loc ""; 37 | Some _loc 38 | | expr_within_comma_separated_list -> 39 | Some _loc 40 | | -> None ]]; 41 | 42 | js_object: [[ "jsobject" -> replace _loc "object%js" ]]; 43 | 44 | expr: BEFORE "." 45 | ["##" RIGHTA 46 | [ SELF; (loc_op,_) = jsmeth -> 47 | replace loc_op "##."; 48 | <:expr> 49 | | SELF; (loc_op1,_) = jsmeth; loc_op2 = [ "<-" -> _loc ] ; expr LEVEL "top" -> 50 | replace loc_op1 "##."; 51 | replace loc_op2 ":="; 52 | <:expr<>> 53 | | e = SELF; (_loc_op,label_loc) = jsmeth; 54 | lpar_loc = ["(" -> _loc]; 55 | args_loc = comma_exprs; 56 | rpar_loc = [")" -> _loc] -> 57 | match args_loc with 58 | | None -> 59 | (* No arguments *) 60 | replace (loc_end_to_end label_loc rpar_loc) ""; 61 | begin match e with 62 | | <:expr< $lid:_$ >> -> () 63 | | <:expr< $e$ >> -> 64 | let _loc = Ast.loc_of_expr e in 65 | print_before _loc "("; 66 | print_after _loc ")"; 67 | end; 68 | <:expr<>> 69 | | Some args_loc -> 70 | print_before label_loc "("; 71 | replace lpar_loc ""; 72 | replace rpar_loc ""; 73 | if Loc.start_off args_loc = Loc.stop_off label_loc + 1 74 | then print_after label_loc " " 75 | else print_after label_loc ""; 76 | print_after rpar_loc ")"; 77 | <:expr<>> 78 | ]]; 79 | 80 | expr: LEVEL "simple" 81 | [[ ["jsnew" -> replace _loc "new%js" ]; e_loc = [ expr LEVEL "label" -> _loc] ; 82 | lpar_loc = ["(" -> _loc]; 83 | comma_exprs_loc = comma_exprs; 84 | rpar_loc = [")" -> _loc] -> 85 | begin 86 | match comma_exprs_loc with 87 | | Some _loc -> 88 | if Loc.stop_off e_loc = Loc.start_off _loc - 1 89 | then replace lpar_loc " " 90 | else replace lpar_loc ""; 91 | replace rpar_loc ""; 92 | <:expr< >> 93 | | None -> 94 | replace (loc_end_to_end e_loc _loc) ""; 95 | <:expr<>> 96 | end 97 | | js_object; "end" -> 98 | <:expr<>> 99 | | js_object; opt_class_self_patt_jsoo; class_structure ; "end" -> 100 | <:expr<>> 101 | ]]; 102 | END 103 | 104 | let rec filter stream = 105 | match stream with parser 106 | [< '(KEYWORD "#", loc); rest >] -> 107 | begin match rest with parser 108 | [< '(KEYWORD "#", loc') >] -> 109 | [< '(KEYWORD "##", Loc.merge loc loc'); filter rest >] 110 | | [< >] -> 111 | [< '(KEYWORD "#", loc); filter rest >] 112 | end 113 | | [< 'other; rest >] -> [< 'other; filter rest >] 114 | 115 | 116 | let _ = 117 | Token.Filter.define_filter (Gram.get_filter ()) 118 | (fun old_filter stream -> old_filter (filter stream)) 119 | 120 | let linkme = () 121 | -------------------------------------------------------------------------------- /plugins/pa_lwt.ml: -------------------------------------------------------------------------------- 1 | open Camlp4.PreCast ;; 2 | open Syntax ;; 3 | open Camlp4_to_ppx ;; 4 | 5 | let linkme = () ;; 6 | 7 | EXTEND Gram 8 | GLOBAL: expr str_item; 9 | 10 | lwt_binding: [[ SELF; "and"; SELF | patt; "="; expr ]]; 11 | 12 | located_lwt: [[ "lwt" -> _loc ]]; 13 | 14 | expr: LEVEL "top" [ 15 | [ loc = ["try_lwt" -> _loc]; 16 | expr LEVEL ";"; 17 | OPT ["with"; match_case]; 18 | fnl = OPT [loc = ["finally" -> ()]; sequence -> loc] -> ( 19 | match fnl with 20 | | Some _ -> 21 | failwith "\"try_lwt ... finally ...\" not supported" 22 | | None -> 23 | (replace loc "try%lwt"; <:expr<>>)) 24 | | loc = located_lwt; lwt_binding; "in"; expr LEVEL ";" -> ( 25 | replace loc "let%lwt"; 26 | <:expr<>>) 27 | | loc = ["for_lwt" -> _loc]; patt; 28 | b = [ "="; sequence; "to"; sequence -> true 29 | | "="; sequence; "downto"; sequence -> true 30 | | "in"; sequence -> false]; 31 | "do"; do_sequence -> ( 32 | if b then 33 | (replace loc "for%lwt"; <:expr<>>) 34 | else 35 | failwith "\"for_lwt ... in ...\" not supported") 36 | | loc = ["raise_lwt" -> _loc]; SELF -> ( 37 | replace loc "[%lwt raise ("; 38 | print_after _loc ")]"; 39 | <:expr<>>) 40 | | loc = ["assert_lwt" -> _loc]; SELF -> ( 41 | replace loc "assert%lwt ("; 42 | print_after _loc ")"; 43 | <:expr<>>) 44 | | loc = ["while_lwt" -> _loc]; sequence; "do"; sequence; "done" -> ( 45 | replace loc "while%lwt"; 46 | <:expr<>>) 47 | | loc = ["match_lwt" -> _loc]; sequence; "with"; match_case -> ( 48 | replace loc "match%lwt"; 49 | <:expr<>>) 50 | ] ]; 51 | 52 | str_item: [ 53 | [ loc = located_lwt; lwt_binding -> 54 | failwith "toplevel \"lwt\" bindings not supported" 55 | | loc = located_lwt; lwt_binding; "in"; expr -> 56 | failwith "toplevel \"lwt\" bindings not supported" 57 | ] 58 | ]; 59 | 60 | END 61 | -------------------------------------------------------------------------------- /plugins/pa_macro.ml: -------------------------------------------------------------------------------- 1 | open Camlp4.PreCast 2 | open Syntax 3 | open Camlp4_to_ppx 4 | 5 | let all_spaces_between start stop = 6 | let rec loop ofs = 7 | if ofs >= stop then 8 | true 9 | else 10 | match file_contents.[ofs] with 11 | | ' ' | '\t' -> loop (ofs + 1) 12 | | _ -> false 13 | in 14 | loop start 15 | 16 | let replace_macro ?(addnl=false) loc dir = 17 | let start = 18 | if all_spaces_between (Loc.start_bol loc) (Loc.start_off loc) then 19 | Loc.start_bol loc 20 | else 21 | Loc.start_off loc 22 | in 23 | add_subst ~start ~stop:(Loc.stop_off loc) ~repl:dir; 24 | if Loc.stop_off loc < String.length file_contents && 25 | file_contents.[Loc.stop_off loc] <> '\n' && addnl then 26 | print_after loc "\n" 27 | ;; 28 | 29 | (* pa_macro *) 30 | EXTEND Gram 31 | GLOBAL: str_item sig_item expr patt; 32 | 33 | define: [ [ "DEFINE" -> replace_macro _loc "#define" ] ]; 34 | ifdef: [ [ "IFDEF" -> replace_macro _loc "#ifdef" ] ]; 35 | ifndef: [ [ "IFNDEF" -> replace_macro _loc "#ifndef" ] ]; 36 | then_: [ [ "THEN" -> replace _loc "" ] ]; 37 | else_: [ [ "ELSE" -> replace_macro _loc "#else" ~addnl:true ] ]; 38 | end_: [ [ "END" -> replace_macro _loc "#endif" ~addnl:true ] ]; 39 | endif_: [ [ "ENDIF" -> replace_macro _loc "#endif" ~addnl:true ] ]; 40 | include_: [ [ "INCLUDE" -> replace_macro _loc "#import" ] ]; 41 | 42 | equal: [ [ "=" -> erase_keyword _loc ] ]; 43 | 44 | str_item: FIRST [ [ macro_def -> <:str_item< >> ] ]; 45 | sig_item: FIRST [ [ macro_def_sig -> <:sig_item< >> ] ]; 46 | macro_def: 47 | [ [ define; uident; opt_macro_value -> () 48 | | ifdef; uident_eval_ifdef; then_; smlist_then; else_macro_def -> () 49 | | ifndef; uident_eval_ifndef; then_; smlist_then; else_macro_def -> () 50 | | include_; STRING -> () ] ] 51 | ; 52 | macro_def_sig: 53 | [ [ define; uident -> () 54 | | ifdef; uident_eval_ifdef; then_; sglist_then; else_macro_def_sig -> () 55 | | ifndef; uident_eval_ifndef; then_; sglist_then; else_macro_def_sig -> () 56 | | include_; STRING -> () ] ] 57 | ; 58 | uident_eval_ifdef: 59 | [ [ uident -> () ]] 60 | ; 61 | uident_eval_ifndef: 62 | [ [ uident -> () ]] 63 | ; 64 | else_macro_def: 65 | [ [ else_; smlist_else; endif -> () 66 | | endif -> () ] ] 67 | ; 68 | else_macro_def_sig: 69 | [ [ else_; sglist_else; endif -> () 70 | | endif -> () ] ] 71 | ; 72 | else_expr: 73 | [ [ else_; expr; endif -> () 74 | | endif -> () ] ] 75 | ; 76 | smlist_then: 77 | [ [ LIST1 [ macro_def; semi -> () | str_item; semi -> () ] -> () ] ]; 78 | smlist_else: 79 | [ [ LIST1 [ macro_def; semi -> () | str_item; semi -> () ] -> () ] ]; 80 | sglist_then: 81 | [ [ LIST1 [ macro_def_sig; semi -> () | sig_item; semi -> () ] -> () ] ]; 82 | sglist_else: 83 | [ [ LIST1 [ macro_def_sig; semi -> () | sig_item; semi -> () ] -> () ] ]; 84 | endif: 85 | [ [ end_ -> () 86 | | endif_ -> () ] ] 87 | ; 88 | opt_macro_value: 89 | [ [ equal; expr -> () 90 | | -> () ] ] 91 | ; 92 | expr: LEVEL "top" 93 | [ [ ifdef ; uident; then_; expr; else_expr -> <:expr< >> 94 | | ifndef; uident; then_; expr; else_expr -> <:expr< >> 95 | ] ] 96 | ; 97 | patt: 98 | [ [ ifdef ; uident; then_; patt; else_; patt; endif -> <:patt< >> 99 | | ifndef; uident; then_; patt; else_; patt; endif -> <:patt< >> 100 | ] ] 101 | ; 102 | uident: 103 | [ [ UIDENT -> print_before _loc "JSC_" ] ] 104 | ; 105 | (* dirty hack to allow polymorphic variants using the introduced keywords. *) 106 | expr: BEFORE "simple" 107 | [ [ "`"; [ "IFDEF" | "IFNDEF" | "THEN" | "ELSE" | "END" | "ENDIF" 108 | | "DEFINE" ] -> <:expr< >> 109 | | "`"; a_ident -> <:expr< >> ] ] 110 | ; 111 | (* idem *) 112 | patt: BEFORE "simple" 113 | [ [ "`"; [ "IFDEF" | "IFNDEF" | "THEN" | "ELSE" | "END" | "ENDIF" ] -> <:patt< >> 114 | | "`"; a_ident -> <:patt< >> ] ] 115 | ; 116 | END 117 | 118 | let linkme = () 119 | -------------------------------------------------------------------------------- /plugins/pa_ounit.ml: -------------------------------------------------------------------------------- 1 | open Camlp4.PreCast 2 | open Syntax 3 | open Camlp4_to_ppx 4 | 5 | EXTEND Gram 6 | GLOBAL: str_item; 7 | 8 | name_equal: [ [ `STRING _; "=" -> () 9 | | "=" -> replace _loc "_ =" 10 | ] ]; 11 | 12 | test: [ [ "TEST" -> replace _loc "let%test" ] ]; 13 | test_unit: [ [ "TEST_UNIT" -> replace _loc "let%test_unit" ] ]; 14 | test_module: [ [ "TEST_MODULE" -> replace _loc "let%test_module" ] ]; 15 | 16 | module_expr2: [ [ module_expr -> 17 | print_before _loc "(module "; 18 | print_after _loc ")" 19 | ] ]; 20 | 21 | expr_skip_trailing_semi : [[ expr -> skip_trailing_semi _loc ]]; 22 | 23 | str_item: 24 | [[ test; name_equal; expr_skip_trailing_semi -> <:str_item< >> 25 | | test_unit; name_equal; expr_skip_trailing_semi -> <:str_item< >> 26 | | test_module; name_equal; module_expr2 -> <:str_item< >> 27 | ]]; 28 | END 29 | 30 | let linkme = () 31 | -------------------------------------------------------------------------------- /plugins/pa_type_conv.ml: -------------------------------------------------------------------------------- 1 | open StdLabels 2 | open Camlp4.PreCast 3 | open Syntax 4 | open Camlp4_to_ppx 5 | 6 | let get_body_text xs = 7 | let _ : (camlp4_token * Gram.token_info) list = xs in 8 | match xs with 9 | | [] -> "" 10 | | (_,first_info)::_ -> 11 | let (_,last_info) = (match List.rev xs with [] -> assert false | x::_ -> x) in 12 | let start = Loc.start_off (Gram.token_location first_info) in 13 | let stop = Loc.start_off (Gram.token_location last_info) in 14 | String.sub file_contents start (stop - start) 15 | 16 | let mk_type_dec_with gens = 17 | Printf.sprintf "[@@deriving %s]" 18 | (String.concat ~sep:", " 19 | (List.map gens ~f:(fun (name,body_opt) -> 20 | match body_opt with 21 | | None -> name 22 | | Some body -> 23 | let _ : (camlp4_token * Gram.token_info) list = body in 24 | Printf.sprintf "%s ~%s" name (get_body_text body) 25 | ))) 26 | 27 | let mk_label_dec_with gens = (* i.e. [with default(..)] *) 28 | String.concat ~sep:" " (List.map gens ~f:(fun (name,body_opt) -> 29 | match body_opt with 30 | | None -> Printf.sprintf "[@%s]" name 31 | | Some body -> 32 | let _ : (camlp4_token * Gram.token_info) list = body in 33 | Printf.sprintf "[@%s %s]" name (get_body_text body) 34 | )) 35 | 36 | let nonrec_opt = 37 | Gram.Entry.of_parser "nonrec" (fun strm -> 38 | match Stream.peek strm with 39 | | Some (LIDENT "nonrec", _info) -> 40 | Stream.junk strm; 41 | false 42 | | _ -> 43 | true) 44 | 45 | let rec fetch_generator_arg paren_count acc strm = 46 | let token, token_info as elt = Stream.next strm in 47 | match token with 48 | | KEYWORD "(" -> 49 | fetch_generator_arg (paren_count + 1) (elt :: acc) strm 50 | | KEYWORD ")" when paren_count = 1 -> 51 | (EOI, token_info) :: acc 52 | | KEYWORD ")" -> 53 | fetch_generator_arg (paren_count - 1) (elt :: acc) strm 54 | | EOI -> 55 | Loc.raise (Gram.token_location token_info) (Stream.Error "')' missing") 56 | | _ -> 57 | fetch_generator_arg paren_count (elt :: acc) strm 58 | 59 | let generator_arg = 60 | Gram.Entry.of_parser "generator_arg" (fun strm -> 61 | match Stream.peek strm with 62 | | Some (KEYWORD "(", _) -> 63 | Stream.junk strm; 64 | Some (List.rev (fetch_generator_arg 1 [] strm)) 65 | | _ -> None) 66 | 67 | EXTEND Gram 68 | 69 | GLOBAL: str_item sig_item label_declaration; 70 | 71 | generator: [[ 72 | (*[ id = LIDENT; l = LIST1 [ "-"; x = LIDENT -> x ] -> (id, None, l)*) 73 | id = LIDENT; arg = generator_arg -> (id, arg) 74 | ]]; 75 | 76 | with_generators: 77 | [[ 78 | "with"; drvs = LIST1 generator SEP "," -> 79 | _loc,drvs 80 | ]]; 81 | 82 | located_type_declaration: 83 | [[ 84 | type_declaration -> 85 | _loc 86 | ]]; 87 | 88 | str_item: 89 | [[ 90 | "type"; nonrec_opt; located_type_declaration; (loc1,drvs) = with_generators -> 91 | replace loc1 (mk_type_dec_with drvs); 92 | <:str_item<>> 93 | | "type"; nonrec_opt; located_type_declaration -> 94 | <:str_item<>> 95 | ]]; 96 | 97 | str_item: 98 | [[ 99 | "exception"; constructor_declaration; (loc1,drvs) = with_generators -> 100 | replace loc1 (mk_type_dec_with drvs); 101 | <:str_item<>> 102 | | "exception"; constructor_declaration -> 103 | <:str_item<>> 104 | ]]; 105 | 106 | sig_item: 107 | [[ 108 | "type"; nonrec_opt; located_type_declaration; (loc1,drvs) = with_generators -> 109 | replace loc1 (mk_type_dec_with drvs); 110 | <:sig_item< >> 111 | | "type"; nonrec_opt; located_type_declaration -> 112 | <:sig_item<>> 113 | ]]; 114 | 115 | sig_item: 116 | [[ 117 | "exception"; constructor_declaration; (loc1,drvs) = with_generators -> 118 | replace loc1 (mk_type_dec_with drvs); 119 | <:sig_item<>> 120 | | "exception"; constructor_declaration -> 121 | <:sig_item<>> 122 | ]]; 123 | 124 | label_declaration: 125 | [[ 126 | a_LIDENT; ":"; poly_type; (loc1,drvs) = with_generators -> 127 | replace loc1 (mk_label_dec_with drvs); 128 | <:ctyp< >> 129 | | "mutable"; a_LIDENT; ":"; poly_type; (loc1,drvs) = with_generators -> 130 | replace loc1 (mk_label_dec_with drvs); 131 | <:ctyp< >> 132 | ]]; 133 | END 134 | 135 | let linkme = () 136 | --------------------------------------------------------------------------------