├── .gitignore ├── .ocamlformat ├── CHANGES.md ├── CONTRIBUTING.md ├── LICENSE.md ├── Makefile ├── README.md ├── dune ├── dune-project ├── ppx_custom_printf.opam ├── src ├── dune ├── gen │ ├── dune │ ├── gen.ml │ └── gen.mli ├── ppx_custom_printf.ml └── ppx_custom_printf.mli └── test ├── custom_printf_sample.ml ├── dune ├── test.ml ├── test.mli └── test.mlt /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | *.install 3 | *.merlin 4 | _opam 5 | 6 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | profile=janestreet 2 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | ## v0.11 2 | 3 | Depend on ppxlib instead of (now deprecated) ppx\_core, ppx\_driver, 4 | ppx\_metaquot, ppx\_traverse and ppx\_type\_conv. 5 | 6 | ## 113.43.00 7 | 8 | - use the new context-free API 9 | 10 | ## 113.24.00 11 | 12 | - OCaml makes no distinctions between "foo" and 13 | `{whatever|foo|whatever}`. The delimiter choice is simply left to the 14 | user. 15 | 16 | Do the same in our ppx rewriters: i.e. wherever we accept "foo", also 17 | accept `{whatever|foo|whatever}`. 18 | 19 | - Fix missing location in errors for broken custom printf example like: 20 | 21 | printf !"%{sexp: int" 3;; 22 | 23 | - Update to follow `Ppx_core` evolution. 24 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | This repository contains open source software that is developed and 2 | maintained by [Jane Street][js]. 3 | 4 | Contributions to this project are welcome and should be submitted via 5 | GitHub pull requests. 6 | 7 | Signing contributions 8 | --------------------- 9 | 10 | We require that you sign your contributions. Your signature certifies 11 | that you wrote the patch or otherwise have the right to pass it on as 12 | an open-source patch. The rules are pretty simple: if you can certify 13 | the below (from [developercertificate.org][dco]): 14 | 15 | ``` 16 | Developer Certificate of Origin 17 | Version 1.1 18 | 19 | Copyright (C) 2004, 2006 The Linux Foundation and its contributors. 20 | 1 Letterman Drive 21 | Suite D4700 22 | San Francisco, CA, 94129 23 | 24 | Everyone is permitted to copy and distribute verbatim copies of this 25 | license document, but changing it is not allowed. 26 | 27 | 28 | Developer's Certificate of Origin 1.1 29 | 30 | By making a contribution to this project, I certify that: 31 | 32 | (a) The contribution was created in whole or in part by me and I 33 | have the right to submit it under the open source license 34 | indicated in the file; or 35 | 36 | (b) The contribution is based upon previous work that, to the best 37 | of my knowledge, is covered under an appropriate open source 38 | license and I have the right under that license to submit that 39 | work with modifications, whether created in whole or in part 40 | by me, under the same open source license (unless I am 41 | permitted to submit under a different license), as indicated 42 | in the file; or 43 | 44 | (c) The contribution was provided directly to me by some other 45 | person who certified (a), (b) or (c) and I have not modified 46 | it. 47 | 48 | (d) I understand and agree that this project and the contribution 49 | are public and that a record of the contribution (including all 50 | personal information I submit with it, including my sign-off) is 51 | maintained indefinitely and may be redistributed consistent with 52 | this project or the open source license(s) involved. 53 | ``` 54 | 55 | Then you just add a line to every git commit message: 56 | 57 | ``` 58 | Signed-off-by: Joe Smith 59 | ``` 60 | 61 | Use your real name (sorry, no pseudonyms or anonymous contributions.) 62 | 63 | If you set your `user.name` and `user.email` git configs, you can sign 64 | your commit automatically with git commit -s. 65 | 66 | [dco]: http://developercertificate.org/ 67 | [js]: https://opensource.janestreet.com/ 68 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | The MIT License 2 | 3 | Copyright (c) 2015--2025 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 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | INSTALL_ARGS := $(if $(PREFIX),--prefix $(PREFIX),) 2 | 3 | default: 4 | dune build 5 | 6 | install: 7 | dune install $(INSTALL_ARGS) 8 | 9 | uninstall: 10 | dune uninstall $(INSTALL_ARGS) 11 | 12 | reinstall: uninstall install 13 | 14 | clean: 15 | dune clean 16 | 17 | .PHONY: default install uninstall reinstall clean 18 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ppx_custom_printf 2 | ================= 3 | 4 | Extensions to printf-style format-strings for user-defined string conversion. 5 | 6 | `ppx_custom_printf` is a ppx rewriter that allows the use of 7 | user-defined string conversion functions in format strings (that is, 8 | strings passed to printf, sprintf, etc.). 9 | 10 | No new syntax is introduced. Instead a previously ill-typed use of 11 | the `!` operator is re-purposed. 12 | 13 | Basic Usage 14 | ----------- 15 | 16 | The basic usage is as follows: 17 | 18 | ```ocaml 19 | printf !"The time is %{Time} and the timezone is %{Time.Zone}." 20 | time zone 21 | ``` 22 | 23 | The ppx rewriter will turn the `!`-string into a format of type 24 | `(Time.t -> Time.Zone.t -> unit, unit, string) format`. This is done 25 | by embedding the `Time.to_string` and `Time.Zone.to_string` functions 26 | into the format, using the low-level format mechanism of the stdlib. 27 | 28 | In general, specifiers like `%{}` produce a call to 29 | `Module-path.to_string`. The module path can even be empty, in which 30 | case the generated code calls `to_string`. 31 | 32 | Note that you have to prepend the format string with a `!`, so that 33 | the ppx rewriter knows to operate on it. 34 | 35 | Sexps 36 | ----- 37 | 38 | The syntax `%{sexp:}` is also supported. For example: 39 | 40 | ```ocaml 41 | printf !"The time is %{sexp:Time.t}." time 42 | ``` 43 | 44 | The `time` argument will be turned into a string using: 45 | 46 | ```ocaml 47 | fun x -> Sexplib.Sexp.to_string_hum ([%sexp_of: Time.t] x) 48 | ``` 49 | 50 | This supports arbitrary type expressions. 51 | 52 | You can use `Sexplib.Sexp.to_string_mach` instead of 53 | `Sexplib.Sexp.to_string_hum` by using `%{sexp#mach:}` 54 | 55 | Using functions other than `M.to_string` 56 | ---------------------------------------- 57 | 58 | The format specifier `%{.}` 59 | corresponds to that function. So, for example: 60 | 61 | ```ocaml 62 | printf !"The date is %{Core.Date.to_string_iso8601_basic}" date 63 | ``` 64 | 65 | will turn `date` to a string using the following code: 66 | 67 | ```ocaml 68 | fun x -> Core.Date.to_string_iso8601_basic x 69 | ``` 70 | 71 | Further, the format specifier 72 | `%{#}` corresponds to the function 73 | `.to_string_`. So, for example: 74 | 75 | ```ocaml 76 | printf !"The date is %{Core.Date#american}" date 77 | ``` 78 | 79 | will turn `date` to a string using: 80 | 81 | ```ocaml 82 | fun x -> Core.Date.to_string_american x 83 | ``` 84 | 85 | Subformats disallowed 86 | --------------------- 87 | 88 | In a regular format string, you can use format specifiers of the form 89 | `%{%}` and `%(%)` where `` is another format 90 | specifier. 91 | 92 | Using these specifiers is disallowed in format strings that are 93 | processed with custom-printf. 94 | -------------------------------------------------------------------------------- /dune: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/janestreet/ppx_custom_printf/560ceade9b040a5ce6110c0b3769a455b39a41b3/dune -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.17) 2 | -------------------------------------------------------------------------------- /ppx_custom_printf.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Jane Street developers" 3 | authors: ["Jane Street Group, LLC"] 4 | homepage: "https://github.com/janestreet/ppx_custom_printf" 5 | bug-reports: "https://github.com/janestreet/ppx_custom_printf/issues" 6 | dev-repo: "git+https://github.com/janestreet/ppx_custom_printf.git" 7 | doc: "https://ocaml.janestreet.com/ocaml-core/latest/doc/ppx_custom_printf/index.html" 8 | license: "MIT" 9 | build: [ 10 | ["dune" "build" "-p" name "-j" jobs] 11 | ] 12 | depends: [ 13 | "ocaml" {>= "5.1.0"} 14 | "base" 15 | "ppx_sexp_conv" 16 | "dune" {>= "3.17.0"} 17 | "ppxlib" {>= "0.33.0" & < "0.36.0"} 18 | ] 19 | available: arch != "arm32" & arch != "x86_32" 20 | synopsis: "Printf-style format-strings for user-defined string conversion" 21 | description: " 22 | Part of the Jane Street's PPX rewriters collection. 23 | " 24 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ppx_custom_printf) 3 | (public_name ppx_custom_printf) 4 | (kind ppx_rewriter) 5 | (libraries compiler-libs.common base ppxlib ppx_sexp_conv.expander 6 | ppxlib.metaquot_lifters) 7 | (preprocess 8 | (pps ppxlib.metaquot ppxlib.traverse))) 9 | 10 | (rule 11 | (targets format_lifter.ml) 12 | (deps 13 | (:first_dep gen/gen.bc)) 14 | (action 15 | (run %{first_dep} -o format_lifter.ml))) 16 | -------------------------------------------------------------------------------- /src/gen/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (modes byte exe) 3 | (names gen) 4 | (libraries str compiler-libs.common compiler-libs.toplevel) 5 | (preprocess no_preprocessing)) 6 | -------------------------------------------------------------------------------- /src/gen/gen.ml: -------------------------------------------------------------------------------- 1 | open StdLabels 2 | open Format 3 | 4 | let lsplit2 s ~on = 5 | match String.index s on with 6 | | exception Not_found -> None 7 | | i -> 8 | Some 9 | ( String.sub s ~pos:0 ~len:i 10 | , String.sub s ~pos:(i + 1) ~len:(String.length s - i - 1) ) 11 | ;; 12 | 13 | let () = 14 | let oc = 15 | match Sys.argv with 16 | | [| _; "-o"; fn |] -> open_out_bin fn 17 | | _ -> failwith "bad command line arguments" 18 | in 19 | try 20 | let buf = Buffer.create 512 in 21 | let pp = formatter_of_buffer buf in 22 | pp_set_margin pp max_int; 23 | (* so we can parse line by line below *) 24 | Toploop.initialize_toplevel_env (); 25 | assert ( 26 | Lexing.from_string "include CamlinternalFormatBasics;;" 27 | |> !Toploop.parse_toplevel_phrase 28 | |> Toploop.execute_phrase true pp); 29 | let types = 30 | Buffer.contents buf 31 | |> Str.split (Str.regexp "\n") 32 | |> List.fold_left ~init:(false, []) ~f:(fun (in_type_group, acc) s -> 33 | match lsplit2 s ~on:' ' with 34 | | Some ("type", s) -> true, s :: acc 35 | | Some ("and", s) when in_type_group -> true, s :: acc 36 | | _ -> false, acc) 37 | |> snd 38 | |> List.rev 39 | in 40 | let s = 41 | String.concat 42 | ~sep:"\n" 43 | (match types with 44 | | [] -> [] 45 | | x :: l -> 46 | (("type " ^ x) :: List.map l ~f:(( ^ ) "and ")) 47 | @ [ "[@@deriving traverse_lift]" ]) 48 | in 49 | let intf = Parse.interface (Lexing.from_string s) in 50 | let ppf = formatter_of_out_channel oc in 51 | fprintf ppf "%a@." Pprintast.signature intf; 52 | close_out oc 53 | with 54 | | exn -> 55 | Location.report_exception Format.err_formatter exn; 56 | exit 2 57 | ;; 58 | -------------------------------------------------------------------------------- /src/gen/gen.mli: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/janestreet/ppx_custom_printf/560ceade9b040a5ce6110c0b3769a455b39a41b3/src/gen/gen.mli -------------------------------------------------------------------------------- /src/ppx_custom_printf.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | open Ppxlib 3 | open Ast_builder.Default 4 | 5 | (* returns the index of the conversion spec (unless the end of string is reached) *) 6 | let rec skip_over_format_flags fmt i = 7 | if i >= String.length fmt 8 | then `Eoi 9 | else ( 10 | match fmt.[i] with 11 | | '*' | '#' | '-' | ' ' | '+' | '_' | '0' .. '9' | '.' -> 12 | skip_over_format_flags fmt (i + 1) 13 | | _ -> `Ok i) 14 | ;; 15 | 16 | (* doesn't check to make sure the format string is well-formed *) 17 | (* Formats with subformats are skipped for the following reasons: 18 | 19 | One is that they are hard to understand and not often used. 20 | 21 | Another is that subformats like "%(%{Module}%)" won't work, since it 22 | is impossible to produce a format of type [(Module.t -> 'a,...) format]. 23 | *) 24 | let has_subformats (fmt : string) = 25 | let lim = String.length fmt - 1 in 26 | let rec loop i = 27 | if i > lim 28 | then false 29 | else if Char.equal fmt.[i] '%' 30 | then ( 31 | match skip_over_format_flags fmt (i + 1) with 32 | | `Eoi -> false 33 | | `Ok i -> 34 | (match fmt.[i] with 35 | | '(' | ')' | '}' -> true 36 | | _ -> loop (i + 1))) 37 | else loop (i + 1) 38 | in 39 | loop 0 40 | ;; 41 | 42 | (* returns a list of strings where even indexed elements are parts of the format string 43 | that the preprocessor won't touch and odd indexed elements are the contents of %{...} 44 | specifications. *) 45 | let explode ~loc (s : string) = 46 | let len = String.length s in 47 | (* for cases where we can't parse the string with custom format specifiers, consider 48 | the string as a regular format string *) 49 | let as_normal_format_string = [ s ] in 50 | if has_subformats s 51 | then as_normal_format_string 52 | else ( 53 | let sub from to_ = String.sub s ~pos:from ~len:(to_ - from) in 54 | let rec loop acc from to_ = 55 | assert (List.length acc % 2 = 0); 56 | if to_ >= len 57 | then List.rev (if from >= len then acc else sub from len :: acc) 58 | else if Char.( <> ) s.[to_] '%' 59 | then loop acc from (to_ + 1) 60 | else ( 61 | match skip_over_format_flags s (to_ + 1) with 62 | | `Eoi -> as_normal_format_string 63 | | `Ok i -> 64 | (match s.[i] with 65 | | '[' -> 66 | (* Scan char sets are not allowed by printf-like functions. So we might as 67 | well disallow them at compile-time so that we can reuse them as magic 68 | format strings in this implementation. *) 69 | Location.raise_errorf 70 | ~loc 71 | "ppx_custom_printf: scan char sets are not allowed in custom format \ 72 | strings" 73 | | '{' -> 74 | if to_ + 1 <> i 75 | then 76 | Location.raise_errorf 77 | ~loc 78 | "ppx_custom_printf: unexpected format flags before %%{} specification \ 79 | in %S" 80 | s; 81 | (match String.index_from s (to_ + 2) '}' with 82 | | None -> as_normal_format_string 83 | | Some i -> 84 | let l = sub (to_ + 2) i :: sub from to_ :: acc in 85 | loop l (i + 1) (i + 1)) 86 | | _ -> loop acc from (i + 1))) 87 | (* skip the conversion spec *) 88 | in 89 | loop [] 0 0) 90 | ;; 91 | 92 | let processed_format_string ~exploded_format_string = 93 | let l = 94 | let rec loop i l = 95 | match l with 96 | | s1 :: _s2 :: l -> s1 :: Printf.sprintf "%%%d[.]" i :: loop (i + 1) l 97 | | [ s1 ] -> [ s1 ] 98 | | [] -> [] 99 | in 100 | loop 0 exploded_format_string 101 | in 102 | String.concat l ~sep:"" 103 | ;; 104 | 105 | let rec evens = function 106 | | ([] | [ _ ]) as l -> l 107 | | x :: _ :: l -> x :: evens l 108 | ;; 109 | 110 | let odds = function 111 | | [] -> [] 112 | | _ :: l -> evens l 113 | ;; 114 | 115 | (* Returns a pair of: 116 | 117 | - a format string, which is [s] where all custom format specifications have been 118 | replaced by ["%" ^ string_of_int index ^ "[.]"] where [index] is the number of 119 | the custom format specification, starting from 0. This string can be passed directly 120 | to [CamlinternalFormat.fmt_ebb_of_string] 121 | - an array of custom format specifications, in the order they appear in the original 122 | string 123 | *) 124 | let extract_custom_format_specifications ~loc s = 125 | let exploded_format_string = explode ~loc s in 126 | let processed = processed_format_string ~exploded_format_string in 127 | let custom_specs = Array.of_list (odds exploded_format_string) in 128 | processed, custom_specs 129 | ;; 130 | 131 | let gen_symbol = gen_symbol ~prefix:"_custom_printf" 132 | 133 | let is_space = function 134 | | ' ' | '\t' | '\n' | '\r' -> true 135 | | _ -> false 136 | ;; 137 | 138 | let strip s = 139 | let a = ref 0 in 140 | let b = ref (String.length s - 1) in 141 | while !a <= !b && is_space s.[!a] do 142 | Int.incr a 143 | done; 144 | while !a <= !b && is_space s.[!b] do 145 | Int.decr b 146 | done; 147 | if !a > !b then "" else String.sub s ~pos:!a ~len:(!b - !a + 1) 148 | ;; 149 | 150 | let string_to_expr ~loc s = 151 | let sexp_converter_opt = 152 | match String.lsplit2 s ~on:':' with 153 | | None -> None 154 | | Some ("sexp", colon_suffix) -> 155 | Some ([%expr Ppx_sexp_conv_lib.Sexp.to_string_hum], colon_suffix) 156 | | Some (colon_prefix, colon_suffix) -> 157 | (match String.chop_prefix colon_prefix ~prefix:"sexp#" with 158 | | None -> None 159 | | Some hash_suffix -> 160 | Some 161 | ( pexp_ident 162 | ~loc 163 | (Located.mk 164 | ~loc 165 | (Longident.parse ("Ppx_sexp_conv_lib.Sexp.to_string_" ^ hash_suffix))) 166 | , colon_suffix )) 167 | in 168 | match sexp_converter_opt with 169 | | Some (sexp_converter, unparsed_type) -> 170 | let lexbuf = Lexing.from_string unparsed_type in 171 | (* ~loc is the position of the string, not the position of the %{bla} group we're 172 | looking at. The format strings don't contain location information, so we can't 173 | actually find the proper positions. *) 174 | lexbuf.lex_abs_pos <- loc.loc_start.pos_cnum; 175 | lexbuf.lex_curr_p <- loc.loc_start; 176 | let ty = Parse.core_type lexbuf in 177 | let e = Ppx_sexp_conv_expander.Sexp_of.core_type ty ~localize:false in 178 | let arg = gen_symbol () in 179 | pexp_fun 180 | ~loc 181 | Nolabel 182 | None 183 | (pvar ~loc arg) 184 | (eapply ~loc sexp_converter [ eapply ~loc e [ evar ~loc arg ] ]) 185 | | None -> 186 | let fail loc = 187 | Location.raise_errorf 188 | ~loc 189 | "ppx_custom_printf: string %S should be of the form , \ 190 | ., #identifier, sexp:, or sexp#mach:" 191 | s 192 | in 193 | let s, has_hash_suffix, to_string = 194 | match String.lsplit2 s ~on:'#' with 195 | | None -> s, false, "to_string" 196 | | Some (s, hash_suffix) -> s, true, "to_string_" ^ hash_suffix 197 | in 198 | let to_string_id : Longident.t = 199 | let s = strip s in 200 | match s with 201 | | "" -> Lident to_string 202 | | _ -> 203 | (match Longident.parse s with 204 | | (Lident n | Ldot (_, n)) as id -> 205 | if String.( <> ) n "" && Char.equal (Char.uppercase n.[0]) n.[0] 206 | then Longident.Ldot (id, to_string) 207 | else if not has_hash_suffix 208 | then id 209 | else fail loc 210 | | _ -> fail loc) 211 | in 212 | let func = pexp_ident ~loc (Located.mk ~loc to_string_id) in 213 | (* Eta-expand as the to_string function might take optional arguments *) 214 | let arg = gen_symbol () in 215 | pexp_fun ~loc Nolabel None (pvar ~loc arg) (eapply ~loc func [ evar ~loc arg ]) 216 | ;; 217 | 218 | class lifter ~loc ~custom_specs = 219 | object (self) 220 | inherit [expression] Format_lifter.lift as super 221 | inherit Ppxlib_metaquot_lifters.expression_lifters loc 222 | 223 | method! fmt 224 | : type f0 225 | f1 226 | f2 227 | f3 228 | f4 229 | f5. (f0 -> expression) 230 | -> (f1 -> expression) 231 | -> (f2 -> expression) 232 | -> (f3 -> expression) 233 | -> (f4 -> expression) 234 | -> (f5 -> expression) 235 | -> (f0, f1, f2, f3, f4, f5) CamlinternalFormatBasics.fmt 236 | -> expression = 237 | fun f0 f1 f2 f3 f4 f5 fmt -> 238 | let open CamlinternalFormatBasics in 239 | match fmt with 240 | (* Recognize the special form "%index[...whatever...]" *) 241 | | Scan_char_set (Some idx, _, fmt) 242 | (* [custom_specs] is empty if [explode] couldn't parse the string. In this case we 243 | can have some scar char sets left. *) 244 | when idx >= 0 && idx < Array.length custom_specs -> 245 | let rest = self#fmt (fun _ -> assert false) f1 f2 f3 f4 f5 fmt in 246 | let func = string_to_expr ~loc custom_specs.(idx) in 247 | [%expr Custom (Custom_succ Custom_zero, (fun () -> [%e func]), [%e rest])] 248 | | _ -> super#fmt f0 f1 f2 f3 f4 f5 fmt 249 | end 250 | 251 | let expand_format_string ~loc fmt_string = 252 | let processed_fmt_string, custom_specs = 253 | extract_custom_format_specifications ~loc fmt_string 254 | in 255 | let (CamlinternalFormat.Fmt_EBB fmt) = 256 | try CamlinternalFormat.fmt_ebb_of_string processed_fmt_string with 257 | | e -> 258 | Location.raise_errorf 259 | ~loc 260 | "%s" 261 | (match e with 262 | (* [fmt_ebb_of_string] normally raises [Failure] on invalid input *) 263 | | Failure msg -> msg 264 | | e -> Exn.to_string e) 265 | in 266 | let lifter = new lifter ~loc ~custom_specs in 267 | let format6 = CamlinternalFormatBasics.Format (fmt, fmt_string) in 268 | let phantom _ = assert false in 269 | let e = lifter#format6 phantom phantom phantom phantom phantom phantom format6 in 270 | [%expr ([%e e] : (_, _, _, _, _, _) CamlinternalFormatBasics.format6)] 271 | ;; 272 | 273 | let expand e = 274 | match e.pexp_desc with 275 | | Pexp_apply 276 | ( { pexp_attributes = ident_attrs; _ } 277 | , [ ( Nolabel 278 | , { pexp_desc = Pexp_constant (Pconst_string (str, _, _)) 279 | ; pexp_loc = loc 280 | ; pexp_loc_stack = _ 281 | ; pexp_attributes = str_attrs 282 | } ) 283 | ] ) -> 284 | assert_no_attributes ident_attrs; 285 | assert_no_attributes str_attrs; 286 | let e' = expand_format_string ~loc str in 287 | Some { e' with pexp_attributes = Merlin_helpers.hide_attribute :: e.pexp_attributes } 288 | | _ -> None 289 | ;; 290 | 291 | let () = 292 | Driver.register_transformation 293 | "custom_printf" 294 | ~rules:[ Context_free.Rule.special_function "!" expand ] 295 | ;; 296 | -------------------------------------------------------------------------------- /src/ppx_custom_printf.mli: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/janestreet/ppx_custom_printf/560ceade9b040a5ce6110c0b3769a455b39a41b3/src/ppx_custom_printf.mli -------------------------------------------------------------------------------- /test/custom_printf_sample.ml: -------------------------------------------------------------------------------- 1 | module Test = Test 2 | -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name custom_printf_sample) 3 | (libraries ppx_sexp_conv.runtime-lib) 4 | (preprocess 5 | (pps ppx_jane))) 6 | 7 | (alias 8 | (name DEFAULT) 9 | (deps test.ml.pp)) 10 | -------------------------------------------------------------------------------- /test/test.ml: -------------------------------------------------------------------------------- 1 | let sprintf = Printf.sprintf 2 | let ksprintf = Printf.ksprintf 3 | 4 | open Ppx_sexp_conv_lib.Conv 5 | 6 | module Time : sig 7 | type t 8 | 9 | val now : unit -> t 10 | val to_string : t -> string 11 | val to_string_sec : t -> string 12 | val to_string_abs : t -> string 13 | end = struct 14 | type t = string 15 | 16 | let now () = "Time.now ()" 17 | let to_string t = "[Time.to_string (" ^ t ^ ")]" 18 | let to_string_sec t = "[Time.to_string_sec (" ^ t ^ ")]" 19 | let to_string_abs t = "[Time.to_string_abs (" ^ t ^ ")]" 20 | end 21 | 22 | module Zone : sig 23 | type t 24 | 25 | val local : t 26 | val to_string : t -> string 27 | end = struct 28 | type t = string 29 | 30 | let local = "Zone.local" 31 | let to_string t = "[Zone.to_string " ^ t ^ "]" 32 | end 33 | 34 | let%test _ = 35 | sprintf !"The time is %{Time} and the timezone is %{Zone}.\n" (Time.now ()) Zone.local 36 | = "The time is [Time.to_string (Time.now ())] and the timezone is [Zone.to_string \ 37 | Zone.local].\n" 38 | ;; 39 | 40 | (* check that custom directives with nothing in between are properly translated *) 41 | let%test _ = sprintf !"%{sexp:int}%{sexp:int}%{sexp:int}%{sexp:int}" 1 2 3 4 = "1234" 42 | 43 | (* check that things works well when the conversion function take optional arguments *) 44 | let%test _ = 45 | let to_string ?foo:_ x = string_of_int x in 46 | sprintf !"%{to_string}\n" 42 = "42\n" 47 | ;; 48 | 49 | (* check the X#y kinds of format and that arguments are not 50 | reversed somehow *) 51 | let%test _ = 52 | let now = Time.now () in 53 | sprintf !"%{Time}, %{Time#sec}, %{Time.to_string_abs}\n%!" now now now 54 | = "[Time.to_string (Time.now ())], [Time.to_string_sec (Time.now ())], \ 55 | [Time.to_string_abs (Time.now ())]\n" 56 | ;; 57 | 58 | (* same as above, with empty module paths *) 59 | let%test _ = 60 | let open Time in 61 | let now = now () in 62 | sprintf !"%{}, %{#sec}, %{to_string_abs}\n%!" now now now 63 | = "[Time.to_string (Time.now ())], [Time.to_string_sec (Time.now ())], \ 64 | [Time.to_string_abs (Time.now ())]\n" 65 | ;; 66 | 67 | (* testing what happens if the expression to the left of the format string 68 | is a bit complicated *) 69 | let%test _ = 70 | let s = ksprintf (fun s -> s ^ " foo") !"%{Time} bar" (Time.now ()) in 71 | s = "[Time.to_string (Time.now ())] bar foo" 72 | ;; 73 | 74 | (* checking sexp: format *) 75 | let%test "sexp conversion" = 76 | sprintf !"The pair is: %{sexp:int * string}" (4, "asdf") = "The pair is: (4 asdf)" 77 | ;; 78 | 79 | (* checking sexp#mach: format *) 80 | let%test "sexp#mach conversion" = 81 | let module Ppx_sexp_conv_lib = struct 82 | module Sexp = struct 83 | include Ppx_sexp_conv_lib.Sexp 84 | 85 | let to_string_mach sexp = to_string sexp ^ " (in machine format)" 86 | end 87 | end 88 | in 89 | sprintf !"The pair is: %{sexp#mach:int * string}" (4, "asdf") 90 | = "The pair is: (4 asdf) (in machine format)" 91 | ;; 92 | 93 | (* checking tricky formats *) 94 | let%test _ = sprintf !"%d %%{foo" 3 = "3 %{foo" 95 | 96 | let%test _ = 97 | sprintf !"%d %%{%{Time}" 3 (Time.now ()) = "3 %{[Time.to_string (Time.now ())]" 98 | ;; 99 | 100 | (* checking that when we eta expand, we do not change side effects *) 101 | let%test _ = 102 | let side_effect1_happened = ref false in 103 | let side_effect2_happened = ref false in 104 | let _f : Zone.t -> string = 105 | (side_effect1_happened := true; 106 | sprintf) 107 | !"%{Time} %{Zone}" 108 | (side_effect2_happened := true; 109 | Time.now ()) 110 | in 111 | !side_effect1_happened && !side_effect2_happened 112 | ;; 113 | 114 | let%test _ = 115 | let to_string () = "plop" in 116 | sprintf !"%{ }" () = "plop" 117 | ;; 118 | 119 | let%test_unit _ = 120 | let f ~labeled_arg:() fmt = ksprintf (fun _ -> ()) fmt in 121 | (* Check that it compiles with the labeled argument applied both before and after the 122 | format string *) 123 | f ~labeled_arg:() !"hello"; 124 | f !"hello" ~labeled_arg:() 125 | ;; 126 | 127 | let%test_unit _ = 128 | let after1 = Some () in 129 | let f ~before:() fmt = ksprintf (fun _ ?after1:_ () ~after2:() -> ()) fmt in 130 | f ~before:() ?after1 !"hello" () ~after2:(); 131 | f ~before:() !"hello" ?after1 () ~after2:(); 132 | f !"hello" ~before:() ?after1 () ~after2:(); 133 | f !"hello" ?after1 ~before:() () ~after2:() 134 | ;; 135 | 136 | let%test_unit _ = 137 | let f ~label:() fmt = ksprintf (fun _ -> ()) fmt in 138 | let r = ref 0 in 139 | let g = f !"%{Time}" ~label:(incr r) in 140 | g (Time.now ()); 141 | g (Time.now ()); 142 | assert (!r = 1) 143 | ;; 144 | 145 | let%test "format subst" = sprintf !"%(%d%)" "[%d]" 1 = "[1]" 146 | let first_class_format1 = !"u = %{sexp:int * int}" 147 | let first_class_format2 = !"t = %{Time}" 148 | 149 | let first_class_format3 = 150 | first_class_format1 ^^ ", " ^^ first_class_format2 ^^ !", v = %{sexp:int}" 151 | ;; 152 | 153 | let%test _ = sprintf first_class_format1 (0, 42) = "u = (0 42)" 154 | 155 | let%test _ = 156 | sprintf first_class_format2 (Time.now ()) = "t = [Time.to_string (Time.now ())]" 157 | ;; 158 | 159 | let%test _ = 160 | sprintf first_class_format3 (0, 42) (Time.now ()) 10 161 | = "u = (0 42), t = [Time.to_string (Time.now ())], v = 10" 162 | ;; 163 | -------------------------------------------------------------------------------- /test/test.mli: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/janestreet/ppx_custom_printf/560ceade9b040a5ce6110c0b3769a455b39a41b3/test/test.mli -------------------------------------------------------------------------------- /test/test.mlt: -------------------------------------------------------------------------------- 1 | #print_column_numbers true 2 | 3 | let f () = !"%{sexp:nosuchtype}" 4 | 5 | [%%expect 6 | {| 7 | Line _, characters 12-22: 8 | Error: Unbound value sexp_of_nosuchtype 9 | |}] 10 | --------------------------------------------------------------------------------