├── .ocamlformat ├── .gitignore ├── src ├── let_trail.mli ├── shims.402.ml ├── shims.403.ml ├── select-impl ├── shims.406.ml ├── select-shims ├── dune ├── let_trail.mll └── pp.real.ml ├── test ├── dune └── test.ml ├── CHANGES.md ├── dune-workspace.dev ├── README.md ├── dune-project ├── ocaml-syntax-shims.opam └── LICENSE.md /.ocamlformat: -------------------------------------------------------------------------------- 1 | version=0.12 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | *.install 3 | *.merlin 4 | -------------------------------------------------------------------------------- /src/let_trail.mli: -------------------------------------------------------------------------------- 1 | val op : Lexing.lexbuf -> string option 2 | -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test) 3 | (preprocess future_syntax)) 4 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | 1.0.0 (09/12/2019) 2 | ------------------ 3 | 4 | Initial release 5 | -------------------------------------------------------------------------------- /src/shims.402.ml: -------------------------------------------------------------------------------- 1 | let nolabel = "" 2 | 3 | let error_of_exn = Location.error_of_exn 4 | -------------------------------------------------------------------------------- /src/shims.403.ml: -------------------------------------------------------------------------------- 1 | let nolabel = Asttypes.Nolabel 2 | 3 | let error_of_exn = Location.error_of_exn 4 | -------------------------------------------------------------------------------- /src/select-impl: -------------------------------------------------------------------------------- 1 | (* -*- tuareg -*- *) 2 | 3 | let v = Scanf.sscanf Sys.argv.(1) "%d.%d" (fun a b -> a, b) in 4 | print_string ( 5 | if v < (4, 08) then 6 | "real" 7 | else 8 | "nop" 9 | ) 10 | -------------------------------------------------------------------------------- /src/shims.406.ml: -------------------------------------------------------------------------------- 1 | let nolabel = Asttypes.Nolabel 2 | 3 | let error_of_exn exn = 4 | match Location.error_of_exn exn with 5 | | Some (`Ok exn) -> Some exn 6 | | Some `Already_displayed -> None 7 | | None -> None 8 | -------------------------------------------------------------------------------- /src/select-shims: -------------------------------------------------------------------------------- 1 | (* -*- tuareg -*- *) 2 | 3 | let v = Scanf.sscanf Sys.argv.(1) "%d.%d" (fun a b -> a, b) in 4 | print_string ( 5 | if v < (4, 03) then 6 | "402" 7 | else if v < (4, 06) then 8 | "403" 9 | else if v < (4, 08) then 10 | "406" 11 | else 12 | "nop" 13 | ) 14 | -------------------------------------------------------------------------------- /dune-workspace.dev: -------------------------------------------------------------------------------- 1 | (lang dune 1.0) 2 | 3 | (context (opam (switch 4.02.3))) 4 | (context (opam (switch 4.03.0))) 5 | (context (opam (switch 4.04.2))) 6 | (context (opam (switch 4.05.0))) 7 | (context (opam (switch 4.06.1))) 8 | (context (opam (switch 4.07.1))) 9 | (context (opam (switch 4.08.0))) 10 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ocaml-syntax-shims 2 | ================== 3 | 4 | This package provides a small utility that backports some of the newer 5 | OCaml syntax to older OCaml compilers. This allows adopting new 6 | features such as `let+` while still keeping compatibility with older 7 | OCaml compiler. 8 | 9 | To use it, simply depend on this package and add the following field 10 | to your `library` or `executable` stanzas in your `dune` files: 11 | `(preprocess future_syntax)`. For instance: 12 | 13 | ```scheme 14 | (library 15 | (name mylib) 16 | (preprocess future_syntax)) 17 | ``` 18 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.0) 2 | (name ocaml-syntax-shims) 3 | 4 | (generate_opam_files true) 5 | 6 | (license "MIT") 7 | (maintainers jeremie@dimino.org) 8 | (authors "Jérémie Dimino ") 9 | (source (github ocaml-ppx/ocaml-syntax-shims)) 10 | (documentation https://ocaml-ppx.github.io/ocaml-syntax-shims/) 11 | 12 | (package 13 | (name ocaml-syntax-shims) 14 | (depends 15 | ("ocaml" (>= "4.02.3"))) 16 | (synopsis "Backport new syntax to older OCaml versions") 17 | (description "\ 18 | This packages backports new features of the language to older 19 | compilers, such as let+. 20 | ")) 21 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name pp) 3 | (public_name ocaml-syntax-shims) 4 | (libraries compiler-libs.common)) 5 | 6 | (ocamllex let_trail) 7 | 8 | (rule 9 | (with-stdout-to 10 | impl 11 | (run ocaml %{dep:select-impl} %{ocaml_version}))) 12 | 13 | (rule 14 | (with-stdout-to 15 | shims 16 | (run ocaml %{dep:select-shims} %{ocaml_version}))) 17 | 18 | (rule 19 | (copy# pp.%{read:impl}.ml pp.ml)) 20 | 21 | (rule 22 | (copy# shims.%{read:shims}.ml shims.ml)) 23 | 24 | (rule 25 | (with-stdout-to 26 | pp.nop.ml 27 | (echo ""))) 28 | 29 | (rule 30 | (with-stdout-to 31 | shims.nop.ml 32 | (echo ""))) 33 | -------------------------------------------------------------------------------- /test/test.ml: -------------------------------------------------------------------------------- 1 | let ( let+ ) x f = `Let (x, f) 2 | 3 | let ( and+ ) a b = `And (a, b) 4 | 5 | let t = 6 | let+ x = 1 and+ y = 2 and+ z = 3 in 7 | (x, y, z) 8 | 9 | let () = 10 | match t with 11 | | `Let (`And (`And (1, 2), 3), f) -> assert (f ((1, 2), 3) = (1, 2, 3)) 12 | | _ -> assert false 13 | 14 | (* Make sure the evaluation order is the same as with OCaml >= 4.08 *) 15 | 16 | let ( let+ ) x f = f x 17 | 18 | let ( and+ ) a b = (a, b) 19 | 20 | let () = 21 | let q1 = Queue.create () in 22 | let q2 = Queue.create () in 23 | let () = Queue.add 1 q1 and () = Queue.add 2 q1 and () = Queue.add 3 q1 in 24 | let+ () = Queue.add 1 q2 and+ () = Queue.add 2 q2 and+ () = Queue.add 3 q2 in 25 | let l1 = Queue.fold (fun l x -> x :: l) [] q1 in 26 | let l2 = Queue.fold (fun l x -> x :: l) [] q2 in 27 | assert (l1 = l2) 28 | -------------------------------------------------------------------------------- /ocaml-syntax-shims.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Backport new syntax to older OCaml versions" 4 | description: """ 5 | This packages backports new features of the language to older 6 | compilers, such as let+. 7 | """ 8 | maintainer: ["jeremie@dimino.org"] 9 | authors: ["Jérémie Dimino "] 10 | license: "MIT" 11 | homepage: "https://github.com/ocaml-ppx/ocaml-syntax-shims" 12 | doc: "https://ocaml-ppx.github.io/ocaml-syntax-shims/" 13 | bug-reports: "https://github.com/ocaml-ppx/ocaml-syntax-shims/issues" 14 | depends: [ 15 | "dune" {>= "2.0"} 16 | "ocaml" {>= "4.02.3"} 17 | ] 18 | build: [ 19 | ["dune" "subst"] {pinned} 20 | [ 21 | "dune" 22 | "build" 23 | "-p" 24 | name 25 | "-j" 26 | jobs 27 | "@install" 28 | "@runtest" {with-test} 29 | "@doc" {with-doc} 30 | ] 31 | ] 32 | dev-repo: "git+https://github.com/ocaml-ppx/ocaml-syntax-shims.git" 33 | -------------------------------------------------------------------------------- /src/let_trail.mll: -------------------------------------------------------------------------------- 1 | { 2 | let name = function 3 | | '!' -> "bang" 4 | | '$' -> "dollar" 5 | | '%' -> "percent" 6 | | '&' -> "ampersand" 7 | | '*' -> "star" 8 | | '+' -> "plus" 9 | | '-' -> "minus" 10 | | '/' -> "slash" 11 | | ':' -> "colon" 12 | | '<' -> "lesser" 13 | | '=' -> "equal" 14 | | '>' -> "greater" 15 | | '?' -> "question" 16 | | '@' -> "at" 17 | | '^' -> "circumflex" 18 | | '|' -> "pipe" 19 | | _ -> assert false 20 | 21 | let expand s = 22 | let buf = Buffer.create 128 in 23 | for i = 0 to String.length s - 1 do 24 | if i > 0 then Buffer.add_char buf '_'; 25 | Buffer.add_string buf (name s.[i]) 26 | done; 27 | Buffer.contents buf 28 | } 29 | 30 | let dotsymbolchar = 31 | ['!' '$' '%' '&' '*' '+' '-' '/' ':' '=' '>' '?' '@' '^' '|'] 32 | let kwdopchar = 33 | ['$' '&' '*' '+' '-' '/' '<' '=' '>' '@' '^' '|'] 34 | 35 | rule op = parse 36 | | kwdopchar dotsymbolchar* as s { Some (expand s) } 37 | | "" { None } 38 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | The MIT License 2 | 3 | Copyright (c) 2016 Jane Street Group, LLC 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, 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, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /src/pp.real.ml: -------------------------------------------------------------------------------- 1 | open StdLabels 2 | open Shims 3 | 4 | let prog_name = Filename.basename Sys.executable_name 5 | 6 | let dump_ast = ref false 7 | 8 | (* Table from positions to custom operators at these positions *) 9 | let custom_operators = Hashtbl.create 128 10 | 11 | module Wrap_lexer = struct 12 | let save_loc = Location.curr 13 | 14 | let restore_loc (lexbuf : Lexing.lexbuf) (loc : Location.t) = 15 | lexbuf.lex_start_p <- loc.loc_start; 16 | lexbuf.lex_curr_p <- loc.loc_end 17 | 18 | let encode_op (tok : Parser.token) op = 19 | (match tok with LET -> "let__" | AND -> "and__" | _ -> assert false) ^ op 20 | 21 | let pending = Queue.create () 22 | 23 | let add (x : Parser.token * _) = Queue.push x pending 24 | 25 | let register_custom_operator tok op (loc1 : Location.t) (loc2 : Location.t) = 26 | let op = encode_op tok op in 27 | Hashtbl.add custom_operators loc1.loc_start 28 | ({ loc1 with loc_end = loc2.loc_end }, op) 29 | 30 | let wrap (lexer : Lexing.lexbuf -> Parser.token) lb = 31 | if not (Queue.is_empty pending) then ( 32 | let tok, loc = Queue.pop pending in 33 | restore_loc lb loc; 34 | tok ) 35 | else 36 | match lexer lb with 37 | | (LET | AND) as tok -> 38 | let loc = save_loc lb in 39 | ( match Let_trail.op lb with 40 | | None -> () 41 | | Some op -> register_custom_operator tok op loc (save_loc lb) ); 42 | restore_loc lb loc; 43 | tok 44 | | LPAREN -> 45 | let loc1 = save_loc lb in 46 | let tok2 = lexer lb in 47 | let loc2 = save_loc lb in 48 | let tok, loc = 49 | match tok2 with 50 | | LET | AND -> ( 51 | match Let_trail.op lb with 52 | | None -> 53 | add (tok2, loc2); 54 | (Parser.LPAREN, loc1) 55 | | Some op -> ( 56 | let loc3 = save_loc lb in 57 | match lexer lb with 58 | | RPAREN -> 59 | ( LIDENT (encode_op tok2 op), 60 | { loc2 with loc_end = loc3.loc_end } ) 61 | | tok4 -> 62 | let loc4 = save_loc lb in 63 | add (tok2, loc2); 64 | add (tok4, loc4); 65 | register_custom_operator tok2 op loc2 loc3; 66 | (LPAREN, loc1) ) ) 67 | | _ -> 68 | add (tok2, loc2); 69 | (LPAREN, loc1) 70 | in 71 | restore_loc lb loc; 72 | tok 73 | | tok -> tok 74 | 75 | let () = Lexer.set_preprocessor (fun () -> Queue.clear pending) wrap 76 | end 77 | 78 | module Map_ast = struct 79 | open Ast_mapper 80 | open Asttypes 81 | open Parsetree 82 | open Ast_helper 83 | 84 | let get_op vb = 85 | match Hashtbl.find custom_operators vb.pvb_loc.loc_start with 86 | | exception Not_found -> None 87 | | loc, op -> Some (Exp.ident ~loc { txt = Lident op; loc }) 88 | 89 | let mapper = 90 | let super = default_mapper in 91 | let expr self expr = 92 | let expr = 93 | match expr.pexp_desc with 94 | | Pexp_let (rf, (vb :: _ as vbs), body) -> ( 95 | match get_op vb with 96 | | None -> expr 97 | | Some op -> 98 | if rf = Recursive then 99 | Location.raise_errorf ~loc:expr.pexp_loc 100 | "Custom 'let' operators cannot be recursive"; 101 | let patts, exprs = 102 | List.map vbs ~f:(fun vb -> 103 | let { 104 | pvb_pat = patt; 105 | pvb_expr = expr; 106 | pvb_attributes = attrs; 107 | pvb_loc = loc; 108 | } = 109 | vb 110 | in 111 | ( match attrs with 112 | | [] -> () 113 | | ({ loc; _ }, _) :: _ -> 114 | Location.raise_errorf ~loc 115 | "This attribute will be discarded" ); 116 | let op = 117 | match get_op vb with 118 | | Some op -> 119 | Hashtbl.remove custom_operators vb.pvb_loc.loc_start; 120 | op 121 | | None -> 122 | Location.raise_errorf ~loc 123 | "Custom 'and' operator expected, got stantard \ 124 | 'and' keyword" 125 | in 126 | (patt, (loc, op, expr))) 127 | |> List.split 128 | in 129 | let patt = 130 | List.fold_left (List.tl patts) ~init:(List.hd patts) 131 | ~f:(fun acc patt -> 132 | let loc = patt.ppat_loc in 133 | Pat.tuple ~loc [ acc; patt ]) 134 | in 135 | let vars = 136 | List.mapi exprs ~f:(fun i _ -> 137 | Printf.sprintf "__future_syntax__%d__" i) 138 | in 139 | let pvars = 140 | List.map2 vars patts ~f:(fun v p -> 141 | let loc = { p.ppat_loc with loc_ghost = true } in 142 | Pat.var ~loc { txt = v; loc }) 143 | in 144 | let evars = 145 | List.map2 vars exprs ~f:(fun v (_, _, e) -> 146 | let loc = { e.pexp_loc with loc_ghost = true } in 147 | Exp.ident ~loc { txt = Lident v; loc }) 148 | in 149 | let expr = 150 | List.fold_left2 (List.tl evars) (List.tl exprs) 151 | ~init:(List.hd evars) ~f:(fun acc var (loc, op, _) -> 152 | Exp.apply ~loc op [ (nolabel, acc); (nolabel, var) ]) 153 | in 154 | let body = 155 | let loc = expr.pexp_loc in 156 | Exp.apply ~loc op 157 | [ 158 | (nolabel, expr); 159 | (nolabel, Exp.fun_ ~loc nolabel None patt body); 160 | ] 161 | in 162 | List.fold_right2 pvars exprs ~init:body 163 | ~f:(fun var (loc, _, expr) acc -> 164 | Exp.let_ Nonrecursive ~loc [ Vb.mk ~loc var expr ] acc) ) 165 | | _ -> expr 166 | in 167 | super.expr self expr 168 | in 169 | { super with expr } 170 | 171 | let map f ast = 172 | let ast = f mapper ast in 173 | let fail _ (loc, _) = 174 | Location.raise_errorf ~loc "Invalid use of custom 'let' or 'and' operator" 175 | in 176 | Hashtbl.iter fail custom_operators; 177 | ast 178 | 179 | let structure = mapper.structure mapper 180 | 181 | let signature = mapper.signature mapper 182 | end 183 | 184 | let process_file fn ~magic ~parse ~print ~map ~mk_ext = 185 | let lexbuf = Lexing.from_channel (open_in_bin fn) in 186 | Location.init lexbuf fn; 187 | Location.input_lexbuf := Some lexbuf; 188 | let ast = 189 | try map (parse lexbuf) 190 | with exn -> ( 191 | match error_of_exn exn with 192 | | Some error -> 193 | if !dump_ast then 194 | [ 195 | mk_ext ?loc:None ?attrs:None (Ast_mapper.extension_of_error error); 196 | ] 197 | else ( 198 | Location.report_error Format.err_formatter error; 199 | exit 1 ) 200 | | None -> raise exn ) 201 | in 202 | if !dump_ast then ( 203 | set_binary_mode_out stdout true; 204 | output_string stdout magic; 205 | output_value stdout fn; 206 | output_value stdout ast; 207 | flush stdout ) 208 | else Format.printf "%a@?" print ast 209 | 210 | let process_file fn = 211 | let ext = 212 | match String.rindex fn '.' with 213 | | exception Not_found -> "" 214 | | i -> String.sub fn ~pos:i ~len:(String.length fn - i) 215 | in 216 | match ext with 217 | | ".ml" -> 218 | process_file fn ~magic:Config.ast_impl_magic_number 219 | ~parse:Parse.implementation ~print:Pprintast.structure 220 | ~map:Map_ast.structure ~mk_ext:Ast_helper.Str.extension 221 | | ".mli" -> 222 | process_file fn ~magic:Config.ast_intf_magic_number ~parse:Parse.interface 223 | ~print:Pprintast.signature ~map:Map_ast.signature 224 | ~mk_ext:Ast_helper.Sig.extension 225 | | _ -> 226 | Printf.eprintf "%s: Don't know what to do with %s.\n%!" prog_name fn; 227 | exit 2 228 | 229 | let () = 230 | let args = 231 | Arg.align 232 | [ 233 | ( "-dump-ast", 234 | Arg.Set dump_ast, 235 | " Output a binary AST rather than a pretty-printed source file" ); 236 | ] 237 | in 238 | let usage = Printf.sprintf "Usage: %s [-dump-ast] FILES" prog_name in 239 | Arg.parse args process_file usage 240 | --------------------------------------------------------------------------------