├── dune-project ├── test ├── import.ml ├── test_comments.mli ├── test_pretty_print.mli ├── sexp_pretty_test.ml ├── dune ├── test_comments.ml └── test_pretty_print.ml ├── .ocamlformat ├── .gitignore ├── src ├── sexp_pretty.mli ├── dune ├── pretty_print_config_example.sexp ├── sexp_pretty_intf.ml ├── config.mli ├── config.ml └── sexp_pretty.ml ├── README.org ├── CHANGES.md ├── Makefile ├── sexp_pretty.opam ├── LICENSE.md └── CONTRIBUTING.md /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.17) 2 | -------------------------------------------------------------------------------- /test/import.ml: -------------------------------------------------------------------------------- 1 | include Core 2 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | profile=janestreet 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | *.install 3 | *.merlin 4 | _opam 5 | 6 | -------------------------------------------------------------------------------- /src/sexp_pretty.mli: -------------------------------------------------------------------------------- 1 | include Sexp_pretty_intf.Sexp_pretty 2 | -------------------------------------------------------------------------------- /test/test_comments.mli: -------------------------------------------------------------------------------- 1 | (*_ This signature is deliberately empty. *) 2 | -------------------------------------------------------------------------------- /test/test_pretty_print.mli: -------------------------------------------------------------------------------- 1 | (*_ This signature is deliberately empty. *) 2 | -------------------------------------------------------------------------------- /README.org: -------------------------------------------------------------------------------- 1 | 2 | A library for pretty-printing s-expressions, using better indentation rules than 3 | the default pretty printer in Sexplib. 4 | -------------------------------------------------------------------------------- /test/sexp_pretty_test.ml: -------------------------------------------------------------------------------- 1 | module Import = Import 2 | module Test_comments = Test_comments 3 | module Test_pretty_print = Test_pretty_print 4 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | ## Release v0.16.0 2 | 3 | * Added `Bright` versions of colors to `Config.color`. 4 | 5 | * Refer to `Stdlib` instead of `Caml`. 6 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name sexp_pretty) 3 | (public_name sexp_pretty) 4 | (preprocess 5 | (pps ppx_base)) 6 | (libraries base parsexp re sexplib)) 7 | -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name sexp_pretty_test) 3 | (libraries textutils.ascii_table_kernel base_quickcheck core 4 | expect_test_helpers_core.expect_test_helpers_base expect_test_helpers_core 5 | sexp_pretty sexp_string_quickcheck sexplib) 6 | (preprocess 7 | (pps ppx_jane))) 8 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /src/pretty_print_config_example.sexp: -------------------------------------------------------------------------------- 1 | ;; -*- mode: lisp; -*- 2 | ((indent 2) 3 | (data_alignment ( 4 | Data_aligned 5 | (Parens_alignment true) 6 | (Atom_threshold 6) 7 | (Character_threshold 60) 8 | (Depth_threshold 3))) 9 | (color_scheme (Magenta Yellow Cyan White)) 10 | (atom_coloring (Color_first 3)) 11 | (atom_printing Escaped) 12 | (paren_coloring true) 13 | (comments (Print (Indent_comment 3) (Green) Pretty_print)) 14 | (singleton_limit ( 15 | Singleton_limit 16 | (Atom_threshold 3) 17 | (Character_threshold 20))) 18 | (leading_threshold ( 19 | (Atom_threshold 3) 20 | (Character_threshold 15)))) 21 | -------------------------------------------------------------------------------- /sexp_pretty.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Jane Street developers" 3 | authors: ["Jane Street Group, LLC"] 4 | homepage: "https://github.com/janestreet/sexp_pretty" 5 | bug-reports: "https://github.com/janestreet/sexp_pretty/issues" 6 | dev-repo: "git+https://github.com/janestreet/sexp_pretty.git" 7 | doc: "https://ocaml.janestreet.com/ocaml-core/latest/doc/sexp_pretty/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 | "parsexp" 16 | "ppx_base" 17 | "sexplib" 18 | "dune" {>= "3.17.0"} 19 | "re" {>= "1.8.0"} 20 | ] 21 | available: arch != "arm32" & arch != "x86_32" 22 | synopsis: "S-expression pretty-printer" 23 | description: " 24 | A library for pretty-printing s-expressions, using better indentation rules than 25 | the default pretty printer in Sexplib. 26 | " 27 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | The MIT License 2 | 3 | Copyright (c) 2016--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 | -------------------------------------------------------------------------------- /src/sexp_pretty_intf.ml: -------------------------------------------------------------------------------- 1 | open! Base 2 | 3 | module type S = sig 4 | type sexp 5 | type 'a writer = Config.t -> 'a -> sexp -> unit 6 | 7 | (** [pp_formatter conf fmt sexp] will mutate the fmt with functions such as 8 | [set_formatter_tag_functions] *) 9 | val pp_formatter : Stdlib.Format.formatter writer 10 | 11 | val pp_formatter' 12 | : next:(unit -> sexp option) 13 | -> Config.t 14 | -> Stdlib.Format.formatter 15 | -> unit 16 | 17 | val pp_buffer : Buffer.t writer 18 | val pp_out_channel : Stdlib.out_channel writer 19 | val pp_blit : (string, unit) Blit.sub_global writer 20 | 21 | (** [pretty_string] needs to allocate. If you care about performance, using one of the 22 | [pp_*] functions above is advised. *) 23 | val pretty_string : Config.t -> sexp -> string 24 | 25 | val sexp_to_string : sexp -> string 26 | end 27 | 28 | (** Pretty-printing of S-expressions *) 29 | module type Sexp_pretty = sig 30 | module Config = Config 31 | 32 | module type S = S 33 | 34 | include S with type sexp := Sexp.t 35 | module Sexp_with_layout : S with type sexp := Sexplib.Sexp.With_layout.t_or_comment 36 | module Parsexp_cst : S with type sexp := Parsexp.Cst.t_or_comment 37 | 38 | module Normalize : sig 39 | type t = 40 | (* Contains a sexp with associated comments. *) 41 | | Sexp of sexp * string list 42 | | Comment of comment 43 | 44 | and comment = 45 | | Line_comment of string 46 | (* Does not contain the "#|" "|#"; contains its indentation size. *) 47 | | Block_comment of int * string list 48 | | Sexp_comment of comment list * sexp 49 | 50 | and sexp = 51 | | Atom of string 52 | | List of t list 53 | 54 | val of_sexp_or_comment : Config.t -> Parsexp.Cst.t_or_comment -> t 55 | end 56 | 57 | val sexp_to_sexp_or_comment : Config.t -> Sexp.t -> Parsexp.Cst.t_or_comment 58 | 59 | val sexp_with_layout_to_sexp_or_comment 60 | : Sexplib.Sexp.With_layout.t_or_comment 61 | -> Parsexp.Cst.t_or_comment 62 | end 63 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /src/config.mli: -------------------------------------------------------------------------------- 1 | open! Base 2 | 3 | type color = 4 | | Black 5 | | Red 6 | | Green 7 | | Yellow 8 | | Blue 9 | | Magenta 10 | | Cyan 11 | | White 12 | | BrightBlack 13 | | BrightRed 14 | | BrightGreen 15 | | BrightYellow 16 | | BrightBlue 17 | | BrightMagenta 18 | | BrightCyan 19 | | BrightWhite 20 | | Default 21 | [@@deriving sexp] 22 | 23 | (** Datatypes of various thresholds *) 24 | type atom_threshold = Atom_threshold of int [@@deriving sexp] 25 | 26 | type char_threshold = Character_threshold of int [@@deriving sexp] 27 | 28 | (** Depth is the depth of an atom. For example, in (a (b (c) d)), the depth of a is 1, the 29 | depth of b and d is 2, and depth of c is 3. Depth_threshold usually refers to the 30 | maximum depth of any atom in a list for it to be considered for certain heuristic, 31 | e.g. data alignment. *) 32 | type depth_threshold = Depth_threshold of int [@@deriving sexp] 33 | 34 | (** Whether or not should closing parentheses be aligned. *) 35 | type aligned_parens = Parens_alignment of bool [@@deriving sexp] 36 | 37 | type data_alignment = 38 | | Data_not_aligned 39 | | Data_aligned of aligned_parens * atom_threshold * char_threshold * depth_threshold 40 | (** Character threshold is excluding spaces and parentheses, the maximum depth can't 41 | exceed the depth threshold. *) 42 | [@@deriving sexp] 43 | 44 | type atom_coloring = 45 | | Color_first of int 46 | (** Color the first one, only if the number of atoms that follow it at most the value of 47 | the constructor's argument. *) 48 | | Color_all 49 | | Color_none 50 | [@@deriving sexp] 51 | 52 | (** This currently relates only to block comments. [Auto_indent] tries to infer the 53 | indentation from the original formatting, [Indent_comment n] indents new lines in a 54 | block comment by n spaces. *) 55 | type comment_indent = 56 | | Auto_indent_comment 57 | | Indent_comment of int 58 | [@@deriving sexp] 59 | 60 | type comment_print_style = 61 | | Pretty_print (** Auto aligns multi-line block comments. *) 62 | | Conservative_print (** Leaves block comments as they are, only adjusts indentation. *) 63 | [@@deriving enumerate, sexp] 64 | 65 | (** Comment treatment. *) 66 | type comments = 67 | | Drop 68 | | Print of comment_indent * color option * comment_print_style 69 | [@@deriving sexp] 70 | 71 | type atom_printing = 72 | | Escaped (** Can be parsed again. Atoms are printed out as loaded, with escaping. *) 73 | | Minimal_escaping (** As [Escaped], but applies escaping to fewer characters. *) 74 | | Interpreted (** Try to interpret atoms as sexps. *) 75 | [@@deriving sexp] 76 | 77 | (** Singleton_lists are lists of the following format 78 | 79 | {v 80 | (ATOM_1 .. ATOM_N (....)) 81 | v} 82 | 83 | and are printed in the following way if they are too big to fit on a line/force a 84 | breakline for other reasons: 85 | 86 | {v 87 | (ATOM_1 .. ATOM_N ( 88 | .... 89 | )) 90 | v} 91 | 92 | Thresholds correspond to what's an acceptable number/size of the leading atoms ATOM_1 93 | through ATOM_N. 94 | 95 | Character threshold is excluding spaces. *) 96 | type singleton_limit = Singleton_limit of atom_threshold * char_threshold 97 | [@@deriving sexp] 98 | 99 | (** Should parentheses be colored? *) 100 | type paren_coloring = bool [@@deriving sexp] 101 | 102 | (** Separator between individual sexps. *) 103 | type separator = 104 | | No_separator 105 | | Empty_line 106 | [@@deriving sexp] 107 | 108 | (** Should closing parentheses be on the same line as the last sexp in the list (modulo 109 | comments), or should they be on new lines? Should opening parentheses always be on the 110 | same line as what follows them, or should they sometimes (when the first item in the 111 | list is a list followed by some other sexp) be on a separate line? *) 112 | type parens = 113 | | Same_line 114 | | New_line 115 | [@@deriving sexp] 116 | 117 | (** Where to put line comments relative to an associated sexp. *) 118 | type sticky_comments = 119 | | Before 120 | | Same_line 121 | | After 122 | [@@deriving sexp] 123 | 124 | type encoding = 125 | | Ascii 126 | | Utf8 127 | [@@deriving enumerate, sexp] 128 | 129 | type t = 130 | { indent : int 131 | ; data_alignment : data_alignment 132 | ; color_scheme : color iarray 133 | ; atom_coloring : atom_coloring 134 | ; atom_printing : atom_printing 135 | ; paren_coloring : paren_coloring 136 | ; opening_parens : parens 137 | ; closing_parens : parens 138 | ; comments : comments 139 | ; singleton_limit : singleton_limit 140 | ; leading_threshold : atom_threshold * char_threshold 141 | ; separator : separator 142 | ; sticky_comments : sticky_comments 143 | ; encoding : encoding 144 | } 145 | [@@deriving sexp] 146 | 147 | val default : t 148 | 149 | val create 150 | : ?color:bool 151 | -> ?interpret_atom_as_sexp:bool 152 | -> ?drop_comments:bool 153 | -> ?new_line_separator:bool 154 | -> ?custom_data_alignment:data_alignment 155 | -> ?encoding:encoding 156 | -> unit 157 | -> t 158 | 159 | val update 160 | : ?color:bool 161 | -> ?interpret_atom_as_sexp:bool 162 | -> ?drop_comments:bool 163 | -> ?new_line_separator:bool 164 | -> ?custom_data_alignment:data_alignment 165 | -> ?encoding:encoding 166 | -> t 167 | -> t 168 | -------------------------------------------------------------------------------- /src/config.ml: -------------------------------------------------------------------------------- 1 | open! Base 2 | 3 | let of_sexp_error = Sexplib.Conv.of_sexp_error 4 | 5 | type color = 6 | | Black 7 | | Red 8 | | Green 9 | | Yellow 10 | | Blue 11 | | Magenta 12 | | Cyan 13 | | White 14 | | BrightBlack 15 | | BrightRed 16 | | BrightGreen 17 | | BrightYellow 18 | | BrightBlue 19 | | BrightMagenta 20 | | BrightCyan 21 | | BrightWhite 22 | | Default 23 | [@@deriving sexp] 24 | 25 | (* Datatypes of various thresholds *) 26 | type atom_threshold = Atom_threshold of int [@@deriving sexp] 27 | 28 | let atom_threshold_of_sexp sexp = 29 | match atom_threshold_of_sexp sexp with 30 | | Atom_threshold n when n < 0 -> 31 | of_sexp_error "Atom threshold must be non_negative." sexp 32 | | threshold -> threshold 33 | ;; 34 | 35 | type char_threshold = Character_threshold of int [@@deriving sexp] 36 | 37 | let char_threshold_of_sexp sexp = 38 | match char_threshold_of_sexp sexp with 39 | | Character_threshold n when n < 0 -> 40 | of_sexp_error "Character threshold must be non_negative." sexp 41 | | threshold -> threshold 42 | ;; 43 | 44 | (* Depth is the depth of an atom. For example, in (a (b (c) d)), the depth of a is 1, the 45 | depth of b and d is 2, and depth of c is 3. 46 | Depth_threshold usually refers to the maximum depth of any atom in a list for it to be 47 | considered for certain heuristic, e.g. data alignment. 48 | *) 49 | type depth_threshold = Depth_threshold of int [@@deriving sexp] 50 | 51 | let depth_threshold_of_sexp sexp = 52 | match depth_threshold_of_sexp sexp with 53 | | Depth_threshold n when n < 1 -> 54 | of_sexp_error "Depth threshold must be greater than 0." sexp 55 | | threshold -> threshold 56 | ;; 57 | 58 | (* Whether or not should closing parentheses be aligned. *) 59 | type aligned_parens = Parens_alignment of bool [@@deriving sexp] 60 | 61 | type data_alignment = 62 | | Data_not_aligned 63 | (* Character threshold is excluding spaces and parentheses, the maximum depth can't exceed 64 | the depth threshold. 65 | *) 66 | | Data_aligned of aligned_parens * atom_threshold * char_threshold * depth_threshold 67 | [@@deriving sexp] 68 | 69 | type atom_coloring = 70 | (* Color the first one, only if the number of atoms that follow it at most the value of 71 | the constructor's argument. 72 | *) 73 | | Color_first of int 74 | | Color_all 75 | | Color_none 76 | [@@deriving sexp] 77 | 78 | let atom_coloring_of_sexp sexp = 79 | match atom_coloring_of_sexp sexp with 80 | | Color_first n when n < 0 -> 81 | of_sexp_error "The limit to color atoms must be non-negative." sexp 82 | | coloring -> coloring 83 | ;; 84 | 85 | (* This currently relates only to block comments. [Auto_indent] tries to infer the 86 | indentation from the original formatting, [Indent_comment n] indents new lines in a 87 | block comment by n spaces. 88 | *) 89 | type comment_indent = 90 | | Auto_indent_comment 91 | | Indent_comment of int 92 | [@@deriving sexp] 93 | 94 | let comment_indent_of_sexp sexp = 95 | match comment_indent_of_sexp sexp with 96 | | Indent_comment n when n < 0 -> of_sexp_error "Indentation must be non-negative." sexp 97 | | indent -> indent 98 | ;; 99 | 100 | type comment_print_style = 101 | (* Auto aligns multi-line block comments. *) 102 | | Pretty_print 103 | (* Leaves block comments as they are, only adjusts indentation. *) 104 | | Conservative_print 105 | [@@deriving enumerate, sexp] 106 | 107 | (* Comment treatment. *) 108 | type comments = 109 | | Drop 110 | | Print of comment_indent * color option * comment_print_style 111 | [@@deriving sexp] 112 | 113 | type atom_printing = 114 | | Escaped (* Can be parsed again. Atoms are printed out as loaded, with escaping. *) 115 | | Minimal_escaping (* As [Escaped], but applies escaping to fewer characters. *) 116 | | Interpreted (* Try to interpret atoms as sexps. *) 117 | [@@deriving sexp] 118 | 119 | (* Singleton_lists are lists of the following format 120 | 121 | (ATOM_1 .. ATOM_N (....)) 122 | 123 | and are printed in the following way if they are too big to fit on a line/force a 124 | breakline for other reasons: 125 | 126 | (ATOM_1 .. ATOM_N ( 127 | .... 128 | )) 129 | 130 | Thresholds correspond to what's an acceptable number/size of the leading atoms ATOM_1 131 | through ATOM_N. 132 | 133 | Character threshold is excluding spaces. 134 | *) 135 | type singleton_limit = Singleton_limit of atom_threshold * char_threshold 136 | [@@deriving sexp] 137 | 138 | (* Should parentheses be colored? *) 139 | type paren_coloring = bool [@@deriving sexp] 140 | 141 | (* Separator between individual sexps. *) 142 | type separator = 143 | | No_separator 144 | | Empty_line 145 | [@@deriving sexp] 146 | 147 | (* Should closing parentheses be on the same line as the last sexp in the list (modulo 148 | comments), or should they be on new lines? 149 | Should opening parentheses always be on the same line as what follows them, or should 150 | they sometimes (when the first item in the list is a list followed by some other sexp) 151 | be on a separate line? 152 | *) 153 | type parens = 154 | | Same_line 155 | | New_line 156 | [@@deriving sexp] 157 | 158 | (* Where to put the line comments corresponding to some sexp? 159 | For example, if the original input is 160 | 161 | {v 162 | SEXP ;comment1 163 | ;comment2 164 | v} 165 | 166 | If [Before], put comments in lines before the sexp: 167 | 168 | {v 169 | ;comment1 170 | ;comment2 171 | SEXP 172 | v} 173 | 174 | If [Same_line], put the first comment right after the sexp, on the same line, 175 | and align the rest of the comments: 176 | 177 | {v 178 | SEXP ;comment1 179 | ;comment2 180 | v} 181 | 182 | If [After], put comments in lines after the sexp: 183 | 184 | {v 185 | SEXP 186 | ;comment1 187 | ;comment2 188 | v} 189 | *) 190 | type sticky_comments = 191 | | Before 192 | | Same_line 193 | | After 194 | [@@deriving sexp] 195 | 196 | type encoding = 197 | | Ascii 198 | | Utf8 199 | [@@deriving enumerate, sexp] 200 | 201 | type t = 202 | { (* The size of indentation in number of spaces. *) 203 | indent : int [@default 2] 204 | ; (* Alignment of sexp list into columns. *) 205 | data_alignment : data_alignment 206 | [@default 207 | Data_aligned 208 | ( Parens_alignment false 209 | , Atom_threshold 6 210 | , Character_threshold 60 211 | , Depth_threshold 3 )] 212 | ; color_scheme : color iarray 213 | ; atom_coloring : atom_coloring [@default Color_first 3] 214 | ; atom_printing : atom_printing [@default Escaped] 215 | ; paren_coloring : paren_coloring [@default true] 216 | ; opening_parens : parens [@default Same_line] 217 | ; closing_parens : parens [@default Same_line] 218 | ; comments : comments [@default Print (Indent_comment 3, Some Green, Pretty_print)] 219 | ; singleton_limit : singleton_limit 220 | [@default Singleton_limit (Atom_threshold 3, Character_threshold 15)] 221 | ; (* Number of atoms that will be marked as leading in regular lists. They will be put on 222 | a single line, if they fit. 223 | *) 224 | leading_threshold : atom_threshold * char_threshold 225 | [@default Atom_threshold 3, Character_threshold 20] 226 | ; separator : separator [@default Empty_line] 227 | ; sticky_comments : sticky_comments [@default After] 228 | ; encoding : encoding [@default Ascii] 229 | } 230 | [@@deriving sexp] 231 | 232 | let t_of_sexp sexp = 233 | let t = t_of_sexp sexp in 234 | if t.indent < 0 then of_sexp_error "Indentation must be non-negative." sexp else t 235 | ;; 236 | 237 | let default_color_scheme = Iarray.of_array [| Magenta; Yellow; Cyan; White |] 238 | 239 | let default = 240 | { indent = 2 241 | ; data_alignment = 242 | Data_aligned 243 | ( Parens_alignment false 244 | , Atom_threshold 6 245 | , Character_threshold 50 246 | , Depth_threshold 3 ) 247 | ; color_scheme = default_color_scheme 248 | ; atom_coloring = Color_first 3 249 | ; atom_printing = Escaped 250 | ; paren_coloring = true 251 | ; closing_parens = Same_line 252 | ; opening_parens = Same_line 253 | ; comments = Print (Indent_comment 3, Some Green, Pretty_print) 254 | ; singleton_limit = Singleton_limit (Atom_threshold 3, Character_threshold 40) 255 | ; leading_threshold = Atom_threshold 3, Character_threshold 40 256 | ; separator = Empty_line 257 | ; sticky_comments = After 258 | ; encoding = Ascii 259 | } 260 | ;; 261 | 262 | let update 263 | ?color 264 | ?interpret_atom_as_sexp 265 | ?drop_comments 266 | ?new_line_separator 267 | ?custom_data_alignment 268 | ?encoding 269 | conf 270 | = 271 | let conf = 272 | match color with 273 | | None -> conf 274 | | Some color -> 275 | if color 276 | then conf 277 | else ( 278 | match conf.comments with 279 | | Print (indent, Some _, style) -> 280 | { conf with 281 | atom_coloring = Color_none 282 | ; paren_coloring = false 283 | ; comments = Print (indent, None, style) 284 | } 285 | | _ -> { conf with atom_coloring = Color_none; paren_coloring = false }) 286 | in 287 | let conf = 288 | match interpret_atom_as_sexp with 289 | | None -> conf 290 | | Some interpret_atom_as_sexp -> 291 | if interpret_atom_as_sexp then { conf with atom_printing = Interpreted } else conf 292 | in 293 | let conf = 294 | match drop_comments with 295 | | None -> conf 296 | | Some drop_comments -> if drop_comments then { conf with comments = Drop } else conf 297 | in 298 | let conf = 299 | match new_line_separator with 300 | | None -> conf 301 | | Some true -> { conf with separator = Empty_line } 302 | | Some false -> { conf with separator = No_separator } 303 | in 304 | let conf = 305 | match custom_data_alignment with 306 | | None -> conf 307 | | Some data_alignment -> { conf with data_alignment } 308 | in 309 | let conf = 310 | match encoding with 311 | | None -> conf 312 | | Some encoding -> { conf with encoding } 313 | in 314 | conf 315 | ;; 316 | 317 | let create 318 | ?(color = false) 319 | ?(interpret_atom_as_sexp = false) 320 | ?(drop_comments = false) 321 | ?(new_line_separator = false) 322 | ?custom_data_alignment 323 | ?encoding 324 | () 325 | = 326 | update 327 | ~color 328 | ~interpret_atom_as_sexp 329 | ~drop_comments 330 | ~new_line_separator 331 | ?custom_data_alignment 332 | ?encoding 333 | default 334 | ;; 335 | -------------------------------------------------------------------------------- /test/test_comments.ml: -------------------------------------------------------------------------------- 1 | (** We have two kinds of tests: 2 | 3 | 1. Handwritten tests showing the pretty strings for some known examples. 4 | 5 | 2. Quickcheck tests which round-trip a sexp through pretty-printing and assert that 6 | the comments are preserved up to some post-processing of whitespace. 7 | 8 | The post-processing is applied to both the original comments and the pretty comments. 9 | It describes how closely we can look before we see how pretty-printing has changed 10 | comments. *) 11 | 12 | open! Import 13 | open! Expect_test_helpers_core 14 | open! Sexp_pretty 15 | 16 | module Comment_print_style = struct 17 | type t = Config.comment_print_style = 18 | | Pretty_print 19 | | Conservative_print 20 | [@@deriving enumerate, sexp_of] 21 | 22 | let to_string t = Sexp.to_string_mach ([%sexp_of: t] t) 23 | end 24 | 25 | type t = Sexp.With_layout.t_or_comment list [@@deriving sexp_of] 26 | 27 | let get_config ~comment_print_style = 28 | Config.update 29 | ~color:false 30 | { Config.default with 31 | comments = 32 | (match Config.default.comments with 33 | | Drop -> raise_s [%message "Expected default to be Print"] 34 | | Print (comment_indent, color_option, _) -> 35 | Print (comment_indent, color_option, comment_print_style)) 36 | } 37 | ;; 38 | 39 | let of_string s : t = 40 | match 41 | Lexing.from_string s 42 | |> Sexplib.Sexp.With_layout.Parser.sexps Sexplib.Sexp.With_layout.Lexer.main 43 | with 44 | | exception exn -> raise_s [%message "sexps_with_layout_of_string" (exn : exn) s] 45 | | t -> t 46 | ;; 47 | 48 | let pretty_string comment_print_style list = 49 | let config = get_config ~comment_print_style in 50 | List.map list ~f:(Sexp_with_layout.pretty_string config) |> String.concat ~sep:" " 51 | ;; 52 | 53 | let%expect_test "leading and trailing whitespace" = 54 | let module Example = struct 55 | type t = 56 | { leading : bool 57 | ; trailing : bool 58 | } 59 | [@@deriving enumerate, sexp_of] 60 | 61 | let to_string { leading; trailing } = 62 | let space_if bool = if bool then " " else "" in 63 | [%string {|#|%{space_if leading}a%{space_if trailing}|#|}] 64 | ;; 65 | 66 | let to_string_pretty t ~style = 67 | t 68 | |> to_string 69 | |> of_string 70 | |> pretty_string style 71 | (* Visualize the whitespace *) 72 | |> String.tr ~target:' ' ~replacement:'.' 73 | ;; 74 | 75 | let columns = 76 | Ascii_table_kernel.Column.create "comment" to_string 77 | :: List.map [%all: Comment_print_style.t] ~f:(fun style -> 78 | Ascii_table_kernel.Column.create 79 | (Comment_print_style.to_string style) 80 | (to_string_pretty ~style)) 81 | ;; 82 | end 83 | in 84 | let ascii_table columns rows = 85 | let screen = 86 | Ascii_table_kernel.draw columns rows ~prefer_split_on_spaces:false 87 | |> Option.value_exn 88 | in 89 | Ascii_table_kernel.Screen.to_string 90 | screen 91 | ~bars:`Unicode 92 | ~string_with_attr:(fun _ s -> s) 93 | in 94 | ascii_table Example.columns [%all: Example.t] |> print_endline; 95 | [%expect 96 | {| 97 | ┌─────────┬──────────────┬────────────────────┐ 98 | │ comment │ Pretty_print │ Conservative_print │ 99 | ├─────────┼──────────────┼────────────────────┤ 100 | │ #|a|# │ #|.a.|# │ #|a|# │ 101 | │ #| a|# │ #|.a.|# │ #|.a|# │ 102 | │ #|a |# │ #|.a.|# │ #|a.|# │ 103 | │ #| a |# │ #|.a.|# │ #|.a.|# │ 104 | └─────────┴──────────────┴────────────────────┘ 105 | |}] 106 | ;; 107 | 108 | let%expect_test "examples" = 109 | let test s = 110 | let t = of_string s in 111 | List.iter [%all: Comment_print_style.t] ~f:(fun style -> 112 | let s = pretty_string style t in 113 | print_endline [%string {|%{style#Comment_print_style}: %{s}|}]) 114 | in 115 | (* multiple internal whitespace *) 116 | test {| #| a b |# |}; 117 | [%expect 118 | {| 119 | Pretty_print: #| a b |# 120 | 121 | Conservative_print: #| a b |# 122 | |}]; 123 | (* multiple lines *) 124 | test 125 | {| #| a 126 | b 127 | c 128 | 129 | d |# |}; 130 | [%expect 131 | {| 132 | Pretty_print: #| a b c d |# 133 | 134 | Conservative_print: #| a 135 | b 136 | c 137 | 138 | d |# 139 | |}]; 140 | (* really long comment *) 141 | test 142 | {| #| really long comment to see if sexp pretty printing will ever add new line breaks |# |}; 143 | [%expect 144 | {| 145 | Pretty_print: #| 146 | really long comment to see if sexp pretty printing will ever add new line 147 | breaks 148 | |# 149 | 150 | Conservative_print: #| really long comment to see if sexp pretty printing will ever add new line breaks |# 151 | |}]; 152 | (* comments nested in sexp comment *) 153 | test 154 | {| #; 155 | ; plain comment 156 | #| block comment |# 157 | (sexp 158 | with 159 | #| nested comment |# 160 | ) |}; 161 | [%expect 162 | {| 163 | Pretty_print: #; 164 | ; plain comment#| block comment |# 165 | (sexp with #| nested comment |#) 166 | 167 | Conservative_print: #; 168 | ; plain comment#| block comment |# 169 | (sexp with #| nested comment |#) 170 | |}]; 171 | (* quoted newline *) 172 | test 173 | {| #| "quoted 174 | newline" |# |}; 175 | [%expect 176 | {| 177 | Pretty_print: #| "quoted newline" |# 178 | 179 | Conservative_print: #| "quoted 180 | newline" |# 181 | |}]; 182 | ignore () 183 | ;; 184 | 185 | let%expect_test "sticky comments" = 186 | let test s = 187 | let t = of_string s in 188 | Config.[ Before; After; Same_line ] 189 | |> List.iter ~f:(fun sticky -> 190 | let label = [%sexp_of: Config.sticky_comments] sticky |> Sexp.to_string in 191 | print_endline [%string {|%{label}:|}]; 192 | List.iter [%all: Comment_print_style.t] ~f:(fun comment_print_style -> 193 | let s = 194 | let config = get_config ~comment_print_style in 195 | let config = { config with Config.sticky_comments = sticky } in 196 | List.map t ~f:(Sexp_with_layout.pretty_string config) |> String.concat ~sep:" " 197 | in 198 | print_endline [%string "%{comment_print_style#Comment_print_style}:\n%{s}"])) 199 | in 200 | test 201 | {| 202 | (a 203 | ;; comment 1 204 | ;; comment 2 205 | 206 | (b c) ;; comment 3 207 | ( ;; comment 4 208 | d ;; comment 5 209 | ("single new 210 | line") ;; comment 6 211 | 212 | #| multi line 213 | block 214 | comment 215 | |# 216 | () 217 | )) 218 | |}; 219 | [%expect 220 | {| 221 | Before: 222 | Pretty_print: 223 | (a 224 | ;; comment 1 225 | ;; comment 2 226 | ;; comment 3 227 | (b c) 228 | (;; comment 4 229 | ;; comment 5 230 | d 231 | ;; comment 6 232 | ("single new\nline") 233 | #| multi line block comment |# 234 | ())) 235 | 236 | Conservative_print: 237 | (a 238 | ;; comment 1 239 | ;; comment 2 240 | ;; comment 3 241 | (b c) 242 | (;; comment 4 243 | ;; comment 5 244 | d 245 | ;; comment 6 246 | ("single new\nline") 247 | #| multi line 248 | block 249 | comment 250 | |# 251 | ())) 252 | 253 | After: 254 | Pretty_print: 255 | (a 256 | ;; comment 1 257 | ;; comment 2 258 | (b c) 259 | ;; comment 3 260 | (;; comment 4 261 | d 262 | ;; comment 5 263 | ("single new\nline") 264 | ;; comment 6 265 | #| multi line block comment |# 266 | ())) 267 | 268 | Conservative_print: 269 | (a 270 | ;; comment 1 271 | ;; comment 2 272 | (b c) 273 | ;; comment 3 274 | (;; comment 4 275 | d 276 | ;; comment 5 277 | ("single new\nline") 278 | ;; comment 6 279 | #| multi line 280 | block 281 | comment 282 | |# 283 | ())) 284 | 285 | Same_line: 286 | Pretty_print: 287 | (a 288 | ;; comment 1 289 | ;; comment 2 290 | (b c) ;; comment 3 291 | (;; comment 4 292 | d ;; comment 5 293 | ("single new\nline") ;; comment 6 294 | #| multi line block comment |# 295 | ())) 296 | 297 | Conservative_print: 298 | (a 299 | ;; comment 1 300 | ;; comment 2 301 | (b c) ;; comment 3 302 | (;; comment 4 303 | d ;; comment 5 304 | ("single new\nline") ;; comment 6 305 | #| multi line 306 | block 307 | comment 308 | |# 309 | ())) 310 | |}]; 311 | ignore () 312 | ;; 313 | 314 | let round_trip_pretty style tc = of_string (pretty_string style tc) 315 | 316 | let get_comment_strings t = 317 | let open Sexp.With_layout in 318 | let rec of_t = function 319 | | Atom _ -> [] 320 | | List (_, t_or_comments, _) -> List.concat_map t_or_comments ~f:of_t_or_comment 321 | and of_t_or_comment = function 322 | | Sexp _ -> [] 323 | | Comment comment -> of_comment comment 324 | and of_comment = function 325 | | Plain_comment (_, s) -> [ s ] 326 | | Sexp_comment (_, comments, t) -> 327 | List.concat [ List.concat_map comments ~f:of_comment; of_t t ] 328 | in 329 | List.concat_map t ~f:of_t_or_comment 330 | ;; 331 | 332 | let whitespace_chars = String.to_list " \t\n\r" 333 | 334 | let compress_whitespace s = 335 | String.split_on_chars s ~on:whitespace_chars 336 | |> List.filter ~f:(Fn.non String.is_empty) 337 | |> String.concat ~sep:" " 338 | ;; 339 | 340 | (* Doesn't strip sexp comments. Our comparison is on the [Plain_comment _] values, 341 | including those nested inside sexp comments. *) 342 | let strip_comment_markers s = 343 | match String.chop_prefix s ~prefix:";" with 344 | | Some line_comment -> line_comment 345 | | None -> 346 | (match 347 | String.chop_prefix s ~prefix:"#|" 348 | |> Option.bind ~f:(String.chop_suffix ~suffix:"|#") 349 | with 350 | | Some s -> s 351 | | None -> raise_s [%message "Comment neither line comment nor block comment." s]) 352 | ;; 353 | 354 | let postprocess_comment (style : Comment_print_style.t) prev = 355 | match style with 356 | (* [Pretty_print] preserves non-whitespace characters *) 357 | | Pretty_print -> prev |> strip_comment_markers |> String.strip |> compress_whitespace 358 | (* [Conservative_print] preserves everything *) 359 | | Conservative_print -> prev 360 | ;; 361 | 362 | module Test_helper = struct 363 | module type S = sig 364 | type t [@@deriving quickcheck, sexp_of] 365 | end 366 | 367 | type 'a t = (module S with type t = 'a) 368 | 369 | let filter_map (type a) ((module M) : a t) ~f : a t = 370 | (module struct 371 | type t = M.t [@@deriving sexp_of] 372 | 373 | include 374 | Quickcheckable.Of_quickcheckable_filtered 375 | (M) 376 | (struct 377 | type t = M.t 378 | 379 | let of_quickcheckable a = f a 380 | let to_quickcheckable = Fn.id 381 | end) 382 | end) 383 | ;; 384 | end 385 | 386 | (* [Sexp_pretty] doesn't promise to round-trip. Let's limit ourselves to inputs 387 | that round-tripped up to the number of comments. *) 388 | let round_trippable_sexps style = 389 | let equal_num_comments a b = 390 | Comparable.lift 391 | [%compare.equal: int] 392 | ~f:(fun list -> get_comment_strings list |> List.length) 393 | a 394 | b 395 | in 396 | Test_helper.filter_map (module Sexp_string_quickcheck.Sexp_string) ~f:(fun s -> 397 | Option.try_with (fun () -> 398 | let prev = of_string s in 399 | let next = round_trip_pretty style prev in 400 | assert (equal_num_comments prev next); 401 | s)) 402 | ;; 403 | 404 | let test_one style = 405 | let equal a b = 406 | Comparable.lift 407 | [%equal: string list] 408 | ~f:(fun list -> get_comment_strings list |> List.map ~f:(postprocess_comment style)) 409 | a 410 | b 411 | in 412 | stage (fun s -> 413 | let prev = of_string s in 414 | let next = round_trip_pretty style prev in 415 | if not (equal prev next) 416 | then raise_s [%message "Comments changed too much." s (pretty_string style next)]) 417 | ;; 418 | 419 | let%expect_test "quickcheck" = 420 | let test here style = 421 | require_does_not_raise ~here (fun () -> 422 | let module M = (val round_trippable_sexps style) in 423 | Base_quickcheck.Test.run_exn (module M) ~f:(unstage (test_one style))) 424 | in 425 | test [%here] Pretty_print; 426 | [%expect {| |}]; 427 | test [%here] Conservative_print; 428 | [%expect {| |}]; 429 | ignore () 430 | ;; 431 | -------------------------------------------------------------------------------- /test/test_pretty_print.ml: -------------------------------------------------------------------------------- 1 | open! Import 2 | open! Sexp_pretty 3 | 4 | let normalized_sexp t = 5 | let rec of_t = function 6 | | Normalize.Sexp (sexp, _) -> Some (of_sexp sexp) 7 | | Normalize.Comment _ -> None 8 | and of_sexp = function 9 | | Normalize.Atom str -> Sexp.Atom str 10 | | Normalize.List ts -> Sexp.List (of_t_list ts) 11 | and of_t_list ts = List.filter_map ts ~f:of_t in 12 | match of_t t with 13 | | Some sexp -> sexp 14 | | None -> assert false 15 | ;; 16 | 17 | let normalize conf sexp = 18 | sexp 19 | |> sexp_to_sexp_or_comment conf 20 | |> Normalize.of_sexp_or_comment conf 21 | |> normalized_sexp 22 | ;; 23 | 24 | (* Tests with atom interpretation *) 25 | 26 | let conf = { Config.default with Config.atom_printing = Interpreted } 27 | 28 | let test ~input:input_sexp sexp = 29 | [%test_result: Sexp.t] ~expect:sexp (normalize conf input_sexp) 30 | ;; 31 | 32 | let%test_unit _ = 33 | let atom = Sexp.Atom "Not connected to oculus monitor" in 34 | test ~input:atom atom 35 | ;; 36 | 37 | let%test_unit _ = 38 | test 39 | ~input:(Sexp.Atom "Not connected to oculus monitor (connect to monitor please)") 40 | (List 41 | [ Atom "Not connected to oculus monitor" 42 | ; Sexp.of_string "(connect to monitor please)" 43 | ]) 44 | ;; 45 | 46 | let%test_unit _ = 47 | test 48 | ~input:(Sexp.Atom "Not connected (not that you have to) to oculus monitor") 49 | (List 50 | [ Atom "Not connected" 51 | ; Sexp.of_string "(not that you have to)" 52 | ; Atom "to oculus monitor" 53 | ]) 54 | ;; 55 | 56 | let%test_unit _ = 57 | let sexp = Sexp.of_string "(this is a (bona fide) sexp)" in 58 | test ~input:sexp sexp 59 | ;; 60 | 61 | let%test_unit _ = 62 | let sexp = Sexp.of_string "(issue (error_fields (message \"A message\")(int 5)))" in 63 | test ~input:sexp sexp 64 | ;; 65 | 66 | let%test_unit _ = 67 | let sexp = Sexp.of_string "(message \"A message\")" in 68 | test ~input:sexp sexp 69 | ;; 70 | 71 | let%test_unit _ = 72 | let sexp = Sexp.Atom "\" space \"" in 73 | test ~input:sexp sexp 74 | ;; 75 | 76 | let%test_unit _ = 77 | let sexp = Sexp.Atom " space " in 78 | test ~input:sexp sexp 79 | ;; 80 | 81 | (* Tests with [Escaped] *) 82 | 83 | let conf = { Config.default with Config.atom_printing = Escaped } 84 | 85 | let test ~input:input_sexp sexp = 86 | [%test_result: Sexp.t] ~expect:sexp (normalize conf input_sexp) 87 | ;; 88 | 89 | let%test_unit _ = 90 | let atom = Sexp.Atom "Not connected to oculus monitor" in 91 | test ~input:atom atom 92 | ;; 93 | 94 | let%test_unit _ = 95 | let sexp = Sexp.Atom "(this is a (bona fide) sexp)" in 96 | test ~input:sexp sexp 97 | ;; 98 | 99 | let%test_unit _ = 100 | let sexp = Sexp.Atom "(message \"A message\")" in 101 | test ~input:sexp sexp 102 | ;; 103 | 104 | let%test_unit _ = 105 | let sexp = Sexp.Atom "\" space \"" in 106 | test ~input:sexp sexp 107 | ;; 108 | 109 | let%test_unit _ = 110 | let sexp = Sexp.Atom " space " in 111 | test ~input:sexp sexp 112 | ;; 113 | 114 | let%expect_test "long atoms with newlines are hard to read" = 115 | let s = String.concat ~sep:"\n" (List.init 10 ~f:Int.to_string) in 116 | print_endline (pretty_string Config.(update default ~color:false) (Atom s)); 117 | [%expect {| "0\n1\n2\n3\n4\n5\n6\n7\n8\n9" |}]; 118 | print_endline (Sexp.to_string_hum (Atom s)); 119 | [%expect 120 | {| 121 | "0\ 122 | \n1\ 123 | \n2\ 124 | \n3\ 125 | \n4\ 126 | \n5\ 127 | \n6\ 128 | \n7\ 129 | \n8\ 130 | \n9" 131 | |}] 132 | ;; 133 | 134 | let test 135 | ?(sticky_comments = Sexp_pretty.Config.default.sticky_comments) 136 | ?(atom_printing = Sexp_pretty.Config.default.atom_printing) 137 | string 138 | = 139 | let lexbuf = Lexing.from_string string in 140 | let next () = 141 | Option.try_with (fun () -> 142 | Sexp.With_layout.Parser.sexp Sexp.With_layout.Lexer.main lexbuf) 143 | in 144 | let config = 145 | { (Sexp_pretty.Config.create ~color:false ~new_line_separator:true ()) with 146 | sticky_comments 147 | ; atom_printing 148 | } 149 | in 150 | Sexp_pretty.Sexp_with_layout.pp_formatter' ~next config Format.std_formatter 151 | ;; 152 | 153 | let%expect_test "block comments should not have extra escape sequence at the end using \ 154 | pp_formatter'" 155 | = 156 | test "(this is a sexp with #| comment |# block comments)"; 157 | [%expect {| (this is a sexp with #| comment |# block comments) |}] 158 | ;; 159 | 160 | let%expect_test "block comments should not have escape sequence when pretty_string" = 161 | let s = "(this is a sexp with #| my delightful comment |# block comments)" in 162 | let config = Sexp_pretty.Config.create ~color:false () in 163 | print_endline (pretty_string config (Atom s)); 164 | [%expect {| "(this is a sexp with #| my delightful comment |# block comments)" |}] 165 | ;; 166 | 167 | let%expect_test "multi-lines atom before comments" = 168 | let string = 169 | {| 170 | the_first_atom "a long string 171 | in multiple 172 | lines" ;; comment about the string 173 | ;; and this as well 174 | 175 | (this is (a list) "another long 176 | string" ;; comment too 177 | ;; another comment 178 | ) 179 | ) 180 | |} 181 | in 182 | test string ~sticky_comments:Before; 183 | [%expect 184 | {| 185 | the_first_atom 186 | 187 | "a long string\nin multiple\nlines" 188 | 189 | ;; comment about the string 190 | ;; and this as well 191 | (this is 192 | (a list) 193 | ;; comment too 194 | ;; another comment 195 | "another long\nstring") 196 | |}] 197 | ;; 198 | 199 | let%expect_test "test comments on all [sticky_comments] config" = 200 | let string = 201 | {| 202 | (AAAAA ;; BBBBB 203 | ;; CCCCC 204 | ) 205 | 206 | (XXXXX) ;; YYYYY 207 | ;; ZZZZZ 208 | 209 | ((iii 210 | (jjj kkk) ;; jkjkjk 211 | ;; kjkjkj 212 | lll)) 213 | 214 | (AAAAA #| BBBBB |# 215 | #| CCCCC |# 216 | ) 217 | 218 | (XXXXX) #| YYYYY |# 219 | #| ZZZZZ |# 220 | 221 | ((iii 222 | (jjj kkk) #| jkjkjk |# 223 | #| kjkjkj |# 224 | lll)) 225 | 226 | (AAAAA #; BBBBB 227 | #; CCCCC 228 | ) 229 | 230 | (XXXXX) #; YYYYY 231 | #; ZZZZZ 232 | 233 | ((iii 234 | (jjj kkk) #; jkjkjk 235 | #; kjkjkj 236 | lll)) 237 | |} 238 | in 239 | test string ~sticky_comments:Before; 240 | [%expect 241 | {| 242 | (;; BBBBB 243 | ;; CCCCC 244 | AAAAA) 245 | 246 | (XXXXX) 247 | 248 | ;; YYYYY 249 | ;; ZZZZZ 250 | (( 251 | iii 252 | ;; jkjkjk 253 | ;; kjkjkj 254 | (jjj kkk) 255 | lll)) 256 | 257 | (AAAAA #| BBBBB |# #| CCCCC |#) 258 | 259 | (XXXXX) 260 | 261 | #| YYYYY |# 262 | #| ZZZZZ |# 263 | ((iii (jjj kkk) #| jkjkjk |# #| kjkjkj |# lll)) 264 | 265 | (AAAAA #; BBBBB #; CCCCC) 266 | 267 | (XXXXX) 268 | 269 | #; 270 | YYYYY 271 | #; 272 | ZZZZZ 273 | ((iii (jjj kkk) #; jkjkjk #; kjkjkj lll)) 274 | |}]; 275 | test string ~sticky_comments:Same_line; 276 | [%expect 277 | {| 278 | (AAAAA ;; BBBBB 279 | ;; CCCCC 280 | ) 281 | 282 | (XXXXX) 283 | 284 | ;; YYYYY 285 | ;; ZZZZZ 286 | (( 287 | iii 288 | (jjj kkk) ;; jkjkjk 289 | ;; kjkjkj 290 | lll)) 291 | 292 | (AAAAA #| BBBBB |# #| CCCCC |#) 293 | 294 | (XXXXX) 295 | 296 | #| YYYYY |# 297 | #| ZZZZZ |# 298 | ((iii (jjj kkk) #| jkjkjk |# #| kjkjkj |# lll)) 299 | 300 | (AAAAA #; BBBBB #; CCCCC) 301 | 302 | (XXXXX) 303 | 304 | #; 305 | YYYYY 306 | #; 307 | ZZZZZ 308 | ((iii (jjj kkk) #; jkjkjk #; kjkjkj lll)) 309 | |}]; 310 | test string ~sticky_comments:After; 311 | [%expect 312 | {| 313 | (AAAAA 314 | ;; BBBBB 315 | ;; CCCCC 316 | ) 317 | 318 | (XXXXX) 319 | 320 | ;; YYYYY 321 | ;; ZZZZZ 322 | (( 323 | iii 324 | (jjj kkk) 325 | ;; jkjkjk 326 | ;; kjkjkj 327 | lll)) 328 | 329 | (AAAAA #| BBBBB |# #| CCCCC |#) 330 | 331 | (XXXXX) 332 | 333 | #| YYYYY |# 334 | #| ZZZZZ |# 335 | ((iii (jjj kkk) #| jkjkjk |# #| kjkjkj |# lll)) 336 | 337 | (AAAAA #; BBBBB #; CCCCC) 338 | 339 | (XXXXX) 340 | 341 | #; 342 | YYYYY 343 | #; 344 | ZZZZZ 345 | ((iii (jjj kkk) #; jkjkjk #; kjkjkj lll)) 346 | |}] 347 | ;; 348 | 349 | let%expect_test "aligned data" = 350 | let string = 351 | {| 352 | ((address (String "50 St. James Street")) ;; 1 353 | (url (String http://www.JSON.org/)) ;; 2 354 | (comment (String "// /* */" (String " ")) ;; 4 356 | ("single new 357 | line" (String "should not be aligend")) ;; 5 358 | (address (String "50 St. James Street")) ;; 6 359 | (url (String http://www.JSON.org/)) ;; 7 360 | ) 361 | |} 362 | in 363 | test string ~sticky_comments:Same_line; 364 | [%expect 365 | {| 366 | ((address (String "50 St. James Street")) ;; 1 367 | (url (String http://www.JSON.org/)) ;; 2 368 | (comment (String "// /* */" (String " ")) ;; 4 370 | ("single new\nline" (String "should not be aligend")) ;; 5 371 | (address (String "50 St. James Street")) ;; 6 372 | (url (String http://www.JSON.org/)) ;; 7 373 | ) 374 | |}]; 375 | test string ~sticky_comments:Same_line ~atom_printing:Minimal_escaping; 376 | [%expect 377 | {| 378 | ((address (String "50 St. James Street")) ;; 1 379 | (url (String http://www.JSON.org/)) ;; 2 380 | (comment (String "// /* */" (String " ")) ;; 4 382 | ("single new 383 | line" (String "should not be aligend")) ;; 5 384 | (address (String "50 St. James Street")) ;; 6 385 | (url (String http://www.JSON.org/)) ;; 7 386 | ) 387 | |}] 388 | ;; 389 | 390 | let%expect_test "singleton lists" = 391 | let string = 392 | {| 393 | (((at1 at2 at3 (elm1 elm2 elm3 )))) 394 | (((at1 at2 at3 ((elm1 elm2 elm3))))) 395 | (at1 at2 at3 ;; comment 1 396 | ;; comment 2 397 | (elm1 elm2 elm3)) 398 | (at1 at2 at3 (elm1 elm2 elm3) ;; comment 1 399 | ;; comment 2 400 | ) 401 | (at1 at2 at3 (elm1 elm2 elm3 ;; comment 1 402 | ;; comment 2 403 | ) 404 | ) 405 | |} 406 | in 407 | test string ~sticky_comments:Same_line; 408 | [%expect 409 | {| 410 | (((at1 at2 at3 (elm1 elm2 elm3)))) 411 | 412 | (((at1 at2 at3 ((elm1 elm2 elm3))))) 413 | 414 | (at1 at2 415 | at3 ;; comment 1 416 | ;; comment 2 417 | (elm1 elm2 elm3)) 418 | 419 | (at1 at2 at3 420 | (elm1 elm2 elm3) ;; comment 1 421 | ;; comment 2 422 | ) 423 | 424 | (at1 at2 at3 ( 425 | elm1 elm2 426 | elm3 ;; comment 1 427 | ;; comment 2 428 | )) 429 | |}] 430 | ;; 431 | 432 | (* Tests with [Minimal_escaping] *) 433 | 434 | let conf = 435 | { (Config.create ~color:false ()) with Config.atom_printing = Minimal_escaping } 436 | ;; 437 | 438 | let%expect_test "long atom with newlines" = 439 | let sexp = Sexp.Atom (String.concat ~sep:"\n" (List.init 10 ~f:Int.to_string)) in 440 | let pretty = pretty_string conf sexp in 441 | print_endline pretty; 442 | [%expect 443 | {| 444 | "0 445 | 1 446 | 2 447 | 3 448 | 4 449 | 5 450 | 6 451 | 7 452 | 8 453 | 9" 454 | |}]; 455 | [%test_result: Sexp.t] ~expect:sexp (Sexp.of_string pretty) 456 | ;; 457 | 458 | let%expect_test "list with an atom having newlines" = 459 | let sexp = Sexp.of_string "(ABCD EFG (123 456 \"abc\ndef ghi\njkl\" 7890) HI)" in 460 | let pretty = pretty_string conf sexp in 461 | print_endline pretty; 462 | [%expect 463 | {| 464 | (ABCD EFG 465 | (123 456 466 | "abc 467 | def ghi 468 | jkl" 469 | 7890) 470 | HI) 471 | |}]; 472 | [%test_result: Sexp.t] ~expect:sexp (Sexp.of_string pretty) 473 | ;; 474 | 475 | let%expect_test "list with the middle leading atom having newlines" = 476 | let sexp = Sexp.of_string "(ABCD \"EFG\nEEFFGG\" HIJ)" in 477 | let pretty = pretty_string conf sexp in 478 | print_endline pretty; 479 | [%expect 480 | {| 481 | (ABCD 482 | "EFG 483 | EEFFGG" 484 | HIJ) 485 | |}] 486 | ;; 487 | 488 | let%expect_test "list with the last leading atom having newlines" = 489 | let sexp = Sexp.of_string "(ABCD EFG \"HIHI\nHIJ\")" in 490 | let pretty = pretty_string conf sexp in 491 | print_endline pretty; 492 | [%expect 493 | {| 494 | (ABCD EFG 495 | "HIHI 496 | HIJ") 497 | |}] 498 | ;; 499 | 500 | let%expect_test "atom with characters to be escaped" = 501 | let sexp = Sexp.Atom "AB\bCD\tEF\nGH\011IJ\012KL\rMN\\OP" in 502 | let pretty = pretty_string conf sexp in 503 | print_endline pretty; 504 | [%expect 505 | {| 506 | "AB\bCD EF 507 | GH\011IJ\012KL\rMN\\OP" 508 | |}]; 509 | [%test_result: Sexp.t] ~expect:sexp (Sexp.of_string pretty) 510 | ;; 511 | 512 | let%expect_test "atom with escaped characters" = 513 | let sexp = Sexp.Atom {|AB\bCD\tEF\nGH\011IJ\012KL\rMN\\OP\"QR|} in 514 | let pretty = pretty_string conf sexp in 515 | print_endline pretty; 516 | [%expect {| "AB\\bCD\\tEF\\nGH\\011IJ\\012KL\\rMN\\\\OP\\\"QR" |}]; 517 | [%test_result: Sexp.t] ~expect:sexp (Sexp.of_string pretty) 518 | ;; 519 | 520 | let%expect_test "all characters" = 521 | let chars = List.chunks_of Char.all ~length:8 in 522 | let test sexp = 523 | let string = pretty_string conf sexp in 524 | print_string string; 525 | Expect_test_helpers_base.require_equal (module Sexp) sexp (Sexp.of_string string) 526 | in 527 | (* grouped in atoms *) 528 | List.iter chars ~f:(fun list -> test (Atom (String.of_char_list list))); 529 | [%expect 530 | {xxx| 531 | "\000\001\002\003\004\005\006\007" 532 | "\b 533 | \011\012\r\014\015" 534 | "\016\017\018\019\020\021\022\023" 535 | "\024\025\026\027\028\029\030\031" 536 | " !\"#$%&'" 537 | "()*+,-./" 538 | 01234567 539 | "89:;<=>?" 540 | @ABCDEFG 541 | HIJKLMNO 542 | PQRSTUVW 543 | "XYZ[\\]^_" 544 | `abcdefg 545 | hijklmno 546 | pqrstuvw 547 | "xyz{|}~\127" 548 | "\128\129\130\131\132\133\134\135" 549 | "\136\137\138\139\140\141\142\143" 550 | "\144\145\146\147\148\149\150\151" 551 | "\152\153\154\155\156\157\158\159" 552 | "\160\161\162\163\164\165\166\167" 553 | "\168\169\170\171\172\173\174\175" 554 | "\176\177\178\179\180\181\182\183" 555 | "\184\185\186\187\188\189\190\191" 556 | "\192\193\194\195\196\197\198\199" 557 | "\200\201\202\203\204\205\206\207" 558 | "\208\209\210\211\212\213\214\215" 559 | "\216\217\218\219\220\221\222\223" 560 | "\224\225\226\227\228\229\230\231" 561 | "\232\233\234\235\236\237\238\239" 562 | "\240\241\242\243\244\245\246\247" 563 | "\248\249\250\251\252\253\254\255" 564 | |xxx}]; 565 | (* one atom each *) 566 | List.iter chars ~f:(fun list -> 567 | test (List (List.map list ~f:(fun char -> Sexp.Atom (String.of_char char))))); 568 | [%expect 569 | {| 570 | ("\000" "\001" "\002" "\003" "\004" "\005" "\006" "\007") 571 | ("\b" " " 572 | " 573 | " 574 | "\011" 575 | "\012" 576 | "\r" 577 | "\014" 578 | "\015") 579 | ("\016" "\017" "\018" "\019" "\020" "\021" "\022" "\023") 580 | ("\024" "\025" "\026" "\027" "\028" "\029" "\030" "\031") 581 | (" " ! "\"" # $ % & ') 582 | ("(" ")" * + , - . /) 583 | (0 1 2 3 4 5 6 7) 584 | (8 9 : ";" < = > ?) 585 | (@ A B C D E F G) 586 | (H I J K L M N O) 587 | (P Q R S T U V W) 588 | (X Y Z [ \ ] ^ _) 589 | (` a b c d e f g) 590 | (h i j k l m n o) 591 | (p q r s t u v w) 592 | (x y z { | } ~ "\127") 593 | ("\128" "\129" "\130" "\131" "\132" "\133" "\134" "\135") 594 | ("\136" "\137" "\138" "\139" "\140" "\141" "\142" "\143") 595 | ("\144" "\145" "\146" "\147" "\148" "\149" "\150" "\151") 596 | ("\152" "\153" "\154" "\155" "\156" "\157" "\158" "\159") 597 | ("\160" "\161" "\162" "\163" "\164" "\165" "\166" "\167") 598 | ("\168" "\169" "\170" "\171" "\172" "\173" "\174" "\175") 599 | ("\176" "\177" "\178" "\179" "\180" "\181" "\182" "\183") 600 | ("\184" "\185" "\186" "\187" "\188" "\189" "\190" "\191") 601 | ("\192" "\193" "\194" "\195" "\196" "\197" "\198" "\199") 602 | ("\200" "\201" "\202" "\203" "\204" "\205" "\206" "\207") 603 | ("\208" "\209" "\210" "\211" "\212" "\213" "\214" "\215") 604 | ("\216" "\217" "\218" "\219" "\220" "\221" "\222" "\223") 605 | ("\224" "\225" "\226" "\227" "\228" "\229" "\230" "\231") 606 | ("\232" "\233" "\234" "\235" "\236" "\237" "\238" "\239") 607 | ("\240" "\241" "\242" "\243" "\244" "\245" "\246" "\247") 608 | ("\248" "\249" "\250" "\251" "\252" "\253" "\254" "\255") 609 | |}] 610 | ;; 611 | 612 | (* Tests with [Utf8] *) 613 | 614 | let conf encoding = { (Config.create ~color:false ()) with encoding } 615 | 616 | let%expect_test "all chars same under utf8" = 617 | let test sexp = 618 | Expect_test_helpers_base.require_equal 619 | (module String) 620 | (pretty_string (conf Utf8) sexp) 621 | (pretty_string (conf Ascii) sexp) 622 | in 623 | let chars = List.chunks_of Char.all ~length:8 in 624 | List.iter chars ~f:(fun list -> test (Atom (String.of_char_list list))); 625 | [%expect {| |}]; 626 | List.iter chars ~f:(fun list -> 627 | test (List (List.map list ~f:(fun char -> Sexp.Atom (String.of_char char))))); 628 | [%expect {| |}] 629 | ;; 630 | 631 | let%expect_test "non-ascii chars" = 632 | let test sexp = 633 | let ascii = pretty_string (conf Ascii) sexp in 634 | let utf8 = pretty_string (conf Utf8) sexp in 635 | print_string ascii; 636 | print_string utf8; 637 | Expect_test_helpers_base.require_equal (module Sexp) (Sexp.of_string utf8) sexp; 638 | Expect_test_helpers_base.require_equal 639 | (module Sexp) 640 | (Sexp.of_string utf8) 641 | (Sexp.of_string ascii) 642 | in 643 | test (Atom "foo bar"); 644 | [%expect 645 | {| 646 | "foo bar" 647 | "foo bar" 648 | |}]; 649 | test (Atom "こんにちは"); 650 | [%expect 651 | {| 652 | "\227\129\147\227\130\147\227\129\171\227\129\161\227\129\175" 653 | こんにちは 654 | |}]; 655 | test (Atom "foo bar こんにちは"); 656 | [%expect 657 | {| 658 | "foo bar \227\129\147\227\130\147\227\129\171\227\129\161\227\129\175" 659 | "foo bar こんにちは" 660 | |}]; 661 | test (Atom "\tこんにちは"); 662 | [%expect 663 | {| 664 | "\t\227\129\147\227\130\147\227\129\171\227\129\161\227\129\175" 665 | "\tこんにちは" 666 | |}]; 667 | test 668 | (List 669 | [ Atom "\t\227\129\147\227\130\147\227\129\171\227\129\161\227\129\175" 670 | ; Atom "\227\129\147\227\130\147\227\129\171\227\129\161\227\129\175" 671 | ]); 672 | [%expect 673 | {| 674 | ("\t\227\129\147\227\130\147\227\129\171\227\129\161\227\129\175" 675 | "\227\129\147\227\130\147\227\129\171\227\129\161\227\129\175") 676 | ("\tこんにちは" こんにちは) 677 | |}] 678 | ;; 679 | 680 | let%expect_test "quickcheck round-tripping" = 681 | let module Sexp_utf8 = struct 682 | type t = Sexp.t [@@deriving sexp_of, quickcheck ~shrinker] 683 | 684 | let quickcheck_generator = 685 | let open Base_quickcheck in 686 | Generator.sexp_of (String.Utf8.quickcheck_generator :> string Generator.t) 687 | ;; 688 | end 689 | in 690 | Quickcheck.iter ~trials:15 Sexp_utf8.quickcheck_generator ~f:(fun sexp -> print_s sexp); 691 | [%expect 692 | {| 693 | "" 694 | (()) 695 | ("\242\179\128\160") 696 | ("" () ()) 697 | () 698 | (() "\244\143\191\191" ()) 699 | (("") "\231\189\186") 700 | () 701 | () 702 | (() () "" () () () "") 703 | (() () ((()))) 704 | "#\000Iql\238\174\172r\244\143\191\191*" 705 | "\226\146\148" 706 | () 707 | "{\217\161\024]\025\213\147\199\188\216\186\244\132\180\183N" 708 | |}]; 709 | Expect_test_helpers_base.quickcheck_m (module Sexp_utf8) ~f:(fun sexp -> 710 | Expect_test_helpers_base.require_equal 711 | (module Sexp) 712 | (Sexp.of_string (pretty_string (conf Ascii) sexp)) 713 | sexp; 714 | Expect_test_helpers_base.require_equal 715 | (module Sexp) 716 | (Sexp.of_string (pretty_string (conf Utf8) sexp)) 717 | sexp) 718 | ;; 719 | -------------------------------------------------------------------------------- /src/sexp_pretty.ml: -------------------------------------------------------------------------------- 1 | open! Base 2 | include Sexp_pretty_intf 3 | module Sexp = Sexplib.Sexp 4 | module Config = Config 5 | open Config 6 | 7 | module Sexp_impl = struct 8 | module type S = sig 9 | val must_escape : string -> bool 10 | val mach_maybe_esc_str : string -> string 11 | val esc_str : string -> string 12 | end 13 | 14 | let get conf : (module S) = 15 | match conf.encoding with 16 | | Ascii -> (module Sexplib.Pre_sexp) 17 | | Utf8 -> (module Base.Sexp.Utf8.Pretty_printing_helpers_private) 18 | ;; 19 | 20 | let must_escape conf = 21 | let (module Sexp_impl) = get conf in 22 | Sexp_impl.must_escape 23 | ;; 24 | 25 | let mach_maybe_esc_str conf = 26 | let (module Sexp_impl) = get conf in 27 | Sexp_impl.mach_maybe_esc_str 28 | ;; 29 | 30 | let esc_str conf = 31 | let (module Sexp_impl) = get conf in 32 | Sexp_impl.esc_str 33 | ;; 34 | 35 | let minimal_escaping conf at = 36 | let body = 37 | match conf.encoding with 38 | | Ascii -> 39 | String.concat_map at ~f:(fun char -> 40 | match char with 41 | | '"' | '\\' -> String.of_char '\\' ^ String.of_char char 42 | | ' ' | '\t' | '\n' -> String.of_char char 43 | | _ -> if Char.is_print char then String.of_char char else Char.escaped char) 44 | | Utf8 -> 45 | String.Utf8.of_string at 46 | |> String.Utf8.to_list 47 | |> List.concat_map ~f:(fun char -> 48 | match Uchar.to_char char with 49 | | Some ('"' | '\\') -> [ Uchar.of_char '\\'; char ] 50 | | _ -> [ char ]) 51 | |> String.Utf8.of_list 52 | |> String.Utf8.to_string 53 | in 54 | String.concat [ "\""; body; "\"" ] 55 | ;; 56 | end 57 | 58 | module W = Parsexp.Cst 59 | 60 | module Format = struct 61 | include Stdlib.Format 62 | 63 | let pp_arrayi sep pp fmt array = 64 | Array.iteri array ~f:(fun i x -> 65 | if i > 0 then fprintf fmt sep; 66 | pp i fmt x) 67 | ;; 68 | 69 | let pp_list sep pp fmt list = 70 | List.iteri list ~f:(fun i x -> 71 | if i > 0 then fprintf fmt sep; 72 | pp fmt x) 73 | ;; 74 | end 75 | 76 | type comment_kind = 77 | | Sexp_comment 78 | | Line_comment 79 | 80 | type content_kind = 81 | | Sexp 82 | | Comment of comment_kind 83 | 84 | type state = { content_kind : content_kind } 85 | 86 | let start_state = { content_kind = Sexp } 87 | let split = Portable_lazy.from_fun (fun () -> Re.Pcre.regexp "[ \t]+") 88 | 89 | let color_to_code = function 90 | | Black -> 30 91 | | Red -> 31 92 | | Green -> 32 93 | | Yellow -> 33 94 | | Blue -> 34 95 | | Magenta -> 35 96 | | Cyan -> 36 97 | | White -> 37 98 | | BrightBlack -> 90 99 | | BrightRed -> 91 100 | | BrightGreen -> 92 101 | | BrightYellow -> 93 102 | | BrightBlue -> 94 103 | | BrightMagenta -> 95 104 | | BrightCyan -> 96 105 | | BrightWhite -> 97 106 | | Default -> 39 107 | ;; 108 | 109 | let rainbow_open_tag conf tag = 110 | let args = Re.Pcre.split ~rex:(Portable_lazy.force split) tag in 111 | let color_count = Iarray.length conf.color_scheme in 112 | match args with 113 | | [ "d"; n ] -> 114 | let i = Int.of_string n in 115 | "[" 116 | ^ Int.to_string 117 | (color_to_code 118 | (if i < 0 || color_count < 1 119 | then Default 120 | else conf.color_scheme.:(i % color_count))) 121 | ^ "m" 122 | (* Printing out comments. *) 123 | | [ "c"; _ ] -> 124 | (match conf.comments with 125 | | Print (_, Some clr, _) -> "[" ^ Int.to_string (color_to_code clr) ^ "m" 126 | | _ -> "") 127 | | _ -> tag 128 | ;; 129 | 130 | let rainbow_tags conf = 131 | { Format.mark_open_stag = 132 | (function 133 | | Format.String_tag tag -> rainbow_open_tag conf tag 134 | | _ -> "") 135 | ; Format.mark_close_stag = 136 | (fun _ -> 137 | match conf.comments with 138 | | Print (_, Some _clr, _) -> "" 139 | | _ -> "") 140 | ; Format.print_open_stag = ignore 141 | ; Format.print_close_stag = ignore 142 | } 143 | ;; 144 | 145 | (* Opens n parentheses, starting at level depth. *) 146 | let open_parens conf state ~depth fmt n = 147 | match conf.paren_coloring, state.content_kind, conf.comments with 148 | (* Overrides the option not to color parentheses. *) 149 | | _, Comment _, Print (_, Some _, _) -> 150 | for i = depth to depth + n - 1 do 151 | Format.fprintf fmt "@{(@}" i 152 | done 153 | | true, Sexp, _ -> 154 | for i = depth to depth + n - 1 do 155 | Format.fprintf fmt "@{(@}" i 156 | done 157 | | _, _, _ -> 158 | for _ = depth to depth + n - 1 do 159 | Format.fprintf fmt "(" 160 | done 161 | ;; 162 | 163 | (* Closes n parentheses, starting at level depth+(n-1) to depth. *) 164 | let close_parens conf state ~depth fmt n = 165 | (* Overrides the option not to color parentheses. *) 166 | match conf.paren_coloring, state.content_kind, conf.comments with 167 | | _, Comment _, Print (_, Some _, _) -> 168 | for i = depth + (n - 1) downto depth do 169 | Format.fprintf fmt "@{)@}" i 170 | done 171 | | true, Sexp, _ -> 172 | for i = depth + (n - 1) downto depth do 173 | Format.fprintf fmt "@{)@}" i 174 | done 175 | | _, _, _ -> 176 | for _ = depth + (n - 1) downto depth do 177 | Format.fprintf fmt ")" 178 | done 179 | ;; 180 | 181 | let must_escape conf = function 182 | | "\\" -> false 183 | | string -> Sexp_impl.must_escape conf string 184 | ;; 185 | 186 | let atom_escape conf at = 187 | match conf.atom_printing with 188 | | Escaped | Interpreted -> Sexp_impl.mach_maybe_esc_str conf at 189 | | Minimal_escaping -> 190 | if Sexp_impl.must_escape conf at then Sexp_impl.minimal_escaping conf at else at 191 | ;; 192 | 193 | let atom_printing_len conf at = 194 | let s = atom_escape conf at in 195 | if String.for_all s ~f:Char.is_print then Some (String.length s) else None 196 | ;; 197 | 198 | let atom_printing_len_exn conf at = 199 | match atom_printing_len conf at with 200 | | Some len -> len 201 | | None -> 202 | raise_s 203 | (Sexp.List [ Atom "Sexp_pretty.atom_printing_len_exn: invalid input"; Atom at ]) 204 | ;; 205 | 206 | let pp_atom conf state ~depth ~len index fmt at = 207 | let at = 208 | match state.content_kind with 209 | | Comment Line_comment -> 210 | (* we never need to escape a line comment *) 211 | at 212 | | Sexp | Comment Sexp_comment -> 213 | if must_escape conf at 214 | then ( 215 | match conf.atom_printing with 216 | | Escaped | Interpreted -> Sexp_impl.esc_str conf at 217 | | Minimal_escaping -> Sexp_impl.minimal_escaping conf at) 218 | else at 219 | in 220 | let should_be_colored = 221 | match conf.atom_coloring with 222 | | Color_none -> false 223 | | Color_first threshold -> Int.equal index 0 && len <= threshold 224 | | Color_all -> true 225 | in 226 | match state.content_kind with 227 | | Comment _ -> 228 | (match conf.comments with 229 | | Drop -> assert false 230 | | Print (_, Some _, _) -> Format.fprintf fmt "@{%s@}" depth at 231 | | Print (_, None, _) -> Format.fprintf fmt "%s" at) 232 | | Sexp -> 233 | if should_be_colored 234 | then Format.fprintf fmt "@{%s@}" depth at 235 | else Format.fprintf fmt "%s" at 236 | ;; 237 | 238 | let pp_associated_comments conf ~depth fmt associated_comments = 239 | if not (List.is_empty associated_comments) 240 | then ( 241 | Format.fprintf fmt " "; 242 | Format.pp_open_vbox fmt 0; 243 | List.iteri associated_comments ~f:(fun i comment -> 244 | if i > 0 then Format.pp_print_break fmt 0 0; 245 | pp_atom conf { content_kind = Comment Line_comment } ~depth ~len:1 0 fmt comment); 246 | Format.pp_close_box fmt ()) 247 | ;; 248 | 249 | module Normalize = struct 250 | type t = 251 | | Sexp of sexp * string list 252 | | Comment of comment 253 | [@@deriving sexp] 254 | 255 | and comment = 256 | | Line_comment of string 257 | | Block_comment of int * string list 258 | | Sexp_comment of comment list * sexp 259 | 260 | and sexp = 261 | | Atom of string 262 | | List of t list 263 | 264 | let block_comment = 265 | Portable_lazy.from_fun (fun () -> 266 | Re.( 267 | seq 268 | [ str "#|" 269 | ; group (seq [ group (rep (set "\t ")); rep (alt [ char '\n'; any ]) ]) 270 | ; str "|#" 271 | ] 272 | |> compile)) 273 | ;; 274 | 275 | let word_split = Portable_lazy.from_fun (fun () -> Re.Pcre.regexp "[ \n\t]+") 276 | let trailing = Portable_lazy.from_fun (fun () -> Re.Pcre.regexp "(.*\\b)[ \t]*$") 277 | let tab_size = 2 278 | 279 | type match_dimension = 280 | | Horizontal 281 | | Vertical 282 | 283 | let match_block_comment comment = 284 | Re.exec_opt (Portable_lazy.force block_comment) comment 285 | ;; 286 | 287 | let is_block_comment comment = Option.is_some (match_block_comment comment) 288 | 289 | let grab_comments pos list = 290 | let rec loop dimension acc (pos : Parsexp.Positions.pos) = function 291 | | [] -> acc, [] 292 | | W.Sexp _ :: _ as list -> acc, list 293 | | (W.Comment (W.Plain_comment { loc = cpos; comment = content }) as comment) :: rest 294 | -> 295 | if (match dimension with 296 | | Horizontal -> pos.line = cpos.start_pos.line 297 | | Vertical -> pos.col = cpos.start_pos.col) 298 | && not (is_block_comment content) 299 | then loop Vertical (content :: acc) cpos.start_pos rest 300 | else acc, comment :: rest 301 | | W.Comment (W.Sexp_comment _) :: _ as list -> acc, list 302 | in 303 | let rev_comments, rest = loop Horizontal [] pos list in 304 | List.rev rev_comments, rest 305 | ;; 306 | 307 | let rec pre_process_atom conf pos atom = 308 | match conf.atom_printing with 309 | | Escaped | Minimal_escaping -> `Atom atom 310 | | Interpreted -> 311 | Option.value 312 | ~default:(`Atom atom) 313 | (Option.try_with (fun () -> 314 | match Parsexp.Many_cst.parse_string_exn atom with 315 | (* Perhaps normalized the atom, but nothing more to do. *) 316 | | [ W.Sexp (W.Atom { unescaped = None; _ }) ] -> `Atom atom 317 | (* Nested atom, try again. *) 318 | | [ W.Sexp (W.Atom { atom = inner_atom; unescaped = Some source; _ }) ] -> 319 | if String.equal inner_atom source 320 | then `Atom atom (* avoid an infinite loop of reinterpreting the atom *) 321 | else ( 322 | match pre_process_atom conf pos inner_atom with 323 | | `Atom _ -> `Atom atom 324 | (* original atom is better since it contains original 325 | spacing which will be stripped off by 326 | pre_process_atom *) 327 | | `List lst -> `List lst) 328 | (* Parsed one whole sexp, bubble it up. *) 329 | | [ W.Sexp (W.List { elements = list; _ }) ] -> `List list 330 | (* It would cause problems if we parsed a comment in the case the atom is a 331 | commented out sexp. We will be conservative here and we won't parse the 332 | comment. 333 | *) 334 | | [ W.Comment _ ] -> `Atom atom 335 | (* Results in an empty. We keep the original. *) 336 | | [] -> `Atom atom 337 | (* Parsed a list of multiple sexps. It could either be spliced into the current 338 | list, or put into a new Sexp list. 339 | At the moment, they are put into separate lists. 340 | *) 341 | (* If needed, we could traverse [sexps] and adjust positions so that they 342 | corespond to the respective positions in the original file. Also, we could 343 | calculate the end position of this list correctly. 344 | *) 345 | | sexps 346 | when List.for_all sexps ~f:(function 347 | | W.Sexp (W.Atom _) -> true 348 | | _ -> false) -> (* we parsed a plain string *) `Atom atom 349 | | sexps -> 350 | (* If atom was created by failwiths or structural_sexp, it would looks like 351 | this: 352 | "human-readable message followed by (potentially (long and (ugly sexp)))" 353 | 354 | We will try to preserve human-readable part by concatenating all sequences 355 | of top-level atoms into singe atom *) 356 | let break a b = 357 | match a, b with 358 | | W.Sexp (W.Atom _), W.Sexp (W.Atom _) -> false 359 | | _ -> true 360 | in 361 | let concatenate_atoms lst = 362 | List.group ~break lst 363 | |> List.map ~f:(function 364 | | W.Sexp (W.Atom { loc; _ }) :: _ as atoms -> 365 | let get_atom_contents = function 366 | | W.Sexp (W.Atom { atom = a; _ }) -> a 367 | | _ -> assert false 368 | (* List.group guarantees that we have only Atoms 369 | here *) 370 | in 371 | let atom_contents = 372 | List.map ~f:get_atom_contents atoms |> String.concat ~sep:" " 373 | in 374 | let escaped_atom_contents = 375 | Sexp_impl.mach_maybe_esc_str conf atom_contents 376 | in 377 | [ W.Sexp 378 | (W.Atom 379 | { loc 380 | ; atom = atom_contents 381 | ; unescaped = Some escaped_atom_contents 382 | }) 383 | ] 384 | | W.Sexp (W.List _) :: _ as lists -> lists 385 | | W.Comment _ :: _ as comments -> comments 386 | | [] -> [] (* cant really happen *)) 387 | |> List.concat 388 | in 389 | `List (concatenate_atoms sexps))) 390 | ;; 391 | 392 | let pre_process_block_comment style comment = 393 | match style with 394 | | Conservative_print -> String.split comment ~on:'\n' 395 | | Pretty_print -> 396 | String.strip comment 397 | |> Re.Pcre.split ~rex:(Portable_lazy.force word_split) 398 | |> List.map ~f:(fun line -> 399 | match Re.exec_opt (Portable_lazy.force trailing) line with 400 | | Some groups -> Re.Group.get groups 0 401 | | None -> line) 402 | |> List.filter ~f:(fun s -> String.length s > 0) 403 | ;; 404 | 405 | let get_size string = 406 | String.count string ~f:(fun c -> Char.equal c ' ') 407 | + (String.count string ~f:(fun c -> Char.equal c '\t') * tab_size) 408 | ;; 409 | 410 | exception Drop_exn 411 | 412 | (* Converts to t, does initial pre-processing - interprets/escapes atoms, 413 | reorders/drops/normalizes comments. 414 | *) 415 | let rec of_sexp_or_comment conf : W.t_or_comment -> t = function 416 | | W.Comment comment -> Comment (of_comment conf comment) 417 | | W.Sexp sexp -> Sexp (of_sexp conf sexp, []) 418 | 419 | and of_sexp (conf : Config.t) : W.t -> sexp = function 420 | | W.Atom { loc; atom; _ } -> 421 | (match pre_process_atom conf loc atom with 422 | | `Atom atom -> Atom atom 423 | | `List list -> of_sexp_or_comment_list conf list) 424 | | W.List { elements; _ } -> of_sexp_or_comment_list conf elements 425 | 426 | and of_sexp_or_comment_list (conf : Config.t) : W.t_or_comment list -> sexp = 427 | fun list -> 428 | match conf.comments with 429 | | Drop -> 430 | List 431 | (List.filter_map list ~f:(fun el -> 432 | match of_sexp_or_comment conf el with 433 | | t -> Some t 434 | | exception Drop_exn -> None)) 435 | | Print _ -> 436 | (* Re-orders comments to have comment that belong to a sexp before it, not after. If 437 | [conf.sticky_comments = Same_line], it ties the comments to the sexp instead *) 438 | let rec reorder acc = function 439 | | [] -> acc 440 | | W.Sexp (W.Atom { loc; _ } as sexp) :: rest -> 441 | reorder_comments acc loc.end_pos sexp rest 442 | | W.Sexp (W.List { loc; _ } as sexp) :: rest -> 443 | reorder_comments acc loc.end_pos sexp rest 444 | | W.Comment comment :: rest -> 445 | reorder (Comment (of_comment conf comment) :: acc) rest 446 | and reorder_comments acc pos sexp rest = 447 | let comments, rest = grab_comments pos rest in 448 | let sexp = of_sexp conf sexp in 449 | let with_comments init = 450 | List.fold comments ~init ~f:(fun acc comment -> 451 | Comment (Line_comment comment) :: acc) 452 | in 453 | match conf.sticky_comments with 454 | | Same_line -> reorder (Sexp (sexp, comments) :: acc) rest 455 | | Before -> reorder (Sexp (sexp, []) :: with_comments acc) rest 456 | | After -> reorder (with_comments (Sexp (sexp, []) :: acc)) rest 457 | in 458 | List (reorder [] list |> List.rev) 459 | 460 | and of_comment (conf : Config.t) : W.comment -> comment = function 461 | | W.Plain_comment { comment; _ } -> 462 | (match conf.comments with 463 | | Drop -> raise Drop_exn 464 | | Print (indent, _, style) -> 465 | (match match_block_comment comment with 466 | | Some group -> 467 | let indent = 468 | match indent with 469 | | Auto_indent_comment -> get_size (Re.Group.get group 2) + 2 470 | | Indent_comment i -> i 471 | in 472 | let text = pre_process_block_comment style (Re.Group.get group 1) in 473 | Block_comment (indent, text) 474 | | None -> Line_comment comment)) 475 | | W.Sexp_comment { comments; sexp; _ } -> 476 | (match conf.comments with 477 | | Drop -> raise Drop_exn 478 | | Print _ -> 479 | let comm_list = List.map comments ~f:(fun comment -> of_comment conf comment) in 480 | let sexp = of_sexp conf sexp in 481 | Sexp_comment (comm_list, sexp)) 482 | ;; 483 | end 484 | 485 | module Print = struct 486 | module N = Normalize 487 | 488 | (* [associated_comments] are line comments correspond to a sexp that are expected to be 489 | printed on the same line *) 490 | type associated_comments = string list 491 | type forces_breakline = bool 492 | 493 | type opened = 494 | | Opened 495 | | Closed 496 | 497 | type 'a tree = 498 | | Node of 'a tree list 499 | | Leaf of 'a 500 | 501 | (* Also contains the first atom list. *) 502 | type shape = (int * string) tree 503 | 504 | type t = 505 | | Sexp of sexp * associated_comments 506 | | Comment of comment 507 | 508 | and comment = 509 | | Line_comment of string 510 | | Block_comment of int * string list (* Does not contain the #| |#*) 511 | | Sexp_comment of (comment list * forces_breakline) * sexp 512 | 513 | and sexp = 514 | | Atom of string 515 | (* With leading atoms. *) 516 | | List of string array * t_or_aligned array * forces_breakline 517 | (* Sexp is a tree - List, Aligned, or Singleton *) 518 | | Singleton of string array * int * sexp * forces_breakline 519 | 520 | and t_or_aligned = 521 | | Aligned of aligned 522 | | T of t 523 | 524 | and aligned = (shape * associated_comments) * line array 525 | 526 | and line = 527 | | Atom_line of string tree * associated_comments 528 | | Comment_line of comment 529 | 530 | (* Unwraps singleton lists. *) 531 | let unwrap sexp = 532 | let rec inner level = function 533 | | N.List [ N.Sexp ((N.List _ as sexp_list), []) ] -> inner (level + 1) sexp_list 534 | | N.List _ as sexp_list -> level + 1, sexp_list 535 | | N.Atom _ as atom -> level, atom 536 | in 537 | inner 0 sexp 538 | ;; 539 | 540 | let maybe_singleton conf (t_list : Normalize.t list) = 541 | match conf.singleton_limit with 542 | | Singleton_limit (Atom_threshold max_at, Character_threshold max_char) -> 543 | let rec maybe_singleton_inner ~atom_count ~char_count acc = function 544 | | [] -> None 545 | | N.Sexp (N.Atom atom, []) :: tl -> 546 | let char_count = char_count + String.length atom in 547 | if atom_count = max_at || char_count > max_char 548 | then None 549 | else 550 | maybe_singleton_inner 551 | (atom :: acc) 552 | tl 553 | ~atom_count:(atom_count + 1) 554 | ~char_count 555 | | [ N.Sexp ((N.List _ as list), []) ] -> 556 | let level, list = unwrap list in 557 | Some (Array.of_list_rev acc, level, list) 558 | | N.Comment _ :: _ -> None 559 | | _ -> None 560 | in 561 | maybe_singleton_inner ~atom_count:0 ~char_count:0 [] t_list 562 | ;; 563 | 564 | let forces_breakline_atom ~conf atom = 565 | match conf.atom_printing with 566 | | Escaped | Interpreted -> false 567 | | Minimal_escaping -> String.mem atom '\n' 568 | ;; 569 | 570 | let forces_breakline_sexp ~conf = function 571 | | Atom atom -> forces_breakline_atom ~conf atom 572 | | List (_, _, forces) -> forces 573 | | Singleton (_, _, _, forces) -> forces 574 | ;; 575 | 576 | let forces_breakline_comment ~conf = function 577 | | Line_comment _ -> true 578 | | Block_comment _ -> false 579 | | Sexp_comment ((_, comm_force), sexp) -> 580 | comm_force || forces_breakline_sexp ~conf sexp 581 | ;; 582 | 583 | let forces_breakline ~conf = function 584 | | Sexp (sexp, []) -> forces_breakline_sexp ~conf sexp 585 | | Sexp (_, _ :: _) -> true 586 | | Comment comment -> forces_breakline_comment ~conf comment 587 | ;; 588 | 589 | let forces_breakline_aligned_or_t ~conf = function 590 | | Aligned _ -> true 591 | | T t -> forces_breakline ~conf t 592 | ;; 593 | 594 | exception Cant_align 595 | 596 | (* Check that the shape is the same and returns a new shape with updated sizes of tabs. *) 597 | let try_check_shape conf shape = 598 | let rec try_check_shape_inner shape t = 599 | match shape, t with 600 | | Leaf (len, at), N.Sexp (N.Atom at2, []) -> 601 | (match atom_printing_len conf at2 with 602 | | Some at2_len -> Leaf (max len at2_len, at), Leaf at2 603 | | None -> raise Cant_align) 604 | | Node shape_list, N.Sexp (N.List sexp_list, []) -> 605 | (match 606 | List.unzip (List.map2_exn shape_list sexp_list ~f:try_check_shape_inner) 607 | with 608 | | shape_list, atom_list -> Node shape_list, Node atom_list 609 | | exception Invalid_argument _ -> raise Cant_align) 610 | | _, _ -> raise Cant_align 611 | in 612 | function 613 | | N.Comment (N.Line_comment comment) -> 614 | Some (shape, Comment_line (Line_comment comment)) 615 | | N.Comment (N.Block_comment (n, list)) -> 616 | Some (shape, Comment_line (Block_comment (n, list))) 617 | | N.Comment (N.Sexp_comment _) -> None 618 | | N.Sexp (sexp, associated_comments) -> 619 | (match try_check_shape_inner shape (N.Sexp (sexp, [])) with 620 | | shape_list, atom_list -> 621 | Some (shape_list, Atom_line (atom_list, associated_comments)) 622 | | exception Cant_align -> None) 623 | ;; 624 | 625 | let get_shape conf ~atom_thresh ~char_thresh ~depth_thresh list = 626 | let rec get_shape_from_list ~depth ~atom_count ~char_count list_acc = function 627 | | [] -> List.rev list_acc, atom_count, char_count 628 | | hd :: tl -> 629 | let shape, atom_count, char_count = 630 | get_shape_inner hd ~depth ~atom_count ~char_count 631 | in 632 | get_shape_from_list (shape :: list_acc) tl ~depth ~atom_count ~char_count 633 | and get_shape_inner ~depth ~atom_count ~char_count t = 634 | (* Breached the depth threshold. *) 635 | if depth > depth_thresh then raise Cant_align; 636 | match t with 637 | | N.Comment _ -> raise Cant_align 638 | | N.Sexp (N.List list, []) -> 639 | let shape_list, atom_count, char_count = 640 | get_shape_from_list [] list ~depth:(depth + 1) ~atom_count ~char_count 641 | in 642 | Node shape_list, atom_count, char_count 643 | | N.Sexp (N.Atom atom, []) -> 644 | (match atom_printing_len conf atom with 645 | | Some atom_len -> 646 | let char_count = char_count + atom_len in 647 | if atom_count < atom_thresh && char_count <= char_thresh 648 | then 649 | Leaf (atom_len, atom), atom_count + 1, char_count 650 | (* Breached the number of atoms threshold or the number of characters threshold. *) 651 | else raise Cant_align 652 | | None -> raise Cant_align) 653 | | N.Sexp (_, _ :: _) -> raise Cant_align 654 | in 655 | try 656 | match get_shape_from_list [] list ~depth:1 ~atom_count:0 ~char_count:0 with 657 | | shape_list, _, _ -> Some (Node shape_list) 658 | with 659 | | Cant_align -> None 660 | ;; 661 | 662 | let rec shape_size = function 663 | | Leaf (len, _) -> len 664 | | Node list -> 665 | List.fold_left list ~init:0 ~f:(fun len shape -> len + shape_size shape) 666 | ;; 667 | 668 | let find_alignable conf shape ~char_thresh list = 669 | let rec find_alignable shape res_acc = function 670 | | [] -> shape, Array.of_list_rev res_acc, [] 671 | | hd :: tl -> 672 | (match try_check_shape conf shape hd with 673 | | None -> shape, Array.of_list_rev res_acc, hd :: tl 674 | | Some (new_shape, res) -> 675 | if shape_size new_shape <= char_thresh 676 | then 677 | find_alignable new_shape (res :: res_acc) tl 678 | (* Breached the number of characters threshold. *) 679 | else shape, Array.of_list_rev res_acc, hd :: tl) 680 | in 681 | find_alignable shape [] list 682 | ;; 683 | 684 | exception Too_many_atoms 685 | 686 | let get_leading_atoms conf (list : Normalize.t list) = 687 | match conf.leading_threshold with 688 | | Atom_threshold leading_atom_threshold, Character_threshold leading_char_threshold -> 689 | let rec get_leading_atoms_inner acc ~atom_count ~char_count = function 690 | | [] -> Array.of_list_rev acc, [] 691 | | N.Sexp (N.Atom atom, []) :: tl as list -> 692 | (match forces_breakline_atom ~conf atom with 693 | | true -> Array.of_list_rev acc, list 694 | | false -> 695 | let char_count = char_count + String.length atom in 696 | if atom_count = leading_atom_threshold || char_count > leading_char_threshold 697 | (* Breached the threshold for number of leading atoms. *) 698 | then raise Too_many_atoms 699 | else 700 | get_leading_atoms_inner 701 | (atom :: acc) 702 | tl 703 | ~atom_count:(atom_count + 1) 704 | ~char_count) 705 | | list -> Array.of_list_rev acc, list 706 | in 707 | (try get_leading_atoms_inner [] ~atom_count:0 ~char_count:0 list with 708 | | Too_many_atoms -> [||], list) 709 | ;; 710 | 711 | let preprocess conf (t : Normalize.t) : t = 712 | let rec preprocess_t = function 713 | | N.Comment comment -> Comment (preprocess_comment comment) 714 | | N.Sexp (sexp, associated_comments) -> 715 | Sexp (preprocess_sexp sexp, associated_comments) 716 | and preprocess_sexp = function 717 | | N.Atom atom -> Atom atom 718 | | N.List list -> 719 | (match maybe_singleton conf list with 720 | | Some (atoms, lvl, sexp) -> 721 | let proc_sexp = preprocess_sexp sexp in 722 | Singleton (atoms, lvl, proc_sexp, forces_breakline_sexp ~conf proc_sexp) 723 | | None -> 724 | let leading_atoms, rest = get_leading_atoms conf list in 725 | let aligned_or_t = 726 | match conf.data_alignment with 727 | | Data_not_aligned -> 728 | Array.of_list_map rest ~f:(fun el -> T (preprocess_t el)) 729 | | Data_aligned 730 | ( _ 731 | , Atom_threshold atom_thresh 732 | , Character_threshold char_thresh 733 | , Depth_threshold depth_thresh ) -> 734 | try_align rest ~atom_thresh ~char_thresh ~depth_thresh 735 | in 736 | List 737 | ( leading_atoms 738 | , aligned_or_t 739 | , Array.exists aligned_or_t ~f:(forces_breakline_aligned_or_t ~conf) )) 740 | and preprocess_comment = function 741 | | N.Line_comment comment -> Line_comment comment 742 | | N.Block_comment (i, comment) -> Block_comment (i, comment) 743 | | N.Sexp_comment (comment_list, sexp) -> 744 | let proc_comment_list = List.map comment_list ~f:preprocess_comment in 745 | let proc_sexp = preprocess_sexp sexp in 746 | let comm_force = 747 | List.exists proc_comment_list ~f:(forces_breakline_comment ~conf) 748 | in 749 | Sexp_comment ((proc_comment_list, comm_force), proc_sexp) 750 | and try_align ~atom_thresh ~char_thresh ~depth_thresh list = 751 | let rec try_align_inner acc = function 752 | | [] -> Array.of_list_rev acc 753 | | [ last ] -> Array.of_list_rev (T (preprocess_t last) :: acc) 754 | | (N.Comment _ as comment) :: tl -> 755 | try_align_inner (T (preprocess_t comment) :: acc) tl 756 | | N.Sexp ((N.Atom _ as sexp), associated_comments) :: tl -> 757 | try_align_inner (T (Sexp (preprocess_sexp sexp, associated_comments)) :: acc) tl 758 | | N.Sexp ((N.List list as sexp), associated_comments) :: tl -> 759 | let shape = get_shape conf list ~atom_thresh ~char_thresh ~depth_thresh in 760 | (match shape with 761 | | None -> 762 | try_align_inner 763 | (T (Sexp (preprocess_sexp sexp, associated_comments)) :: acc) 764 | tl 765 | | Some shape -> 766 | let shape, aligned, rest = find_alignable conf shape tl ~char_thresh in 767 | if Array.exists aligned ~f:(function 768 | | Atom_line _ -> true 769 | | _ -> false) 770 | then 771 | try_align_inner 772 | (Aligned ((shape, associated_comments), aligned) :: acc) 773 | rest 774 | else 775 | try_align_inner 776 | (T (Sexp (preprocess_sexp sexp, associated_comments)) :: acc) 777 | tl) 778 | in 779 | try_align_inner [] list 780 | in 781 | preprocess_t t 782 | ;; 783 | 784 | let set_up_tabulation conf state parens_aligned shape depth fmt = 785 | let rec set_up_markers ~depth ~index : shape -> int = function 786 | | Leaf (tab, at) -> 787 | Format.pp_set_tab fmt (); 788 | pp_atom conf state ~depth ~len:1 index fmt at; 789 | (* Spaces that should still be printed*) 790 | tab - atom_printing_len_exn conf at 791 | | Node shape_list -> 792 | Format.pp_set_tab fmt (); 793 | open_parens conf state ~depth:(depth + 1) fmt 1; 794 | let trailing_spaces = 795 | List.foldi shape_list ~init:0 ~f:(fun i previous_spaces el -> 796 | for _ = 1 to previous_spaces do 797 | Format.fprintf fmt " " 798 | done; 799 | if i > 0 then Format.fprintf fmt " "; 800 | set_up_markers ~depth:(depth + 1) ~index:i el) 801 | in 802 | if parens_aligned 803 | then ( 804 | for _ = 1 to trailing_spaces do 805 | Format.fprintf fmt " " 806 | done; 807 | Format.pp_set_tab fmt (); 808 | close_parens conf state ~depth:(depth + 1) fmt 1; 809 | 0) 810 | else ( 811 | close_parens conf state ~depth:(depth + 1) fmt 1; 812 | trailing_spaces) 813 | in 814 | ignore (set_up_markers ~depth ~index:0 shape : int) 815 | ;; 816 | 817 | (* The closing paren goes on a new line, or the last element forces a breakline. *) 818 | let newline_at_end conf sexp = 819 | match conf.closing_parens with 820 | | New_line -> true 821 | | Same_line -> 822 | (match sexp with 823 | | List (_, list, true) -> 824 | (not (Array.is_empty list)) 825 | && 826 | (match Array.last_exn list with 827 | | Aligned (_, line_list) -> 828 | (* Would not create an [Aligned] with an empty [line_list] *) 829 | (match Array.last_exn line_list with 830 | | Comment_line (Line_comment _) | Atom_line (_, _ :: _) -> true 831 | | Comment_line (Block_comment _ | Sexp_comment _) | Atom_line (_, []) -> 832 | false) 833 | | T (Comment (Line_comment _) | Sexp (_, _ :: _)) -> true 834 | | T (Comment (Block_comment _ | Sexp_comment _) | Sexp (_, [])) -> false) 835 | | List (_, _, false) | Atom _ | Singleton _ -> false) 836 | ;; 837 | 838 | let rec pp_t conf state ?(opened = Closed) ?(len = 1) depth ?(index = 0) fmt = function 839 | | Sexp (sexp, associated_comments) -> 840 | pp_sexp conf state ~opened depth ~index ~len fmt sexp; 841 | pp_associated_comments conf ~depth fmt associated_comments 842 | | Comment comment -> pp_comment conf state depth ~index fmt comment 843 | 844 | and pp_sexp conf state ~opened ?(len = 1) depth ~index fmt = function 845 | | Atom at -> pp_atom conf state ~depth ~len index fmt at 846 | | List (leading, list, forces_breakline) as sexp_list -> 847 | let print_leading len fmt leading = 848 | Format.fprintf 849 | fmt 850 | "@[%a@]" 851 | (Format.pp_arrayi "@ " (pp_atom conf state ~depth:(depth + 1) ~len)) 852 | leading 853 | in 854 | let print_rest off fmt rest = 855 | Format.pp_arrayi 856 | "@ " 857 | (fun i fmt el -> 858 | pp_t_or_aligned 859 | conf 860 | state 861 | (depth + 1) 862 | ~index:(i + off) 863 | ~len:(Array.length rest) 864 | fmt 865 | el) 866 | fmt 867 | rest 868 | in 869 | let print_opened fmt leading rest = 870 | let leading_len = Array.length leading in 871 | let leading_is_not_empty = leading_len > 0 in 872 | let rest_is_not_empty = not (Array.is_empty rest) in 873 | if leading_is_not_empty then print_leading leading_len fmt leading; 874 | if leading_is_not_empty && rest_is_not_empty then Format.pp_print_space fmt (); 875 | if rest_is_not_empty then print_rest leading_len fmt rest 876 | in 877 | let print_closed print leading rest = 878 | let leading_len = Array.length leading in 879 | let leading_not_empty = leading_len > 0 in 880 | let rest_not_empty = not (Array.is_empty rest) in 881 | let same_line_rest = 882 | match conf.opening_parens with 883 | | New_line -> false 884 | | Same_line -> rest_not_empty && not leading_not_empty 885 | in 886 | print 887 | (if same_line_rest then 1 else conf.indent) 888 | (fun fmt () -> open_parens conf state ~depth:(depth + 1) fmt 1) 889 | () 890 | (fun fmt (leading, rest) -> 891 | if leading_not_empty then print_leading leading_len fmt leading; 892 | (* Close the leading atom block. *) 893 | Format.pp_close_box fmt (); 894 | if rest_not_empty 895 | then 896 | if leading_not_empty 897 | then Format.pp_print_space fmt () 898 | else if not same_line_rest 899 | then Format.pp_print_cut fmt (); 900 | if rest_not_empty then print_rest leading_len fmt rest) 901 | (leading, rest) 902 | (fun fmt () -> close_parens conf state ~depth:(depth + 1) fmt 1) 903 | () 904 | in 905 | (match leading, list, forces_breakline, opened, newline_at_end conf sexp_list with 906 | | [||], [||], _, Closed, _ -> 907 | open_parens conf state ~depth:(depth + 1) fmt 1; 908 | close_parens conf state ~depth:(depth + 1) fmt 1 909 | | leading, rest, false, Opened, _ -> 910 | Format.pp_open_hvbox fmt 0; 911 | print_opened fmt leading rest; 912 | Format.pp_close_box fmt () 913 | | leading, rest, true, Opened, _ -> print_opened fmt leading rest 914 | | leading, rest, true, Closed, true -> 915 | (* There must be something in the list, if it forces a breakline *) 916 | print_closed (Format.fprintf fmt "@[@[%a%a@]@,%a") leading rest 917 | | leading, rest, true, Closed, false -> 918 | (* There must be something in the list, if it forces a breakline *) 919 | print_closed (Format.fprintf fmt "@[@[%a%a@]%a") leading rest 920 | | leading, rest, false, Closed, true -> 921 | print_closed 922 | (Format.fprintf fmt "@[@[@[@[%a%a@]@,@]%a@]") 923 | leading 924 | rest 925 | | leading, rest, false, Closed, false -> 926 | print_closed 927 | (Format.fprintf fmt "@[@[@[@[%a%a@]@]%a@]") 928 | leading 929 | rest) 930 | | Singleton (atoms, d, sexp, forces_breakline) -> 931 | let print_opened printer atoms = 932 | printer 933 | conf.indent 934 | (Format.pp_arrayi 935 | "@ " 936 | (pp_atom conf state ~depth:(depth + 1) ~len:(Array.length atoms))) 937 | atoms 938 | (open_parens conf state ~depth:(depth + 2)) 939 | d 940 | (pp_sexp conf state ~opened:Opened (depth + d) ~index:0 ~len:1) 941 | sexp 942 | (close_parens conf state ~depth:(depth + 2)) 943 | d 944 | in 945 | let print_closed printer atoms = 946 | printer 947 | conf.indent 948 | (open_parens conf state ~depth:(depth + 1)) 949 | 1 950 | (fun fmt -> function 951 | | [||] -> () 952 | | atoms -> 953 | Format.pp_arrayi 954 | "@ " 955 | (pp_atom conf state ~depth:(depth + 1) ~len:(Array.length atoms)) 956 | fmt 957 | atoms; 958 | Format.pp_print_space fmt ()) 959 | atoms 960 | (open_parens conf state ~depth:(depth + 2)) 961 | d 962 | (pp_sexp conf state ~opened:Opened (depth + d) ~len:1 ~index:0) 963 | sexp 964 | (close_parens conf state ~depth:(depth + 1)) 965 | (d + 1) 966 | in 967 | (match atoms, forces_breakline, opened, newline_at_end conf sexp with 968 | | [||], _, Opened, _ -> assert false 969 | | atoms, true, Closed, true -> 970 | print_closed (Format.fprintf fmt "@[@[%a%a%a@]@,%a@]@,%a") atoms 971 | | atoms, true, Closed, false -> 972 | print_closed (Format.fprintf fmt "@[@[%a%a%a@]@,%a@]%a") atoms 973 | | atoms, false, Closed, true -> 974 | print_closed 975 | (Format.fprintf fmt "@[@[@[@[%a%a%a@]@,%a@]@,@]%a@]") 976 | atoms 977 | | atoms, false, Closed, false -> 978 | print_closed 979 | (Format.fprintf fmt "@[@[@[@[%a%a%a@]@,%a@]@]%a@]") 980 | atoms 981 | | atoms, true, Opened, true -> 982 | print_opened (Format.fprintf fmt "@[@[%a@ %a@]@,%a@]@,%a") atoms 983 | | atoms, true, Opened, false -> 984 | print_opened (Format.fprintf fmt "@[@[%a@ %a@]@,%a@]%a") atoms 985 | | atoms, false, Opened, true -> 986 | print_opened 987 | (Format.fprintf fmt "@[@[@[@[%a@ %a@]@,%a@]@,@]%a@]") 988 | atoms 989 | | atoms, false, Opened, false -> 990 | print_opened 991 | (Format.fprintf fmt "@[@[@[@[%a@ %a@]@,%a@]@]%a@]") 992 | atoms) 993 | 994 | and pp_t_or_aligned conf state depth ~len ~index fmt = function 995 | | T t -> pp_t conf state ~len depth ~index fmt t 996 | | Aligned ((shape, associated_comments), line_list) -> 997 | pp_aligned conf state depth fmt shape associated_comments line_list 998 | 999 | and pp_comment conf state depth ~index fmt comment = 1000 | match conf.comments with 1001 | | Drop -> assert false 1002 | | _ -> 1003 | (); 1004 | (match comment with 1005 | | Line_comment comment -> 1006 | pp_atom 1007 | conf 1008 | { content_kind = Comment Line_comment } 1009 | ~depth 1010 | ~len:1 1011 | index 1012 | fmt 1013 | comment 1014 | | Block_comment (indent, comment_list) -> 1015 | (match conf.comments with 1016 | | Drop -> assert false (* Would have dropped the comment at pre-processing. *) 1017 | | Print (_, color, Conservative_print) -> 1018 | let f = 1019 | match color with 1020 | | Some _ -> Format.fprintf fmt "@{@[#|%a|#@]@}" 1021 | (* This is an ugly hack not to print anything if colors are disabled. The opening 1022 | tag works fine, as it checks whether or not anything should be printed. The 1023 | closing one doesn't (it can't have any arguments, which is bad). 1024 | *) 1025 | | None -> Format.fprintf fmt "@{#|%a|#@]" 1026 | in 1027 | f 1028 | depth 1029 | (fun fmt comment_list -> 1030 | Format.pp_list 1031 | "@." 1032 | (fun fmt comm -> Format.fprintf fmt "%s" comm) 1033 | fmt 1034 | comment_list) 1035 | comment_list 1036 | | Print (_, color, Pretty_print) -> 1037 | let f = 1038 | match color with 1039 | | Some _ -> 1040 | Format.fprintf 1041 | fmt 1042 | "@{@[@[@[#|%a@[%a@]@]@ @]|#@]@}" 1043 | | None -> 1044 | Format.fprintf fmt "@{@[@[@[#|%a@[%a@]@]@ @]|#@]" 1045 | in 1046 | f 1047 | depth 1048 | indent 1049 | (fun fmt spaces -> Format.pp_print_break fmt spaces 0) 1050 | (if indent > 2 && not (List.is_empty comment_list) then indent - 2 else 0) 1051 | (fun fmt comment_list -> 1052 | Format.pp_list "@ " Format.pp_print_string fmt comment_list) 1053 | comment_list) 1054 | | Sexp_comment ((comments, _), sexp) -> 1055 | (match conf.comments with 1056 | | Drop -> assert false 1057 | | Print (_, Some _, _) -> Format.fprintf fmt "@{#;@}@ " depth 1058 | | Print (_, None, _) -> Format.fprintf fmt "#;@ "); 1059 | List.iteri comments ~f:(fun i comm -> 1060 | pp_comment conf state depth ~index:i fmt comm); 1061 | if not (List.is_empty comments) then Format.pp_print_space fmt (); 1062 | pp_sexp 1063 | conf 1064 | { content_kind = Comment Sexp_comment } 1065 | ~opened:Closed 1066 | depth 1067 | ~index 1068 | fmt 1069 | sexp) 1070 | 1071 | and pp_aligned conf state depth fmt shape associated_comments align_list = 1072 | let parens_aligned = 1073 | match conf.data_alignment with 1074 | | Data_aligned (Parens_alignment a, _, _, _) -> a 1075 | | _ -> assert false 1076 | in 1077 | let rec print_aligned ~depth index = function 1078 | | Leaf at -> 1079 | Format.pp_print_tab fmt (); 1080 | pp_atom conf state ~depth ~len:1 index fmt at 1081 | | Node list -> 1082 | Format.pp_print_tab fmt (); 1083 | open_parens conf state ~depth:(depth + 1) fmt 1; 1084 | List.iteri list ~f:(print_aligned ~depth:(depth + 1)); 1085 | if parens_aligned then Format.pp_print_tab fmt (); 1086 | close_parens conf state ~depth:(depth + 1) fmt 1 1087 | in 1088 | let print_aligned_or_comment index = function 1089 | (* Comments on a separate line for now. *) 1090 | | Comment_line comm -> 1091 | Format.pp_print_cut fmt (); 1092 | pp_comment conf state depth ~index fmt comm 1093 | | Atom_line (line, associated_comments) -> 1094 | Format.pp_print_cut fmt (); 1095 | print_aligned ~depth 0 line; 1096 | pp_associated_comments conf ~depth fmt associated_comments 1097 | in 1098 | Format.pp_open_tbox fmt (); 1099 | set_up_tabulation conf state parens_aligned shape depth fmt; 1100 | pp_associated_comments conf ~depth fmt associated_comments; 1101 | Array.iteri align_list ~f:print_aligned_or_comment; 1102 | Format.pp_close_tbox fmt () 1103 | ;; 1104 | 1105 | let pp_sexp_rainbow_toplevel conf fmt sexp = 1106 | let t = Normalize.of_sexp_or_comment conf sexp in 1107 | let aligned = preprocess conf t in 1108 | Format.fprintf 1109 | fmt 1110 | "@[%a@]@." 1111 | (pp_t conf start_state ~opened:Closed 0 ~index:0) 1112 | aligned 1113 | ;; 1114 | end 1115 | 1116 | let setup conf fmt = 1117 | Format.pp_set_formatter_stag_functions fmt (rainbow_tags conf); 1118 | Format.pp_set_tags fmt true 1119 | ;; 1120 | 1121 | let run ~next conf fmt = 1122 | setup conf fmt; 1123 | let rec loop prints_newline = 1124 | match next () with 1125 | | None -> () 1126 | | Some t_or_comment -> 1127 | (match conf.comments, t_or_comment with 1128 | | Drop, W.Comment _ -> loop prints_newline 1129 | | Print _, W.Comment _ -> 1130 | (match prints_newline, conf.separator with 1131 | | true, Empty_line -> Format.pp_print_break fmt 0 0 1132 | | false, _ | _, No_separator -> ()); 1133 | Print.pp_sexp_rainbow_toplevel conf fmt t_or_comment; 1134 | loop false 1135 | | _, W.Sexp _ -> 1136 | (match prints_newline, conf.separator with 1137 | | true, Empty_line -> Format.pp_print_break fmt 0 0 1138 | | false, _ | _, No_separator -> ()); 1139 | Print.pp_sexp_rainbow_toplevel conf fmt t_or_comment; 1140 | loop true) 1141 | in 1142 | Format.pp_open_vbox fmt 0; 1143 | loop false; 1144 | if conf.paren_coloring then (* Reset all formatting *) 1145 | Format.pp_print_string fmt ""; 1146 | Format.pp_close_box fmt (); 1147 | Format.pp_print_flush fmt () 1148 | ;; 1149 | 1150 | let dummy_pos = Parsexp.Positions.beginning_of_file 1151 | let dummy_range = { Parsexp.Positions.start_pos = dummy_pos; end_pos = dummy_pos } 1152 | 1153 | let rec sexp_to_sexp_or_comment conf = function 1154 | | Sexp.Atom at -> 1155 | let fmt_at = Some (Sexp_impl.mach_maybe_esc_str conf at) in 1156 | W.Sexp (W.Atom { loc = dummy_range; atom = at; unescaped = fmt_at }) 1157 | | Sexp.List list -> 1158 | W.Sexp 1159 | (W.List 1160 | { loc = dummy_range; elements = List.map list ~f:(sexp_to_sexp_or_comment conf) }) 1161 | ;; 1162 | 1163 | module Make (M : sig 1164 | type t 1165 | 1166 | val to_sexp_or_comment : Config.t -> t -> Parsexp.Cst.t_or_comment 1167 | end) : sig 1168 | include S with type sexp := M.t 1169 | end = struct 1170 | type 'a writer = Config.t -> 'a -> M.t -> unit 1171 | 1172 | let pp_formatter conf fmt sexp = 1173 | let t_or_comment = M.to_sexp_or_comment conf sexp in 1174 | let next = 1175 | let stop = ref false in 1176 | fun () -> 1177 | if !stop 1178 | then None 1179 | else ( 1180 | stop := true; 1181 | Some t_or_comment) 1182 | in 1183 | run ~next conf fmt 1184 | ;; 1185 | 1186 | let pp_formatter' ~next conf fmt = 1187 | run 1188 | ~next:(fun () -> 1189 | match next () with 1190 | | None -> None 1191 | | Some s -> Some (M.to_sexp_or_comment conf s)) 1192 | conf 1193 | fmt 1194 | ;; 1195 | 1196 | let pp_buffer conf buffer sexp = 1197 | pp_formatter conf (Format.formatter_of_buffer buffer) sexp 1198 | ;; 1199 | 1200 | let pp_out_channel conf oc sexp = 1201 | pp_formatter conf (Format.formatter_of_out_channel oc) sexp 1202 | ;; 1203 | 1204 | let pp_blit conf blit sexp = 1205 | let formatter = 1206 | Format.make_formatter (fun buf pos len -> blit buf ~pos ~len) ignore 1207 | in 1208 | pp_formatter conf formatter sexp 1209 | ;; 1210 | 1211 | let pretty_string conf sexp = 1212 | let buffer = Buffer.create 16 in 1213 | pp_buffer conf buffer sexp; 1214 | Buffer.contents buffer 1215 | ;; 1216 | 1217 | let sexp_to_string = 1218 | let config = Portable_lazy.from_fun (fun () -> Config.create ~color:false ()) in 1219 | fun sexp -> pretty_string (Portable_lazy.force config) sexp 1220 | ;; 1221 | end 1222 | 1223 | include Make (struct 1224 | type t = Sexp.t 1225 | 1226 | let to_sexp_or_comment = sexp_to_sexp_or_comment 1227 | end) 1228 | 1229 | module Parsexp_cst = Make (struct 1230 | type t = W.t_or_comment 1231 | 1232 | let to_sexp_or_comment (_ : Config.t) = Fn.id 1233 | end) 1234 | 1235 | let sexp_with_layout_to_sexp_or_comment sexp_with_layout_or_comment = 1236 | let convert_pos (pos : Sexplib.Sexp.With_layout.pos) : Parsexp.Positions.pos = 1237 | { line = pos.row; col = pos.col; offset = 0 } 1238 | in 1239 | let atom_end_position ~(pos : Sexplib.Sexp.With_layout.pos) ~atom ~unescaped = 1240 | convert_pos 1241 | (match unescaped with 1242 | | None -> { pos with col = pos.col + String.length atom } 1243 | | Some quoted_string -> 1244 | String.fold quoted_string ~init:pos ~f:(fun pos char -> 1245 | match char with 1246 | | '\n' -> { row = pos.row + 1; col = 0 } 1247 | | _ -> { pos with col = pos.col + 1 })) 1248 | in 1249 | let convert_range (pos : Sexplib.Sexp.With_layout.pos) ~len : Parsexp.Positions.range = 1250 | let start_pos = convert_pos pos in 1251 | { start_pos 1252 | ; end_pos = 1253 | { start_pos with col = start_pos.col + len; offset = start_pos.offset + len } 1254 | } 1255 | in 1256 | let rec convert_sexp_or_comment 1257 | : Sexplib.Sexp.With_layout.t_or_comment -> W.t_or_comment 1258 | = function 1259 | | Sexp s -> W.Sexp (convert_sexp s) 1260 | | Comment comment -> W.Comment (convert_comment comment) 1261 | and convert_comment : Sexplib.Sexp.With_layout.comment -> W.comment = function 1262 | | Plain_comment (pos, comment) -> 1263 | W.Plain_comment { loc = convert_range pos ~len:(String.length comment); comment } 1264 | | Sexp_comment (pos, comments, sexp) -> 1265 | W.Sexp_comment 1266 | { hash_semi_pos = convert_pos pos 1267 | ; comments = List.map comments ~f:convert_comment 1268 | ; sexp = convert_sexp sexp 1269 | } 1270 | and convert_sexp : Sexplib.Sexp.With_layout.t -> W.t = function 1271 | | Atom (pos, atom, unescaped) -> 1272 | W.Atom 1273 | { loc = 1274 | { start_pos = convert_pos pos 1275 | ; end_pos = atom_end_position ~pos ~atom ~unescaped 1276 | } 1277 | ; atom 1278 | ; unescaped 1279 | } 1280 | | List (start_pos, elements, end_pos) -> 1281 | W.List 1282 | { loc = { start_pos = convert_pos start_pos; end_pos = convert_pos end_pos } 1283 | ; elements = List.map elements ~f:convert_sexp_or_comment 1284 | } 1285 | in 1286 | convert_sexp_or_comment sexp_with_layout_or_comment 1287 | ;; 1288 | 1289 | module Sexp_with_layout = Make (struct 1290 | type t = Sexplib.Sexp.With_layout.t_or_comment 1291 | 1292 | let to_sexp_or_comment (_ : Config.t) = sexp_with_layout_to_sexp_or_comment 1293 | end) 1294 | --------------------------------------------------------------------------------