├── .gitignore ├── README.md ├── benchmarks ├── concat.rkt ├── flatten.rkt ├── wadler-opt.rkt ├── sexp-random.rkt ├── sexp-full.rkt ├── fill-sep.rkt └── json.rkt ├── info.rkt ├── promise.rkt ├── LICENSE-APACHE ├── .github └── workflows │ └── ci.yml ├── LICENSE-MIT ├── process.rkt ├── benchtool.rkt ├── examples.rkt ├── addons.rkt ├── main.rkt ├── doc.rkt ├── core.rkt └── scribblings └── pretty-expressive.scrbl /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | \#* 3 | .\#* 4 | .DS_Store 5 | compiled/ 6 | /doc/ 7 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | pretty-expressive 2 | ================= 3 | 4 | An pretty expressive printer in Racket. View the documentation at https://docs.racket-lang.org/pretty-expressive/ 5 | -------------------------------------------------------------------------------- /benchmarks/concat.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (module test racket/base) 4 | 5 | (require pretty-expressive 6 | pretty-expressive/benchtool) 7 | 8 | (setup "concat" #:size 10000) 9 | 10 | (define (pp n) 11 | (cond 12 | [(zero? n) empty-doc] 13 | [else (<> (pp (sub1 n)) (text "line"))])) 14 | 15 | (define doc (pp (current-size))) 16 | (do-bench doc) 17 | -------------------------------------------------------------------------------- /info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | (define collection "pretty-expressive") 3 | (define deps '("base")) 4 | (define build-deps '("scribble-lib" "racket-doc" "rackunit-lib")) 5 | (define scribblings '(("scribblings/pretty-expressive.scrbl" ()))) 6 | (define pkg-desc "A pretty expressive printer") 7 | (define version "1.1") 8 | (define pkg-authors '(sorawee)) 9 | (define license '(Apache-2.0 OR MIT)) 10 | -------------------------------------------------------------------------------- /benchmarks/flatten.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (module test racket/base) 4 | 5 | (require pretty-expressive 6 | pretty-expressive/benchtool) 7 | 8 | (setup "flatten" #:size 1000) 9 | 10 | (define (quadratic n) 11 | (cond 12 | [(zero? n) (text "line")] 13 | [else (group (<> (quadratic (sub1 n)) nl (text "line")))])) 14 | 15 | (define doc (quadratic (current-size))) 16 | (do-bench doc) 17 | -------------------------------------------------------------------------------- /benchmarks/wadler-opt.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (module test racket/base) 4 | 5 | (require pretty-expressive 6 | pretty-expressive/benchtool) 7 | 8 | (setup "wadler-opt" #:size 0 #:page-width 5) 9 | 10 | (unless (zero? (current-size)) 11 | (raise-user-error "Size must be zero")) 12 | 13 | (define doc 14 | (<> (group (<> (text "AAA") nl)) 15 | (nest 5 16 | (group (<> (text "B") nl 17 | (text "B") nl 18 | (text "B")))))) 19 | 20 | (pretty-print doc) 21 | -------------------------------------------------------------------------------- /promise.rkt: -------------------------------------------------------------------------------- 1 | ;; A promise that also records an overestimation of newlines 2 | 3 | #lang racket/base 4 | 5 | (#%declare #:unsafe) 6 | 7 | (provide promise? 8 | promise-nl 9 | force 10 | delay) 11 | 12 | (struct promise (nl val) #:mutable) 13 | 14 | (define (force v) 15 | (cond 16 | [(procedure? (promise-val v)) 17 | (define forced ((promise-val v))) 18 | (set-promise-val! v forced) 19 | forced] 20 | [else (promise-val v)])) 21 | 22 | (define-syntax-rule (delay #:nl nl e ...) 23 | (promise nl (λ () e ...))) 24 | -------------------------------------------------------------------------------- /LICENSE-APACHE: -------------------------------------------------------------------------------- 1 | Copyright 2021 sorawee 2 | 3 | Licensed under the Apache License, Version 2.0 (the "License"); 4 | you may not use this file except in compliance with the License. 5 | You may obtain a copy of the License at 6 | 7 | http://www.apache.org/licenses/LICENSE-2.0 8 | 9 | Unless required by applicable law or agreed to in writing, software 10 | distributed under the License is distributed on an "AS IS" BASIS, 11 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | See the License for the specific language governing permissions and 13 | limitations under the License. 14 | -------------------------------------------------------------------------------- /benchmarks/sexp-random.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (module test racket/base) 4 | 5 | (require pretty-expressive 6 | pretty-expressive/benchtool 7 | racket/file 8 | json) 9 | 10 | (setup "sexp-random" #:size 1) 11 | 12 | (define (pp s) 13 | (cond 14 | [(list? s) 15 | (define s* (map pp s)) 16 | (<+> (text "(") (alt (v-concat s*) (as-concat s*)) (text ")"))] 17 | [else (text s)])) 18 | 19 | (define json 20 | (string->jsexpr 21 | (file->string 22 | (build-path (getenv "BENCHDATA") 23 | (format "random-tree-~a.sexp" (current-size)))))) 24 | 25 | (define doc (pp json)) 26 | (do-bench doc) 27 | -------------------------------------------------------------------------------- /benchmarks/sexp-full.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (module test racket/base) 4 | 5 | (require pretty-expressive 6 | pretty-expressive/benchtool) 7 | 8 | (setup "sexp-full" #:size 10) 9 | 10 | (define (pp s) 11 | (cond 12 | [(list? s) 13 | (define s* (map pp s)) 14 | (<+> (text "(") (alt (v-concat s*) (as-concat s*)) (text ")"))] 15 | [else (text s)])) 16 | 17 | (define (test-expr n c) 18 | (cond 19 | [(zero? n) (values (number->string c) (add1 c))] 20 | [else 21 | (define-values (t1 c1) (test-expr (sub1 n) c)) 22 | (define-values (t2 c2) (test-expr (sub1 n) c1)) 23 | (values (list t1 t2) c2)])) 24 | 25 | (define-values (t _) (test-expr (current-size) 0)) 26 | (define doc (pp t)) 27 | (do-bench doc) 28 | -------------------------------------------------------------------------------- /benchmarks/fill-sep.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (module test racket/base) 4 | 5 | (require pretty-expressive 6 | pretty-expressive/benchtool 7 | racket/match 8 | racket/file 9 | (only-in racket/list take)) 10 | 11 | (setup "fill-sep" #:size 20000) 12 | 13 | (define (fill-sep xs) 14 | (match xs 15 | ['() empty-doc] 16 | [(cons x xs) 17 | (let loop ([xs xs] [acc (text x)]) 18 | (match xs 19 | ['() acc] 20 | [(cons x xs) 21 | (loop xs (alt (<+> acc space (text x)) 22 | (<$> acc (text x))))]))])) 23 | 24 | (define lines (file->lines (build-path (getenv "BENCHDATA") "words"))) 25 | (define doc (fill-sep (take lines (current-size)))) 26 | (do-bench doc) 27 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | on: [push, pull_request] 2 | name: CI 3 | jobs: 4 | build: 5 | name: "Build on Racket '${{ matrix.racket-version }}' (${{ matrix.racket-variant }})" 6 | runs-on: ubuntu-latest 7 | strategy: 8 | matrix: 9 | racket-version: ["stable", "current"] 10 | racket-variant: ["BC", "CS"] 11 | steps: 12 | - uses: actions/checkout@v3 13 | - uses: Bogdanp/setup-racket@v1.10 14 | with: 15 | architecture: x64 16 | distribution: full 17 | variant: ${{ matrix.racket-variant }} 18 | version: ${{ matrix.racket-version }} 19 | - name: Installing pretty-expressive and its dependencies 20 | run: raco pkg install --no-docs --auto --name pretty-expressive 21 | - name: Compiling pretty-expressive and building its docs 22 | run: raco setup --check-pkg-deps --unused-pkg-deps pretty-expressive 23 | - name: Testing pretty-expressive 24 | run: raco test -p pretty-expressive 25 | -------------------------------------------------------------------------------- /LICENSE-MIT: -------------------------------------------------------------------------------- 1 | pretty-expressive 2 | 3 | MIT License 4 | 5 | Copyright (c) 2021 sorawee 6 | 7 | Permission is hereby granted, free of charge, to any person obtaining a copy 8 | of this software and associated documentation files (the "Software"), to deal 9 | in the Software without restriction, including without limitation the rights 10 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | copies of the Software, and to permit persons to whom the Software is 12 | furnished to do so, subject to the following conditions: 13 | 14 | The above copyright notice and this permission notice shall be included in all 15 | copies or substantial portions of the Software. 16 | 17 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | SOFTWARE. 24 | -------------------------------------------------------------------------------- /process.rkt: -------------------------------------------------------------------------------- 1 | ;; A facility to process documents 2 | 3 | #lang racket/base 4 | 5 | (#%declare #:unsafe) 6 | 7 | (provide doc-process) 8 | (require racket/match 9 | "doc.rkt") 10 | 11 | (define (doc-process f doc) 12 | (match doc 13 | [(struct* :text ()) doc] 14 | [(struct* :newline ()) doc] 15 | [(struct* :concat ([a a] [b b])) 16 | (define a* (f a)) 17 | (define b* (f b)) 18 | (cond 19 | [(and (eq? a* a) (eq? b* b)) doc] 20 | [else (concat a* b*)])] 21 | [(struct* :alternatives ([a a] [b b])) 22 | (define a* (f a)) 23 | (define b* (f b)) 24 | (cond 25 | [(and (eq? a* a) (eq? b* b)) doc] 26 | [else (alternatives a* b*)])] 27 | [(struct* :align ([d d])) 28 | (define d* (f d)) 29 | (cond 30 | [(eq? d* d) doc] 31 | [else (align d*)])] 32 | [(struct* :reset ([d d])) 33 | (define d* (f d)) 34 | (cond 35 | [(eq? d* d) doc] 36 | [else (reset d*)])] 37 | [(struct* :nest ([n n] [d d])) 38 | (define d* (f d)) 39 | (cond 40 | [(eq? d* d) doc] 41 | [else (nest n d*)])] 42 | [(struct* :full ([d d])) 43 | (define d* (f d)) 44 | (cond 45 | [(eq? d* d) doc] 46 | [else (full d*)])] 47 | [(struct* :cost ([n n] [d d])) 48 | (define d* (f d)) 49 | (cond 50 | [(eq? d* d) doc] 51 | [else (cost n d*)])] 52 | [(struct* :special ()) doc] 53 | [(struct* :fail ()) fail])) 54 | -------------------------------------------------------------------------------- /benchmarks/json.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (module test racket/base) 4 | 5 | (require pretty-expressive 6 | pretty-expressive/benchtool 7 | racket/match 8 | racket/file 9 | (only-in racket/list add-between) 10 | json) 11 | 12 | (setup "json" #:size 2) 13 | 14 | (define json-file 15 | (match (current-size) 16 | [1 "1k.json"] 17 | [2 "10k.json"] 18 | [_ (raise-user-error "invalid size")])) 19 | 20 | (define json 21 | (string->jsexpr (file->string (build-path (getenv "BENCHDATA") json-file)))) 22 | 23 | (define (h-append/bin a b) 24 | (<> (flatten a) b)) 25 | 26 | (define+provide-family h h-append/bin) 27 | 28 | (define (enclose-sep left right sep ds) 29 | (match ds 30 | ['() (<+> left right)] 31 | [(list d) (<+> left d right)] 32 | [(cons d ds) 33 | (<+> (alt (h-concat (cons left (add-between (cons d ds) sep))) 34 | (v-concat (cons (<+> left d) (map (λ (d) (<+> sep d)) ds)))) 35 | right)])) 36 | 37 | (define (pp v) 38 | (match v 39 | [(? list? xs) 40 | (enclose-sep lbrack rbrack comma (map pp xs))] 41 | [(? hash? (app hash->list xs)) 42 | (define entries (sort xs symbol (text (format "\"~a\": " (car entry))) 45 | (pp (cdr entry)))) 46 | entries))] 47 | [(? number? x) (text (format "~a" (exact->inexact x)))] 48 | [(? string? x) (text (format "\"~a\"" x))] 49 | [#f (text "false")] 50 | [#t (text "true")])) 51 | 52 | (define doc (pp json)) 53 | (do-bench doc) 54 | -------------------------------------------------------------------------------- /benchtool.rkt: -------------------------------------------------------------------------------- 1 | ;; A benchmarking tool 2 | 3 | #lang racket/base 4 | 5 | (provide setup 6 | do-bench 7 | current-size) 8 | 9 | (require racket/cmdline 10 | racket/match 11 | racket/string 12 | racket/format 13 | file/md5 14 | pretty-expressive 15 | pretty-expressive/doc 16 | (only-in racket/pretty [pretty-write r:pretty-write])) 17 | 18 | (define current-size (make-parameter #f)) 19 | (define current-out (make-parameter #f)) 20 | (define current-program (make-parameter #f)) 21 | (define current-view-cost? (make-parameter #f)) 22 | 23 | (define (setup program 24 | #:size size 25 | #:page-width [page-width 80] 26 | #:computation-width [computation-width 100]) 27 | (current-page-width page-width) 28 | (current-computation-width computation-width) 29 | (current-size size) 30 | (current-out #f) 31 | (current-program program) 32 | (current-view-cost? #f) 33 | (command-line 34 | #:once-each 35 | [("--page-width") 36 | page-width 37 | [(format "Page width limit (default: ~a)" page-width)] 38 | (current-page-width (string->number page-width))] 39 | [("--computation-width") 40 | computation-width 41 | [(format "Computation width limit (default: ~a)" computation-width)] 42 | (current-computation-width (string->number computation-width))] 43 | [("--size") 44 | size 45 | [(format "Size (default: ~a)" size)] 46 | (current-size (string->number size))] 47 | [("--view-cost") 48 | "Output cost (default: no)" 49 | (current-view-cost? #t)] 50 | [("--out") 51 | out 52 | "Path for the output; - means stdout (default: do not output)" 53 | (current-out out)] 54 | [("--memo-limit") 55 | memo-limit 56 | "Memoization limit (default: 7)" 57 | (set-memo-limit! (string->number memo-limit))])) 58 | 59 | ;; do-bench :: doc? -> void? 60 | (define (do-bench d) 61 | (match-define-values [(list out (info tainted? cost)) _ duration _] 62 | (time-apply (λ () (pretty-format/factory/info d (default-cost-factory))) '())) 63 | (match (current-out) 64 | [#f (void)] 65 | ["-" (displayln out)] 66 | [dest (with-output-to-file dest 67 | #:exists 'replace 68 | (λ () (displayln out)))]) 69 | 70 | (when (current-view-cost?) 71 | (fprintf (current-error-port) "(cost ~a)\n" cost)) 72 | 73 | (r:pretty-write 74 | `([target pretty-expressive-racket] 75 | [program ,(string->symbol (current-program))] 76 | [duration ,(exact->inexact (/ duration 1000))] 77 | [lines ,(length (string-split out "\n"))] 78 | [size ,(current-size)] 79 | [md5 ,(string->symbol (~a (md5 out)))] 80 | [page-width ,(current-page-width)] 81 | [computation-width ,(current-computation-width)] 82 | [tainted? ,(if tainted? 'true 'false)] 83 | [memo-limit ,(get-memo-limit)]))) 84 | -------------------------------------------------------------------------------- /examples.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require pretty-expressive 4 | (prefix-in r: racket/base)) 5 | 6 | (define d-traditional 7 | (<> (text "function append(first,second,third){") 8 | (nest 4 9 | (let ([f (text "first +")] 10 | [s (text "second +")] 11 | [t (text "third")]) 12 | (<> nl (text "return ") 13 | (group (nest 4 (<> f nl s nl t)))))) 14 | nl (text "}"))) 15 | 16 | (define d-arbitrary 17 | (<$> (text "function append(first,second,third){") 18 | (let ([f (text "first +")] 19 | [s (text "second +")] 20 | [t (text "third")] 21 | [sp (text " ")] 22 | [indentation (text " ")] 23 | [ret (text "return ")]) 24 | (<+> indentation 25 | (alt (<$> (<+> ret (text "(")) 26 | (<+> indentation (<$> f s t)) 27 | (text ")")) 28 | (<+> ret f sp s sp t)))) 29 | (text "}"))) 30 | 31 | 32 | (define d-pretty-expressive 33 | (<> (text "function append(first,second,third){") 34 | (nest 4 35 | (let ([f (text "first +")] 36 | [s (text "second +")] 37 | [t (text "third")]) 38 | (<> nl (text "return ") 39 | (alt (<> (text "(") 40 | (nest 4 (<> nl f nl s nl t)) 41 | nl 42 | (text ")")) 43 | (let ([sp (text " ")]) 44 | (<> f sp s sp t)))))) 45 | nl 46 | (text "}"))) 47 | 48 | (module+ test 49 | (require rackunit) 50 | 51 | (define horz-layout 52 | #< 25 | 26 | <$> 27 | <+> 28 | <+s> 29 | 30 | flatten 31 | group 32 | 33 | define+provide-family) 34 | 35 | (require racket/match 36 | "core.rkt" 37 | "process.rkt" 38 | (for-syntax racket/base 39 | racket/syntax 40 | syntax/parse/pre)) 41 | 42 | (define empty-doc (text "")) 43 | 44 | (define space (text " ")) 45 | (define lparen (text "(")) 46 | (define rparen (text ")")) 47 | (define lbrack (text "[")) 48 | (define rbrack (text "]")) 49 | (define lbrace (text "{")) 50 | (define rbrace (text "}")) 51 | (define comma (text ",")) 52 | 53 | (define nl (newline " ")) 54 | (define break (newline "")) 55 | (define hard-nl (newline #f)) 56 | 57 | (define (alt . xs) 58 | (for/foldr ([current fail]) ([x (in-list xs)]) 59 | (alternatives x current))) 60 | 61 | (define (fold-doc f xs) 62 | (match xs 63 | ['() empty-doc] 64 | [(cons x xs) (for/fold ([current x]) ([x (in-list xs)]) 65 | (f current x))])) 66 | 67 | (define-syntax (define+provide-family stx) 68 | (syntax-parse stx 69 | [(_ name:id bin-op:expr) 70 | #:with name-concat (format-id this-syntax "~a-concat" #'name) 71 | #:with name-append (format-id this-syntax "~a-append" #'name) 72 | #'(begin 73 | (provide name-concat 74 | name-append) 75 | (define (name-concat xs) 76 | (fold-doc bin-op xs)) 77 | (define name-append 78 | (case-lambda 79 | [() empty-doc] 80 | [(x) x] 81 | [(x y) (bin-op x y)] 82 | [xs (name-concat xs)])))])) 83 | 84 | (define+provide-family u concat) 85 | (define <> u-append) 86 | 87 | (define (us-append/bin x y) 88 | (<> x space y)) 89 | (define+provide-family us us-append/bin) 90 | (define us-append) 91 | 92 | (define (v-append/bin x y) 93 | (<> x hard-nl y)) 94 | (define+provide-family v v-append/bin) 95 | (define <$> v-append) 96 | 97 | (define (a-append/bin x y) 98 | (<> x (align y))) 99 | (define+provide-family a a-append/bin) 100 | (define <+> a-append) 101 | 102 | (define (as-append/bin x y) 103 | (<> x space (align y))) 104 | (define+provide-family as as-append/bin) 105 | (define <+s> as-append) 106 | 107 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;; 108 | 109 | (define flatten-map (make-weak-hasheq)) 110 | 111 | (define (flatten d) 112 | (let loop ([d d]) 113 | (hash-ref! flatten-map d 114 | (λ () 115 | (match d 116 | [(struct* :align ([d d])) (doc-process loop d)] 117 | [(struct* :reset ([d d])) (doc-process loop d)] 118 | [(struct* :nest ([d d])) (doc-process loop d)] 119 | [(struct* :newline ([s s])) 120 | (cond 121 | [s (text s)] 122 | [else fail])] 123 | [_ (doc-process loop d)]))))) 124 | 125 | (define (group d) 126 | (alt d (flatten d))) 127 | 128 | -------------------------------------------------------------------------------- /main.rkt: -------------------------------------------------------------------------------- 1 | ;; The main file for pretty-expressive 2 | 3 | #lang racket/base 4 | 5 | (require racket/match 6 | racket/math 7 | "core.rkt" 8 | "addons.rkt") 9 | 10 | (provide pretty-format/factory/info 11 | pretty-print/factory/info 12 | 13 | pretty-print/factory 14 | pretty-format/factory 15 | 16 | pretty-format 17 | pretty-print 18 | 19 | current-page-width 20 | current-computation-width 21 | current-offset 22 | current-special 23 | 24 | default-cost-factory 25 | 26 | (all-from-out "addons.rkt") 27 | (except-out (all-from-out "core.rkt") 28 | concat ; replaced by <> 29 | alternatives ; replaced by alt 30 | print-layout)) 31 | 32 | (define current-page-width (make-parameter 80)) 33 | (define current-computation-width (make-parameter #f)) 34 | (define current-offset (make-parameter 0)) 35 | (define current-special (make-parameter write-special)) 36 | 37 | (define (pretty-format/factory/info d F 38 | #:offset [offset (current-offset)] 39 | #:special [special (current-special)]) 40 | (define out (open-output-string)) 41 | (define info 42 | (pretty-print/factory/info d F 43 | #:offset offset 44 | #:out out 45 | #:special special)) 46 | (values (get-output-string out) info)) 47 | 48 | (define (pretty-print/factory/info d F 49 | #:offset [offset (current-offset)] 50 | #:out [out (current-output-port)] 51 | #:special [special (current-special)]) 52 | (print-layout #:doc d 53 | #:factory F 54 | #:offset offset 55 | #:out out 56 | #:special special)) 57 | 58 | (define (pretty-format/factory d F #:offset [offset (current-offset)]) 59 | (define out (open-output-string)) 60 | (define info (pretty-print/factory d F 61 | #:offset offset 62 | #:out out 63 | #:special special)) 64 | (get-output-string out)) 65 | 66 | (define (pretty-print/factory d F 67 | #:offset [offset (current-offset)] 68 | #:out [out (current-output-port)] 69 | #:special [special (current-special)]) 70 | (void (pretty-print/factory/info d F #:offset offset #:out out #:special special))) 71 | 72 | (define (default-cost-factory 73 | #:page-width [page-width (current-page-width)] 74 | #:computation-width [computation-width (current-computation-width)]) 75 | (cost-factory 76 | (match-lambda** 77 | [((list b1 h1) (list b2 h2)) 78 | (cond 79 | [(= b1 b2) (<= h1 h2)] 80 | [else (< b1 b2)])]) 81 | (match-lambda** 82 | [((list b1 h1) (list b2 h2)) 83 | (list (+ b1 b2) (+ h1 h2))]) 84 | (λ (pos len) 85 | (define stop (+ pos len)) 86 | (cond 87 | [(> stop page-width) 88 | (define maxwc (max page-width pos)) 89 | (define a (- maxwc page-width)) 90 | (define b (- stop maxwc)) 91 | (list (* b (+ (* 2 a) b)) 0)] 92 | [else (list 0 0)])) 93 | (λ (i) (list 0 1)) 94 | (or computation-width (exact-floor (* page-width 1.2))))) 95 | 96 | (define (pretty-format 97 | d 98 | #:page-width [page-width (current-page-width)] 99 | #:computation-width [computation-width (current-computation-width)] 100 | #:offset [offset (current-offset)] 101 | #:special [special (current-special)]) 102 | (define out (open-output-string)) 103 | (pretty-print d 104 | #:page-width page-width 105 | #:computation-width computation-width 106 | #:offset offset 107 | #:out out 108 | #:special special) 109 | (get-output-string out)) 110 | 111 | (define (pretty-print d 112 | #:page-width [page-width (current-page-width)] 113 | #:computation-width [computation-width (current-computation-width)] 114 | #:offset [offset (current-offset)] 115 | #:out [out (current-output-port)] 116 | #:special [special (current-special)]) 117 | (pretty-print/factory d 118 | (default-cost-factory 119 | #:page-width page-width 120 | #:computation-width computation-width) 121 | #:offset offset 122 | #:out out 123 | #:special special)) 124 | 125 | (module+ test 126 | (require racket/match 127 | racket/string 128 | (except-in rackunit fail)) 129 | 130 | (define (get-dim s) 131 | (define ss (string-split s "\n")) 132 | (cons (length ss) (apply max (map string-length ss)))) 133 | 134 | (define (pretty d) 135 | (match d 136 | [(list) (text "()")] 137 | [(list f args ...) 138 | (define fp (pretty f)) 139 | (define argsp (map pretty args)) 140 | (alt (<> lparen 141 | (align (v-concat (cons fp argsp))) 142 | rparen) 143 | (<> lparen 144 | (align fp) 145 | space 146 | (align (v-concat argsp)) 147 | rparen) 148 | (flatten 149 | (<> lparen 150 | (align (us-concat (cons fp argsp))) 151 | rparen)))] 152 | [_ (text d)])) 153 | 154 | (define (pretty* d) 155 | (match d 156 | [(list) (text "()")] 157 | [(list f args ...) 158 | (define fp (pretty* f)) 159 | (define argsp (map pretty* args)) 160 | (alt (<> lparen 161 | (align (v-concat (cons fp argsp))) 162 | rparen) 163 | (<> lparen 164 | (align fp) 165 | space 166 | (align (v-concat argsp)) 167 | rparen) 168 | (<> lparen 169 | (align (us-concat (cons fp argsp))) 170 | rparen))] 171 | [_ (text d)])) 172 | 173 | 174 | (check-equal? 175 | (pretty-format (pretty '("+" ("foo" "1" "2") ("bar" "2" "3") ("baz" "3" "4"))) 176 | #:page-width 31) 177 | #< (text "abc") hard-nl (text "def"))))) 254 | "abc\ndef") 255 | (check-equal? (pretty-format (nest 4 (<> (text "abc") hard-nl (text "def")))) 256 | "abc\n def") 257 | (check-equal? (pretty-format (alt (flatten (<> (text "abc") nl (text "def"))) 258 | (text "something"))) 259 | "abc def") 260 | (check-equal? (pretty-format (alt (flatten (<> (text "abc") hard-nl (text "def"))) 261 | (text "something"))) 262 | "something") 263 | 264 | (check-exn #px"the document fails to print" 265 | (λ () (pretty-format fail)))) 266 | -------------------------------------------------------------------------------- /doc.rkt: -------------------------------------------------------------------------------- 1 | ;; This module defines basic document combinator along with 2 | ;; the basic partial evaluation. 3 | 4 | #lang racket/base 5 | 6 | (#%declare #:unsafe) 7 | 8 | (provide doc? 9 | 10 | ;; pattern expanders 11 | :newline 12 | :fail 13 | :text 14 | :special 15 | :alternatives 16 | :concat 17 | :nest 18 | :align 19 | :reset 20 | :full 21 | :cost 22 | 23 | ;; constructor 24 | newline 25 | fail 26 | text 27 | special 28 | alternatives 29 | concat 30 | nest 31 | align 32 | reset 33 | full 34 | cost 35 | 36 | set-memo-limit! 37 | get-memo-limit) 38 | 39 | (module+ private 40 | (provide (struct-out doc))) 41 | 42 | (require racket/match 43 | (for-syntax racket/base 44 | syntax/parse/pre)) 45 | 46 | ;; We only memoize every memo-weight-limit node. 47 | ;; The value of memo-weight-limit must be a positive integer (initialized below) 48 | (define memo-weight-limit #f) 49 | 50 | ;; memo-weight-init is an integer in range [0, *memo-weight-limit* - 1] 51 | ;; that is used as the initial value given to the leaf nodes. 52 | ;; Since we don't want the leaf node to get memoized and want memoization to 53 | ;; occur farthest away from the leaf nodes, 54 | ;; we set the value to memo-weight-limit - 1 (initialized below). 55 | (define memo-weight-init #f) 56 | 57 | (define (set-memo-limit! memo-limit) 58 | (set! memo-weight-limit memo-limit) 59 | (set! memo-weight-init (sub1 memo-limit))) 60 | 61 | (define (get-memo-limit) 62 | memo-weight-limit) 63 | 64 | (set-memo-limit! 7) 65 | 66 | ;; - failing/X/Y means the doc will always fail to resolve. 67 | ;; X indicates fullness before resolving, and 68 | ;; Y indicates fullness after resolving. 69 | ;; The value usually starts as #f. The #f value could be mutated to #t. 70 | (struct doc (memo-weight ; memo weight in range of 0 to *memo-weight-limit* - 1 71 | table/no/no ; memo table for not full before and not full after 72 | table/yes/no ; memo table for full before and not full after 73 | table/no/yes ; memo table for not full before and full after 74 | table/yes/yes ; memo table for full before and full after 75 | failing/no/no ; fails when not full before and not full after? 76 | failing/yes/no ; fails when full before and not full after? 77 | failing/no/yes ; fails when not full before and full after? 78 | failing/yes/yes ; fails when full before and full after? 79 | nl-cnt) ; overapproximation of newline count 80 | #:mutable) 81 | 82 | (begin-for-syntax 83 | (define-splicing-syntax-class fail-flag 84 | (pattern {~seq #:fail value ...}) 85 | (pattern {~seq} #:with (value ...) #'(#f #f #f #f)))) 86 | 87 | ;; calc-weight :: doc -> natural? 88 | ;; Calculate the current memo weight in range 0 to memo-weight-limit - 1 89 | (define (calc-weight d) 90 | (define val (doc-memo-weight d)) 91 | (cond 92 | [(zero? val) memo-weight-init] 93 | [else (sub1 val)])) 94 | 95 | (define-syntax (get-weight stx) 96 | (syntax-parse stx 97 | [(_ d) #'(calc-weight d)] 98 | [(_ a b) #'(min (calc-weight a) (calc-weight b))])) 99 | 100 | ;; inst-internal-doc creates an internal doc with a constructor ctor. 101 | ;; It automatically decides whether memo tables should be allocated based on 102 | ;; the memo weight, and initializes the failure flags with #f if 103 | ;; #:fail is not given 104 | (define-syntax (inst-internal-doc stx) 105 | (syntax-parse stx 106 | [(_ ctor #:doc [doc ...] 107 | fail:fail-flag #:args arg ...) 108 | #'(let ([weight (get-weight doc ...)]) 109 | (cond 110 | [(zero? weight) 111 | (ctor weight 112 | (make-hasheq) (make-hasheq) (make-hasheq) (make-hasheq) 113 | fail.value ... 114 | arg ...)] 115 | [else 116 | (ctor weight 117 | #f #f #f #f 118 | fail.value ... 119 | arg ...)]))])) 120 | 121 | ;; inst-leaf-doc creates a leaf doc with a constructor ctor. 122 | ;; It automatically blanks the memo table fields, initializes the memo weight 123 | ;; and initializes the failure flags with #f if #:fail is not given 124 | (define-syntax (inst-leaf-doc stx) 125 | (syntax-parse stx 126 | [(_ ctor fail:fail-flag #:args arg ...) 127 | #'(ctor memo-weight-init 128 | #f #f #f #f 129 | fail.value ... 130 | arg ...)])) 131 | 132 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 133 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 134 | 135 | ;; A newline consists of: 136 | ;; - s :: (or/c #f string?) 137 | (struct :newline doc (s) #:transparent #:constructor-name make-newline) 138 | 139 | (define (newline s) 140 | (inst-leaf-doc make-newline #:fail #f #f #t #t #:args 1 s)) 141 | 142 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 143 | 144 | ;; A fail is a nullary constructor. 145 | (struct :fail doc () #:transparent #:constructor-name make-fail) 146 | 147 | (define fail (inst-leaf-doc make-fail #:fail #t #t #t #t #:args -1)) 148 | 149 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 150 | 151 | ;; A text consists of: 152 | ;; - s :: (or/c string? (treeof string?)) 153 | ;; - len :: natural? 154 | ;; where len is the length of s 155 | (struct :text doc (s len) #:transparent #:constructor-name make-text*) 156 | 157 | (define (make-text s len) 158 | (inst-leaf-doc make-text* #:fail #f #t #t (not (zero? len)) #:args 0 s len)) 159 | 160 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 161 | 162 | ;; special consists of: 163 | ;; - s :: any/c 164 | ;; - len :: natural? 165 | ;; where len is the length of s 166 | (struct :special doc (s len) #:transparent #:constructor-name make-special*) 167 | 168 | (define (special s len) 169 | (inst-leaf-doc make-special* #:fail #f #t #t (not (zero? len)) #:args 0 s len)) 170 | 171 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 172 | 173 | ;; An alternatives consists of: 174 | ;; - a :: doc? 175 | ;; - b :: doc? 176 | (struct :alternatives doc (a b) #:transparent #:constructor-name make-alternatives*) 177 | 178 | (define (make-alternatives a b) 179 | (inst-internal-doc make-alternatives* 180 | #:doc [a b] 181 | #:args 182 | (max (doc-nl-cnt a) (doc-nl-cnt b)) 183 | a b)) 184 | 185 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 186 | 187 | ;; A concat consists of: 188 | ;; - a :: doc? 189 | ;; - b :: doc? 190 | (struct :concat doc (a b) #:transparent #:constructor-name make-concat*) 191 | 192 | (define (make-concat a b) 193 | (inst-internal-doc make-concat* 194 | #:doc [a b] 195 | #:args 196 | (+ (doc-nl-cnt a) (doc-nl-cnt b)) 197 | a b)) 198 | 199 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 200 | 201 | ;; A nest consists of: 202 | ;; - n :: natural? 203 | ;; - d :: doc? 204 | (struct :nest doc (n d) #:transparent #:constructor-name make-nest*) 205 | 206 | (define (make-nest n d) 207 | (inst-internal-doc make-nest* 208 | #:doc [d] 209 | #:args 210 | (doc-nl-cnt d) 211 | n d)) 212 | 213 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 214 | 215 | ;; An align consists of: 216 | ;; - d :: doc? 217 | (struct :align doc (d) #:transparent #:constructor-name make-align*) 218 | 219 | (define (make-align d) 220 | (inst-internal-doc make-align* 221 | #:doc [d] 222 | #:args 223 | (doc-nl-cnt d) 224 | d)) 225 | 226 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 227 | 228 | ;; A reset consists of: 229 | ;; - d :: doc? 230 | (struct :reset doc (d) #:transparent #:constructor-name make-reset*) 231 | 232 | (define (make-reset d) 233 | (inst-internal-doc make-reset* 234 | #:doc [d] 235 | #:args 236 | (doc-nl-cnt d) 237 | d)) 238 | 239 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 240 | 241 | ;; A full consists of: 242 | ;; - d :: doc? 243 | (struct :full doc (d) #:transparent #:constructor-name make-full*) 244 | 245 | (define (make-full d) 246 | (inst-internal-doc make-full* 247 | #:doc [d] 248 | #:fail #t #t #f #f 249 | #:args 250 | (doc-nl-cnt d) 251 | d)) 252 | 253 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 254 | 255 | ;; A cost consists of: 256 | ;; - n :: tau 257 | ;; - d :: doc? 258 | (struct :cost doc (n d) #:transparent #:constructor-name make-cost*) 259 | 260 | (define (make-cost n d) 261 | (inst-internal-doc make-cost* 262 | #:doc [d] 263 | #:args 264 | (doc-nl-cnt d) 265 | n d)) 266 | 267 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 268 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 269 | 270 | ;; Set current-debug? to true for the debug mode (disable partial evaluation) 271 | (define-for-syntax current-debug? #f) 272 | 273 | ;; perform partial evaluation on the "constructor"s 274 | 275 | ;; For production code, use #:prod clause. For debugging code, use #:dbg clause. 276 | (define-syntax (cond-dbg stx) 277 | (syntax-parse stx 278 | [(_ [#:dbg e ...+] 279 | [#:prod e2 ...+]) 280 | #:with out (if current-debug? 281 | #'(let () e ...) 282 | #'(let () e2 ...)) 283 | #'out])) 284 | 285 | (cond-dbg 286 | [#:dbg 287 | (displayln "==========") 288 | (displayln "debug mode") 289 | (displayln "==========")] 290 | [#:prod (void)]) 291 | 292 | (define (text s) 293 | (make-text s (string-length s))) 294 | 295 | (define (concat a b) 296 | (cond-dbg 297 | [#:dbg (make-concat a b)] 298 | [#:prod (match* (a b) 299 | [((struct* :text ([len 0])) d) d] 300 | [(d (struct* :text ([len 0]))) d] 301 | [((? :full?) (? :text?)) fail] ; the text is non-empty 302 | [((? :fail?) _) fail] 303 | [(_ (? :fail?)) fail] 304 | [((struct* :text ([s sa] [len la])) 305 | (struct* :text ([s sb] [len lb]))) 306 | (make-text (cons sa sb) (+ la lb))] 307 | [(_ _) (make-concat a b)])])) 308 | 309 | (define (alternatives a b) 310 | (cond-dbg 311 | [#:dbg (make-alternatives a b)] 312 | [#:prod (match* (a b) 313 | [((? :fail?) _) b] 314 | [(_ (? :fail?)) a] 315 | [(_ _) 316 | (cond 317 | [(eq? a b) a] 318 | [else (make-alternatives a b)])])])) 319 | 320 | (define (full d) 321 | (cond-dbg 322 | [#:dbg (make-full d)] 323 | [#:prod (match d 324 | [(? :full?) d] 325 | [(? :fail?) fail] 326 | [_ (make-full d)])])) 327 | 328 | (define (cost n d) 329 | (cond-dbg 330 | [#:dbg (make-cost n d)] 331 | [#:prod (match d 332 | [(? :fail?) fail] 333 | [_ (make-cost n d)])])) 334 | 335 | (define (nest n d) 336 | (cond-dbg 337 | [#:dbg (make-nest n d)] 338 | [#:prod (match d 339 | [(? :fail?) d] 340 | [(? :align?) d] 341 | [(? :reset?) d] 342 | [(? :text?) d] 343 | [(struct* :nest ([n n2] [d d])) (make-nest (+ n n2) d)] 344 | [_ (make-nest n d)])])) 345 | 346 | (define (align d) 347 | (cond-dbg 348 | [#:dbg (make-align d)] 349 | [#:prod (match d 350 | [(? :fail?) d] 351 | [(? :align?) d] 352 | [(? :reset?) d] 353 | [(? :text?) d] 354 | [_ (make-align d)])])) 355 | 356 | (define (reset d) 357 | (cond-dbg 358 | [#:dbg (make-reset d)] 359 | [#:prod (match d 360 | [(? :fail?) d] 361 | [(? :align?) d] 362 | [(? :reset?) d] 363 | [(? :text?) d] 364 | [_ (make-reset d)])])) 365 | -------------------------------------------------------------------------------- /core.rkt: -------------------------------------------------------------------------------- 1 | ;; This module is the core of the pretty expressive printer algorithm 2 | 3 | #lang racket/base 4 | 5 | (#%declare #:unsafe) 6 | 7 | (provide print-layout 8 | (struct-out info) 9 | (struct-out cost-factory) 10 | (all-from-out "doc.rkt")) 11 | 12 | (require racket/match 13 | racket/list 14 | racket/string 15 | "doc.rkt" 16 | "process.rkt" 17 | "promise.rkt" 18 | (submod "doc.rkt" private)) 19 | 20 | (define current-print-special (make-parameter #f)) 21 | 22 | (struct info (tainted? cost) #:transparent) 23 | 24 | (struct cost-factory (cost<=? cost+ cost-text cost-nl limit)) 25 | 26 | ;; A measure consists of 27 | ;; - last length :: natural? 28 | ;; - cost :: tau 29 | ;; - tok :: output-port? -> void? 30 | (struct measure (last cost tok) #:transparent) 31 | 32 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 33 | 34 | ;; measure-set/c is either 35 | ;; - a promise that can be forced to a list of measures with length at most one 36 | ;; - a list of measures 37 | 38 | ;; extract-at-most-one :: measure-set/c -> (or/c null? (list/c measure?)) 39 | (define (extract-at-most-one ms) 40 | (match ms 41 | [(? promise?) (force ms)] 42 | ['() '()] 43 | [(list m _ ...) (list m)])) 44 | 45 | ;; NOTE: the token function takes a list of tokens and produces a list of tokens. 46 | ;; We could alternatively make it consume nothing and 47 | ;; use side-effect to write content to a port directly. 48 | ;; Unfortunately, due to https://github.com/racket/racket/issues/1388 49 | ;; the latter is currently inefficient, so we will build a list of tokens 50 | ;; explicitly for now. 51 | 52 | ;; print :: doc -> cost-factory? -> (values measure? boolean?) 53 | (define (print d F #:offset offset) 54 | (match-define (cost-factory cost<=? cost+ cost-text cost-nl limit) F) 55 | 56 | (define (dominates? m1 m2) 57 | (match-define (measure last1 cost1 _) m1) 58 | (match-define (measure last2 cost2 _) m2) 59 | (and (<= last1 last2) (cost<=? cost1 cost2))) 60 | 61 | ;; merge :: measure-set/c -> measure-set/c -> #:keep-both? boolean? 62 | ;; -> measure-set/c 63 | ;; Merge two measure sets together. #:prunnable? should be #f when there is a 64 | ;; chance that the two measure sets are both tainted, 65 | ;; and when they are forced, one fails while one does not. 66 | (define (merge ms1 ms2 #:prunable? [prunable? #f]) 67 | (match* (ms1 ms2) 68 | [(_ '()) ms1] 69 | [('() _) ms2] 70 | [((? promise?) (? promise?)) 71 | (let-values ([(ms1 ms2) 72 | (cond 73 | [(>= (promise-nl ms1) (promise-nl ms2)) (values ms1 ms2)] 74 | [else (values ms2 ms1)])]) 75 | (if prunable? 76 | ms1 77 | (delay #:nl (promise-nl ms1) 78 | (match (force ms1) 79 | ['() (force ms2)] 80 | [val val]))))] 81 | [(_ (? promise?)) ms1] 82 | [((? promise?) _) ms2] 83 | [(_ _) 84 | (let loop ([ms1 ms1] [ms2 ms2]) 85 | (match* (ms1 ms2) 86 | [(_ '()) ms1] 87 | [('() _) ms2] 88 | [((cons m1 ms1*) (cons m2 ms2*)) 89 | (cond 90 | [(dominates? m1 m2) (loop ms1 ms2*)] 91 | [(dominates? m2 m1) (loop ms1* ms2)] 92 | [(> (measure-last m1) (measure-last m2)) (cons m1 (loop ms1* ms2))] 93 | [else (cons m2 (loop ms1 ms2*))])]))])) 94 | 95 | (define (concat-measure m1 m2) 96 | (match-define (measure _ cost1 tok1) m1) 97 | (match-define (measure last2 cost2 tok2) m2) 98 | (measure last2 (cost+ cost1 cost2) 99 | (λ (out) 100 | (tok1 out) 101 | (tok2 out)))) 102 | 103 | (define limit+1 (add1 limit)) 104 | 105 | (define (memoize f) 106 | (λ (d c i beg-full? end-full?) 107 | (cond 108 | [((if beg-full? 109 | (if end-full? doc-failing/yes/yes doc-failing/yes/no) 110 | (if end-full? doc-failing/no/yes doc-failing/no/no)) d) 111 | '()] 112 | [(or (> c limit) (> i limit) (not (zero? (doc-memo-weight d)))) 113 | (f d c i beg-full? end-full?)] 114 | [else 115 | (define table ((if beg-full? 116 | (if end-full? doc-table/yes/yes doc-table/yes/no) 117 | (if end-full? doc-table/no/yes doc-table/no/no)) d)) 118 | (hash-ref! table 119 | (+ (* i limit+1) c) 120 | (λ () (f d c i beg-full? end-full?)))]))) 121 | 122 | (define resolve 123 | (memoize 124 | (λ (d c i beg-full? end-full?) 125 | (define (core) 126 | ;; NOTE 1: for :full and leaf nodes 127 | ;; (:text and :newline in particular), 128 | ;; we can assume that the result will not be failing, 129 | ;; because if it should be failing, it would have already failed earlier 130 | ;; from failing flags that are set from doc construction. 131 | (match d 132 | [(struct* :text ([s s] [len len])) 133 | ;; Per Note 1, no need to check for failure 134 | (list (measure (+ c len) 135 | (cost-text c len) 136 | (λ (out) 137 | (cond 138 | [(string? s) (display s out)] 139 | [else (for ([s (in-list (flatten s))]) 140 | (display s out))]))))] 141 | 142 | [(struct* :newline ()) 143 | ;; Per Note 1, no need to check for failure 144 | (list (measure i 145 | (cost-nl i) 146 | (λ (out) 147 | (display "\n" out) 148 | (display (make-string i #\space) out))))] 149 | 150 | [(struct* :concat ([a a] [b b])) 151 | ;; analyze-left-ms :: bool? -> measure-set/c 152 | (define (analyze-left-ms mid-full?) 153 | (match (resolve a c i beg-full? mid-full?) 154 | [(? promise? a-mt) 155 | (delay #:nl (doc-nl-cnt d) 156 | (match (force a-mt) 157 | ['() '()] 158 | [(list a-m) 159 | (match (extract-at-most-one 160 | (resolve b (measure-last a-m) i mid-full? end-full?)) 161 | ['() '()] 162 | [(list b-m) (list (concat-measure a-m b-m))])]))] 163 | [a-ms 164 | ;; NOTE 2: Here, resolving `a` succeeds. 165 | ;; We are now resolving `b` with many different `c` values, 166 | ;; and concat the measures and merge them together: 167 | ;; 168 | ;; (merge 169 | ;; (analyze-right-ms (resolve b c1 ...)) 170 | ;; (analyze-right-ms (resolve b c2 ...)) 171 | ;; (analyze-right-ms (resolve b c3 ...)) 172 | ;; ...) 173 | ;; 174 | ;; Due to Lemma 1, we can set #:prunable? to #t 175 | ;; because (resolve b * ...)s will all fail or all succeed, 176 | ;; so keeping only one tainted measure suffices. 177 | (for/foldr ([ms-rest '()]) ([a-m (in-list a-ms)]) 178 | ;; analyze-right-ms :: measure-set/c -> measure-set/c 179 | (define (analyze-right-ms b-ms) 180 | (match b-ms 181 | [(? promise?) 182 | (delay #:nl (doc-nl-cnt d) 183 | (match (force b-ms) 184 | ['() '()] 185 | [(list b-m) (list (concat-measure a-m b-m))]))] 186 | ['() '()] 187 | [(cons b-m b-ms) 188 | (for/fold ([current-best (concat-measure a-m b-m)] 189 | [msr '()] 190 | #:result (reverse (cons current-best msr))) 191 | ([b-m (in-list b-ms)]) 192 | (define current (concat-measure a-m b-m)) 193 | (cond 194 | [(cost<=? (measure-cost current) 195 | (measure-cost current-best)) 196 | (values current msr)] 197 | [else (values current (cons current-best msr))]))])) 198 | 199 | (merge (analyze-right-ms 200 | (resolve b (measure-last a-m) i mid-full? end-full?)) 201 | ms-rest 202 | #:prunable? #t))])) 203 | 204 | (merge (analyze-left-ms #f) (analyze-left-ms #t))] 205 | 206 | [(struct* :alternatives ([a a] [b b])) 207 | (merge (resolve a c i beg-full? end-full?) 208 | (resolve b c i beg-full? end-full?))] 209 | 210 | [(struct* :align ([d d])) (resolve d c c beg-full? end-full?)] 211 | 212 | [(struct* :reset ([d d])) (resolve d c 0 beg-full? end-full?)] 213 | 214 | [(struct* :nest ([n n] [d d])) (resolve d c (+ i n) beg-full? end-full?)] 215 | 216 | [(struct* :cost ([n n] [d d])) 217 | (match (resolve d c i beg-full? end-full?) 218 | [(? promise? mt) 219 | (delay #:nl (doc-nl-cnt d) 220 | (match (force mt) 221 | ['() '()] 222 | [(list m) 223 | (list (struct-copy measure m [cost (cost+ (measure-cost m) n)]))]))] 224 | [ms 225 | (for/list ([m (in-list ms)]) 226 | (struct-copy measure m [cost (cost+ (measure-cost m) n)]))])] 227 | 228 | [(struct* :full ([d d])) 229 | ;; Per Note 1, no need to check for failure 230 | (merge (resolve d c i beg-full? #f) (resolve d c i beg-full? #t))] 231 | 232 | [(struct* :special ([s s] [len len])) 233 | ;; Per Note 1, no need to check for failure 234 | (list (measure (+ c len) 235 | (cost-text c len) 236 | (λ (out) ((current-print-special) s out))))] 237 | 238 | ;; This is essentially a dead code. 239 | ;; Partial evaluation should have removed most fails away already, 240 | ;; except when the document is truly failing. 241 | ;; But in that case, the failure metadata should have been set, 242 | ;; and we should have already failed earlier from the memoization step. 243 | [(struct* :fail ()) '()])) 244 | 245 | (define column-pos 246 | (match d 247 | [(struct* :text ([len len])) (+ c len)] 248 | [_ c])) 249 | 250 | (cond 251 | [(or (> column-pos limit) (> i limit)) 252 | (delay #:nl (doc-nl-cnt d) 253 | (match (extract-at-most-one (core)) 254 | ['() 255 | ((if beg-full? 256 | (if end-full? 257 | set-doc-failing/yes/yes! 258 | set-doc-failing/yes/no!) 259 | (if end-full? 260 | set-doc-failing/no/yes! 261 | set-doc-failing/no/no!)) d #t) 262 | '()] 263 | [result result]))] 264 | [else (core)])))) 265 | 266 | (define result 267 | (merge (resolve d offset 0 #f #f) (resolve d offset 0 #f #t))) 268 | 269 | (define tainted? (promise? result)) 270 | 271 | ;; NOTE: unlike OCaml, the doc d can be printed with other cost factories 272 | ;; so we need to reset the memoization table. 273 | (define cleanup-map (make-weak-hasheq)) 274 | 275 | (define (cleanup d) 276 | (let loop ([d d]) 277 | (when (doc-table/no/no d) 278 | (hash-clear! (doc-table/no/no d)) 279 | (hash-clear! (doc-table/no/yes d)) 280 | (hash-clear! (doc-table/yes/no d)) 281 | (hash-clear! (doc-table/yes/yes d))) 282 | (hash-ref! cleanup-map d 283 | (λ () (doc-process loop d))))) 284 | 285 | (match (begin0 (extract-at-most-one result) 286 | (cleanup d)) 287 | ['() (raise (exn:fail:user "the document fails to print" 288 | (current-continuation-marks)))] 289 | [(list m) (values m tainted?)])) 290 | 291 | ;; print-layout :: #:doc doc? -> #:factory cost-factory? -> info? 292 | (define (print-layout #:doc d #:factory F #:offset offset #:out out 293 | #:special special) 294 | (parameterize ([current-print-special special]) 295 | (define-values (m tainted?) (print d F #:offset offset)) 296 | ((measure-tok m) out) 297 | (info tainted? (measure-cost m)))) 298 | 299 | ;; Lemma 1: the failure of resolving is independent of c and i. 300 | ;; I.e., given d, c1, c2, i1, i2, beg-full?, and end-full?: 301 | ;; (resolve d c1 i1 beg-full? end-full?) fails iff 302 | ;; (resolve d c2 i2 beg-full? end-full?) fails 303 | -------------------------------------------------------------------------------- /scribblings/pretty-expressive.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | @require[scribble/example 3 | scriblib/autobib 4 | @for-label[pretty-expressive 5 | pretty-expressive/process 6 | (except-in racket/base newline) 7 | racket/contract 8 | racket/math 9 | racket/match]] 10 | 11 | @(define evaluator (make-base-eval)) 12 | @(evaluator '(require racket/match racket/math pretty-expressive)) 13 | @(define-cite ~cite citet generate-bibliography) 14 | 15 | @title{pretty-expressive: a pretty expressive printer} 16 | @author[@author+email["Sorawee Porncharoenwase" "sorawee.pwase@gmail.com"]] 17 | 18 | @(define oopsla "Object-Oriented Programming, Systems, Languages and Applications") 19 | 20 | @(define Porncharoenwase23:pretty-expressive 21 | (make-bib #:author (authors "Sorawee Porncharoenwase" "Justin Pombrio" "Emina Torlak") 22 | #:title @elem{A pretty expressive printer} 23 | #:location (proceedings-location oopsla) 24 | #:date "2023")) 25 | 26 | @defmodule[pretty-expressive] 27 | 28 | This library implements a pretty expressive printer, following the algorithm presented in @citet[Porncharoenwase23:pretty-expressive]. 29 | The pretty printer is expressive, provably optimal, and practically efficient. 30 | It is similar to another library @racketmodname[pprint #:indirect], but that library employs a greedy algorithm. 31 | As a result, @racketmodname[pretty-expressive], when compared to PPrint, is more expressive and optimal, at the cost of being less efficient. 32 | 33 | This documentation and its structure are shamelessly copied/adapted from the PPrint library. 34 | 35 | @table-of-contents[] 36 | 37 | @section{Getting Started} 38 | 39 | Pretty printing is a process for producing human readable text from structured 40 | data. Users encode the structured data together with styling choices in an 41 | abstract document, which we'll call a @deftech{doc}. This @tech{doc} contains printing 42 | instructions: things like text, newlines, indentation, and styling. It can also 43 | contain @deftech{choices} (@racket[alt]) between two or more alternatives, resulting 44 | in many possible layouts for a document. The pretty printer's job is to pick 45 | the optimal layout from among all of the choices. E.g., the one that minimizes 46 | the number of lines which not exceeding the page width limit. 47 | 48 | Here's a simple example of pretty printing a document encoding a fragment of code. 49 | 50 | @examples[#:label #f #:eval evaluator 51 | (code:comment "Build a document") 52 | (define doc 53 | (<> (text "while (true) {") 54 | (nest 4 55 | (<> nl 56 | (text "f();") 57 | nl 58 | (<> (text "if (done())") 59 | (let ([exit-doc (text "exit();")]) 60 | (alt (<> space exit-doc) 61 | (nest 4 (<> nl exit-doc))))))) 62 | nl 63 | (text "}"))) 64 | ] 65 | 66 | It has a choice between two alternatives (@racket[alt]), so it has two possible 67 | layouts. If we print it with a page width limit of 80, we get one layout, and if we print it 68 | with a page width limit of 20 we get another: 69 | 70 | @examples[#:label #f #:eval evaluator 71 | (pretty-print doc #:page-width 80) 72 | (pretty-print doc #:page-width 20) 73 | ] 74 | 75 | @section{Documents} 76 | 77 | The library provides many functions (see @secref{Constructing_Documents}) for 78 | building and combining @tech{doc}s, which can then be printed 79 | (see @secref{Printing_Documents}). 80 | 81 | @defproc[(doc? [x any/c]) boolean?]{ 82 | Determines whether @racket[x] is a member of the @tech{doc} datatype. 83 | } 84 | 85 | @section{Best Practice for Document Construction} 86 | 87 | The arguments to @racket[alt] should typically have the same content, but with different formats. 88 | Although the @deftech{tree size} of a @tech{doc} containing @racket[alt] tends to blow up exponentially, 89 | the time complexity of our algorithm depends on the @deftech{DAG size} of the @tech{doc}. 90 | As a result, provided that sub-documents are sufficiently @emph{shared}, 91 | the @tech{DAG size} will be small, allowing efficient pretty printing. 92 | 93 | As an example, say we want to pretty print an S-expression with three possible styles for each ``list'': horizontal style, vertical style, and argument list style. That is, 94 | 95 | @racketblock[ 96 | (a b c d) 97 | ] 98 | 99 | could be rendered as itself or 100 | 101 | @racketblock[ 102 | (a 103 | b 104 | c 105 | d) 106 | ] 107 | 108 | or 109 | 110 | 111 | @racketblock[ 112 | (a b 113 | c 114 | d) 115 | ] 116 | 117 | We can construct a function to convert an S-expression to a @tech{doc}: 118 | 119 | @examples[#:eval evaluator #:label #f 120 | (define (pretty s) 121 | (match s 122 | [(list) (<+> lparen rparen)] 123 | [(list x) (<+> lparen (pretty x) rparen)] 124 | [(list x xs ...) 125 | (code:comment @#,elem{Calculate all subdocuments first to @emph{share} their references}) 126 | (define x-doc (pretty x)) 127 | (define xs-doc (map pretty xs)) 128 | (<+> lparen 129 | (alt (as-concat (cons x-doc xs-doc)) 130 | (v-concat (cons x-doc xs-doc)) 131 | (<+> x-doc space (v-concat xs-doc))) 132 | rparen)] 133 | [_ (text s)])) 134 | ] 135 | 136 | We can then pretty print it: 137 | 138 | @examples[#:eval evaluator #:label #f 139 | (define abcd-doc (pretty '("a" "b" "c" "d"))) 140 | (pretty-print abcd-doc #:page-width 10) 141 | (pretty-print abcd-doc #:page-width 6) 142 | (pretty-print abcd-doc #:page-width 4) 143 | ] 144 | 145 | The important point is that we @emph{reuse} @racket[x-doc] and @racket[xs-doc] across branches of @racket[alt]. 146 | Had we call @racket[(pretty x)] and @racket[(map pretty xs)] multiple times in branches of @racket[alt], 147 | both @tech{doc} construction and @racket[pretty-print] would be inefficient. 148 | 149 | @section{Library Documentation} 150 | 151 | @subsection{Printing Documents} 152 | 153 | @defproc[(pretty-print [d doc?] 154 | [#:page-width page-width natural? (current-page-width)] 155 | [#:computation-width computation-width (or/c #f natural?) (current-computation-width)] 156 | [#:offset offset natural? (current-offset)] 157 | [#:out out output-port? (current-output-port)] 158 | [#:special special (-> any/c output-port? void?) (current-special)]) 159 | void?]{ 160 | Pretty prints the @tech{doc} @racket[d] to the output port @racket[out] 161 | with a maximum page width of @racket[page-width] and offset @racket[offset]. 162 | The optimality of the output is only guanranteed when the output fits the @deftech{computation width} @racket[computation-width]. 163 | The worst case time complexity of pretty printing is proportional to the DAG size of @racket[d] and 164 | the 4th power of @racket[computation-width] (although in practice it is much lower than that). 165 | If @racket[computation-width] has the value @racket[#f], its effective value is @math{1.2 × @racket[page-width]}. 166 | 167 | The optimality objective for this pretty printing is given by @racket[default-cost-factory]. 168 | 169 | @examples[#:eval evaluator 170 | (define doc (<$> (<+> lparen 171 | (<$> (text "'Rhoam Bosphoramus Hyrule'") 172 | (text "'Daphnes Nohansen Hyrule'")) 173 | rparen) 174 | (<+> lparen 175 | (text "'2B'") 176 | space 177 | (text "'9S'") 178 | space 179 | (text "'A2'") 180 | rparen))) 181 | (pretty-print doc) 182 | ] 183 | 184 | The @racket[offset] argument is particularly helpful when there is already some preceding text printed to the screen, 185 | and we wish to pretty-printing after that. 186 | 187 | The @racket[special] argument is used for printing @tech[#:doc '(lib "scribblings/reference/reference.scrbl")]{special} results. 188 | 189 | @examples[#:eval evaluator 190 | (define prefix-s "values are: ") 191 | (begin 192 | (display prefix-s) 193 | (pretty-print (align doc) #:offset (string-length prefix-s))) 194 | (code:comment @#,elem{Without @racket[#:offset], the output will not be correctly aligned.}) 195 | (begin 196 | (display prefix-s) 197 | (pretty-print (align doc))) 198 | ] 199 | } 200 | 201 | @defproc[(pretty-format [d doc?] 202 | [#:page-width page-width natural? (current-page-width)] 203 | [#:computation-width computation-width (or/c #f natural?) (current-computation-width)] 204 | [#:offset offset natural? (current-offset)] 205 | [#:special special (-> any/c output-port? void?) (current-special)]) 206 | string?]{ 207 | Like @racket[pretty-print], but outputs a string instead of writing to the output port. 208 | } 209 | 210 | 211 | @defproc[(pretty-print/factory [d doc?] 212 | [F cost-factory?] 213 | [#:offset offset natural? (current-offset)] 214 | [#:out out output-port? (current-output-port)] 215 | [#:special special (-> any/c output-port? void?) (current-special)]) 216 | void?]{ 217 | Like @racket[pretty-print], but uses a cost factory @racket[F] instead. 218 | See @secref{Cost_factory} for more details. 219 | } 220 | 221 | @defproc[(pretty-format/factory [d doc?] 222 | [F cost-factory?] 223 | [#:offset offset natural? (current-offset)] 224 | [#:special special (-> any/c output-port? void?) (current-special)]) 225 | string?]{ 226 | Like @racket[pretty-print/factory], but outputs a string instead. 227 | } 228 | 229 | @defproc[(pretty-print/factory/info [d doc?] 230 | [F cost-factory?] 231 | [#:offset offset natural? (current-offset)] 232 | [#:out out output-port? (current-output-port)] 233 | [#:special special (-> any/c output-port? void?) (current-special)]) 234 | info?]{ 235 | Like @racket[pretty-print/factory], but outputs an @racket[info] structure 236 | which contains debugging information. 237 | } 238 | 239 | @defproc[(pretty-format/factory/info [d doc?] 240 | [F cost-factory?] 241 | [#:offset offset natural? (current-offset)] 242 | [#:special special (-> any/c output-port? void?) (current-special)]) 243 | (values string? info?)]{ 244 | Like @racket[pretty-print/factory/info], but additionally outputs a string. 245 | } 246 | 247 | @defstruct[info ([tainted? boolean?] 248 | [cost any/c])]{ 249 | A structure type that contains debugging information: 250 | taintedness (whether the computation width limit was exceeded) and cost of the output layout. 251 | 252 | @history[#:changed "1.1" @elem{Removed the @racket[out] component.}] 253 | } 254 | 255 | @subsection{Constructing Documents} 256 | 257 | @defproc[(text [s string?]) doc?]{ 258 | Constructs a @tech{doc} containing the fixed string @racket[s]. 259 | @racket[s] must @bold{not} contain a newline character. 260 | 261 | 262 | @examples[#:eval evaluator 263 | (pretty-print (text "Portal")) 264 | ] 265 | } 266 | 267 | @defproc[(special [s any/c] [len natural?]) doc?]{ 268 | Constructs a @tech{doc} containing the value @racket[s] 269 | with an estimated width of @racket[len] characters. 270 | The value @racket[s] will be printed with the @racket[special] 271 | argument of @racket[pretty-print] and friends. 272 | 273 | DrRacket, in particular, sets up its @racket[current-output-port] so that 274 | one can prints an image as a special value. 275 | } 276 | 277 | @defproc[(newline [s (or/c #f string?)]) doc?]{ 278 | A newline document, which renders to a newline character along with indentation spaces. 279 | Under @racket[flatten], it is reduced to @racket[s] if @racket[s] is not @racket[#f], 280 | and it fails to render if @racket[s] is @racket[#f]. 281 | } 282 | 283 | 284 | @defproc[(alt [x doc?] ...) doc?]{ 285 | Constructs a @tech{doc} which is rendered to one of @racket[x]s, 286 | whichever results in the prettiest layout for the whole document. 287 | If given no arguments, the resulting doc is @racket[fail]. 288 | 289 | See also @secref["Best_Practice_for_Document_Construction"]. 290 | } 291 | 292 | @deftogether[(@defproc[(v-append [x doc?] ...) doc?] 293 | @defproc[(<$> [x doc?] ...) doc?])]{ 294 | Concatenates @tech{doc} @racket[x]s vertically using @racket[hard-nl]. 295 | @racket[(<$> a b)] is equivalent to @racket[(<> a hard-nl b)]. 296 | 297 | @examples[#:eval evaluator 298 | (pretty-print 299 | (<$> (text "Tears of the Kingdom") 300 | (text "Breath of the Wild") 301 | (text "Ocarina of Time"))) 302 | ] 303 | } 304 | 305 | @defproc[(v-concat [xs (listof doc?)]) doc?]{ 306 | Concatenates @tech{doc}s in @racket[xs] vertically using @racket[hard-nl]. 307 | } 308 | 309 | @deftogether[(@defproc[(u-append [x doc?] ...) doc?] 310 | @defproc[(<> [x doc?] ...) doc?])]{ 311 | Concatenates @tech{doc} @racket[x]s together without alignment. 312 | 313 | @examples[#:eval evaluator 314 | (define left-doc 315 | (<$> (text "Splatoon") 316 | (text "Nier"))) 317 | (define right-doc 318 | (<$> (text "Automata") 319 | (text "FEZ"))) 320 | (pretty-print (<> left-doc right-doc)) 321 | ] 322 | } 323 | 324 | @deftogether[(@defproc[(a-append [x doc?] ...) doc?] 325 | @defproc[(<+> [x doc?] ...) doc?])]{ 326 | Concatenates @tech{doc} @racket[x]s together with alignment. 327 | 328 | @examples[#:eval evaluator 329 | (pretty-print (<+> left-doc right-doc)) 330 | ] 331 | } 332 | 333 | @deftogether[(@defproc[(us-append [x doc?] ...) doc?] 334 | @defproc[( [x doc?] ...) doc?])]{ 335 | Concatenates @tech{doc} @racket[x]s together without alignment 336 | with successive pairs separated by @racket[space]. 337 | 338 | @examples[#:eval evaluator 339 | (pretty-print ( left-doc right-doc)) 340 | ] 341 | } 342 | 343 | @deftogether[(@defproc[(as-append [x doc?] ...) doc?] 344 | @defproc[(<+s> [x doc?] ...) doc?])]{ 345 | Concatenates @tech{doc} @racket[x]s together with alignment 346 | with successive pairs separated by @racket[space]. 347 | 348 | @examples[#:eval evaluator 349 | (pretty-print (<+s> left-doc right-doc)) 350 | ] 351 | } 352 | 353 | @defproc[(u-concat [xs (listof doc?)]) doc?]{ 354 | Concatenates @tech{doc}s in @racket[xs] together using @racket[<>]. 355 | } 356 | 357 | @defproc[(a-concat [xs (listof doc?)]) doc?]{ 358 | Concatenates @tech{doc}s in @racket[xs] together using @racket[<+>]. 359 | } 360 | 361 | @defproc[(us-concat [xs (listof doc?)]) doc?]{ 362 | Concatenates @tech{doc}s in @racket[xs] together using @racket[]. 363 | } 364 | 365 | @defproc[(as-concat [xs (listof doc?)]) doc?]{ 366 | Concatenates @tech{doc}s in @racket[xs] together using @racket[<+s>]. 367 | } 368 | 369 | @defproc[(align [d doc?]) doc?]{ 370 | Aligns the @tech{doc} @racket[d]. 371 | @racket[(<+> a b)] is equivalent to @racket[(<> a (align b))]. 372 | } 373 | 374 | @defproc[(nest [n natural?] [d doc?]) doc?]{ 375 | Increments the indentation level by @racket[n] when rendering the @tech{doc} @racket[d]. 376 | 377 | 378 | @examples[#:eval evaluator 379 | (pretty-print (<> (text "when 1 = 2:") 380 | (nest 4 (<> nl (text "print 'oh no!'"))))) 381 | ] 382 | 383 | The increment does not affect content on the current line. 384 | 385 | @examples[#:eval evaluator 386 | (code:comment @#,elem{"when 1 = 2:" is not further indented}) 387 | (pretty-print (nest 4 (<> (text "when 1 = 2:") 388 | nl 389 | (text "print 'oh no!'")))) 390 | ] 391 | } 392 | 393 | @defproc[(reset [d doc?]) doc?]{ 394 | Resets the indentation level to 0 when rendering the @tech{doc} @racket[d]. 395 | This is especially useful for formatting multi-line strings and multi-line comments. 396 | 397 | @examples[#:eval evaluator 398 | (define subd (reset (<> (text "#< (text "when 1 = 2:") 403 | (nest 4 (<> nl (text "print ") subd)))) 404 | ] 405 | } 406 | 407 | 408 | @defthing[fail doc?]{ 409 | Constructs a @tech{doc} that fails to render. 410 | This doc interacts with @racket[alt]: failing branches are pruned away. 411 | 412 | @examples[#:eval evaluator 413 | (eval:error (pretty-print (<> (text "a") fail))) 414 | (pretty-print (alt (<> (text "a") fail) (text "b"))) 415 | ] 416 | } 417 | 418 | 419 | @defproc[(full [x doc?]) doc?]{ 420 | Constrains that @tech{doc} @racket[x] cannot be followed by any text in the same line. 421 | Otherwise, it @racket[fail]s to render. 422 | @racket[full] is particularly suitable for imposing constraints for inline comments, 423 | which should not be followed by any other code (as the code would be commented out). 424 | 425 | @examples[#:eval evaluator 426 | (define the-comment (full (text "# this is a comment"))) 427 | (define the-code (text "print(1)")) 428 | (pretty-print (<> the-comment nl the-code)) 429 | (eval:error (pretty-print (<> the-comment the-code))) 430 | (pretty-print (alt (<> the-comment the-code) 431 | (<> the-comment nl the-code))) 432 | 433 | (pretty-print (<> the-comment nl (full (text "# this is another comment")))) 434 | (pretty-print (<> the-comment (text ""))) 435 | ] 436 | } 437 | 438 | @defproc[(flatten [x doc?]) doc?]{ 439 | Flattens @tech{doc} @racket[x] so that all newlines and indentation spaces 440 | due to @racket[newline] are replaced with its content. 441 | 442 | @examples[#:eval evaluator 443 | (define doc (<> (text "a") nl (text "b") nl (text "c"))) 444 | (pretty-print doc) 445 | (pretty-print (flatten doc)) 446 | (define doc2 (<> (text "a") break (text "b") break (text "c"))) 447 | (pretty-print doc2) 448 | (pretty-print (flatten doc2)) 449 | (define doc3 (<> (text "a") hard-nl (text "b") hard-nl (text "c"))) 450 | (pretty-print doc3) 451 | (eval:error (pretty-print (flatten doc3))) 452 | (define doc4 (<> (text "a") (newline ", ") (text "b") (newline ", ") (text "c"))) 453 | (pretty-print doc4) 454 | (pretty-print (flatten doc4)) 455 | ] 456 | } 457 | 458 | @defproc[(group [x doc?]) doc?]{ 459 | Creates a choice between @racket[(flatten x)] and @racket[x]. 460 | } 461 | 462 | @defproc[(cost [n any/c] [x doc?]) doc?]{ 463 | Adds a cost @racket[n] to @racket[x]. 464 | See @secref{Cost_factory} for more details. 465 | } 466 | 467 | @subsection{Constants} 468 | 469 | @defthing[nl doc?]{ 470 | Same as @racket[(newline " ")] 471 | } 472 | 473 | @defthing[break doc?]{ 474 | Same as @racket[(newline "")] 475 | } 476 | 477 | @defthing[hard-nl doc?]{ 478 | Same as @racket[(newline #f)] 479 | } 480 | 481 | @defthing[empty-doc doc?]{ 482 | Same as @racket[(text "")] 483 | } 484 | 485 | @defthing[lparen doc?]{ 486 | Same as @racket[(text "(")] 487 | } 488 | 489 | @defthing[rparen doc?]{ 490 | Same as @racket[(text ")")] 491 | } 492 | 493 | @defthing[lbrack doc?]{ 494 | Same as @racket[(text "[")] 495 | } 496 | 497 | @defthing[rbrack doc?]{ 498 | Same as @racket[(text "]")] 499 | } 500 | 501 | @defthing[lbrace doc?]{ 502 | Same as @racket[(text "{")] 503 | } 504 | 505 | @defthing[rbrace doc?]{ 506 | Same as @racket[(text "}")] 507 | } 508 | 509 | @defthing[space doc?]{ 510 | Same as @racket[(text " ")] 511 | } 512 | 513 | @defthing[comma doc?]{ 514 | Same as @racket[(text ",")] 515 | } 516 | 517 | @subsection{Parameters} 518 | 519 | @defparam[current-page-width page-width natural? #:value 80]{ 520 | A parameter that determines the page width. 521 | } 522 | 523 | @defparam[current-computation-width computation-width (or/c #f natural?) #:value #f]{ 524 | A parameter that determines the @tech{computation width}. 525 | } 526 | 527 | @defparam[current-offset offset natural? #:value 0]{ 528 | A parameter that determines the column offset for subsequent lines. 529 | } 530 | 531 | @defparam[current-special special (-> any/c output-port? void?) #:value write-special]{ 532 | A parameter that determines the printing function for @tech[#:doc '(lib "scribblings/reference/reference.scrbl")]{special} results. 533 | } 534 | 535 | @subsection{Match Expanders} 536 | 537 | Internally, a @tech{doc} is either a @racket[:text], @racket[:newline], @racket[:concat], @racket[:alternatives], @racket[:align], @racket[:reset], @racket[:nest], @racket[:full], @racket[:fail], or @racket[:cost]. 538 | We provide these @tech[#:doc '(lib "scribblings/reference/reference.scrbl")]{match expander}s to allow @tech{doc} processing (see @secref{Processing_Documents}). 539 | The match expanders are illegal outside of the pattern position of the @racket[match] form. 540 | Keep in mind that this list is unstable and could change across versions of the library. 541 | 542 | 543 | @defform[(:text s len)]{ 544 | A match expander that recognizes text @racket[s] of type @racket[(treeof string?)] whose length is @racket[len]. 545 | } 546 | 547 | @defform[(:special s len)]{ 548 | A match expander that recognizes a special result @racket[s] whose length is @racket[len]. 549 | } 550 | 551 | @defform[(:newline s)]{ 552 | A match expander that recognizes a newline that flattens to @racket[s]. When @racket[s] is @racket[#f], it fails to flatten. 553 | } 554 | 555 | @defform[(:concat da db)]{ 556 | A match expander that recognizes an unaligned concatenation of @tech{doc}s @racket[da] and @racket[db]. 557 | } 558 | 559 | @defform[(:alternatives da db)]{ 560 | A match expander that recognizes a choice: @tech{doc}s @racket[da] and @racket[db]. 561 | } 562 | 563 | @defform[(:align d)]{ 564 | A match expander that recognizes an alignment of @tech{doc} @racket[d]. 565 | } 566 | 567 | @defform[(:reset d)]{ 568 | A match expander that recognizes an indentation level reset of @tech{doc} @racket[d]. 569 | } 570 | 571 | @defform[(:nest n d)]{ 572 | A match expander that recognizes an increment of indentation level of @racket[n] on @tech{doc} @racket[d]. 573 | } 574 | 575 | @defform[(:full d)]{ 576 | A match expander that recognizes a constraint that the @tech{doc} @racket[d] must not be followed by any any non-empty text in the line. 577 | } 578 | 579 | @defform[(:fail)]{ 580 | A match expander that recognizes a failing @tech{doc}. 581 | } 582 | 583 | @defform[(:cost c d)]{ 584 | A match expander that recognizes an increment of cost by @racket[c] on the @tech{doc} @racket[d]. 585 | } 586 | 587 | @section{Cost factory} 588 | 589 | Pretty printers choose an optimal layout from a document 590 | by minimizing an @deftech{optimality objective}. 591 | Unlike other pretty printers, which have built-in optimality objectives, 592 | @racketmodname[pretty-expressive] allows you to customize an optimality objective via 593 | the @deftech{cost factory} interface. 594 | 595 | @defstruct[cost-factory ([cost<=? (-> any/c any/c any/c)] 596 | [cost+ (-> any/c any/c any/c)] 597 | [cost-text (-> natural? natural? any/c)] 598 | [cost-nl (-> natural? any/c)] 599 | [limit natural?])]{ 600 | A structure type for cost factories. 601 | 602 | @itemlist[ 603 | @item{@racket[(cost<=? a b)] determines whether the cost @racket[a] is less than or equal to the cost @racket[b].} 604 | @item{@racket[(cost+ a b)] combines costs @racket[a] and @racket[b] together to produce a new cost.} 605 | @item{@racket[(cost-text c len)] gives the cost of placing text of length @racket[len] at column position @racket[c].} 606 | @item{@racket[(cost-nl i)] gives the cost of a newline followed by an indentation of @racket[i] spaces.} 607 | @item{@racket[limit] is the computation width limit.} 608 | ] 609 | 610 | These functions should at minimum satisfy the following properties: 611 | 612 | @itemlist[ 613 | @item{@racket[cost<=?] should be a total order: reflexive, antisymmetric, and total.} 614 | @item{For all costs @racket[a], @racket[b], @racket[c], and @racket[d], such that @racket[(cost<=? a b)] and @racket[(cost<=? c d)], 615 | @racket[cost+] should satisfy @racket[(cost<=? (cost+ a c) (cost+ b d))].} 616 | @item{For all @racket[c], @racket[c*], and @racket[len], such that @racket[(<= c c*)], 617 | @racket[cost-text] should satisfy @racket[(cost<=? (cost-text c len) (cost-text c* len))].} 618 | @item{For all @racket[i] and @racket[i*] such that @racket[(<= i i*)], 619 | @racket[cost-nl] should satisfy @racket[(cost<=? (cost-nl i) (cost-nl i*))].} 620 | @item{@racket[cost+] should be commutative and associative.} 621 | @item{@racket[(cost+ (cost-text c len) (cost-text (+ c len) len*))] should be equal to @racket[(cost-text c (+ len len*))].} 622 | ] 623 | } 624 | 625 | @defproc[(default-cost-factory [#:page-width page-width natural? (current-page-width)] 626 | [#:computation-width computation-width (or/c #f natural?) (current-computation-width)]) 627 | cost-factory?]{ 628 | The default cost factory that is employed for @racket[pretty-print]. 629 | A cost satisfies the contract @racket[(list/c natural? natural?)]. 630 | For a cost @racket[(list b h)], @racket[b] is the @deftech{badness}, 631 | which is the sum of squared overflows over the page width limit @racket[page-width], 632 | and @racket[h] is the number of newlines. 633 | The optimality objective is to minimize the badness, and then minimize the number of newlines. 634 | If @racket[computation-width] has the @racket[#f] value, its effective value is @math{1.2 × @racket[page-width]}. 635 | 636 | Internally, this cost factory is implemented as: 637 | 638 | @racketblock[ 639 | (define (default-cost-factory 640 | #:page-width [page-width (current-page-width)] 641 | #:computation-width [computation-width (current-computation-width)]) 642 | (cost-factory 643 | (match-lambda** 644 | [((list b1 h1) (list b2 h2)) 645 | (cond 646 | [(= b1 b2) (<= h1 h2)] 647 | [else (< b1 b2)])]) 648 | (match-lambda** 649 | [((list b1 h1) (list b2 h2)) 650 | (list (+ b1 b2) (+ h1 h2))]) 651 | (λ (pos len) 652 | (define stop (+ pos len)) 653 | (cond 654 | [(> stop page-width) 655 | (define maxwc (max page-width pos)) 656 | (define a (- maxwc page-width)) 657 | (define b (- stop maxwc)) 658 | (list (* b (+ (* 2 a) b)) 0)] 659 | [else (list 0 0)])) 660 | (λ (i) (list 0 1)) 661 | (or computation-width (exact-floor (* page-width 1.2))))) 662 | ] 663 | } 664 | 665 | @subsection{More cost factory examples} 666 | 667 | Consider the example in @secref{Best_Practice_for_Document_Construction}. 668 | Each list can be rendered with three possible styles: horizontal style, vertical style, and argument list style. 669 | 670 | @examples[#:eval evaluator #:label #f 671 | (pretty-print (pretty '("abc" "def" ("ghi" "jkl" "mno"))) #:page-width 15) 672 | ] 673 | 674 | Indeed, this is an optimal layout according to @racket[default-cost-factory], 675 | because it does not have any @tech{badness}, and two newlines are minimal. 676 | 677 | However, let's say that we consider the vertical style to be not pretty. 678 | The vertical style should still be a possibility however, since it can help us avoid going over the page width limit 679 | and minimize the number of newlines in many situations. 680 | We simply would prefer other styles when all else is equal. 681 | In this case, we would prefer the output: 682 | 683 | @racketblock[ 684 | (abc def 685 | (ghi jkl 686 | mno)) 687 | ] 688 | 689 | To address this issue, we construct a new cost factory. 690 | 691 | @examples[#:label #f #:eval evaluator 692 | (define (my-cost-factory 693 | #:page-width [page-width (current-page-width)] 694 | #:computation-width [computation-width (current-computation-width)]) 695 | (cost-factory 696 | (match-lambda** 697 | [((list b1 h1 sc1) (list b2 h2 sc2)) 698 | (cond 699 | [(= b1 b2) 700 | (cond 701 | [(= h1 h2) (<= sc1 sc2)] 702 | [else (< h1 h2)])] 703 | [else (< b1 b2)])]) 704 | (match-lambda** 705 | [((list b1 h1 sc1) (list b2 h2 sc2)) 706 | (list (+ b1 b2) (+ h1 h2) (+ sc1 sc2))]) 707 | (λ (pos len) 708 | (define stop (+ pos len)) 709 | (cond 710 | [(> stop page-width) 711 | (define maxwc (max page-width pos)) 712 | (define a (- maxwc page-width)) 713 | (define b (- stop maxwc)) 714 | (list (* b (+ (* 2 a) b)) 0 0)] 715 | [else (list 0 0 0)])) 716 | (λ (i) (list 0 1 0)) 717 | (or computation-width (exact-floor (* page-width 1.2))))) 718 | ] 719 | 720 | The cost of @racket[my-cost-factory] is similar to that of @racket[default-cost-factory], 721 | but it has an extra component: @deftech{style cost}. 722 | When all else is equal, we prefer a cost with less style cost. 723 | 724 | We can now construct a function to convert an S-expression to a @tech{doc}. 725 | It penalizes the vertical style by adding a @tech{style cost} to that choice. 726 | 727 | @examples[#:eval evaluator #:label #f 728 | (define (new-pretty s) 729 | (match s 730 | [(list) (<+> lparen rparen)] 731 | [(list x) (<+> lparen (new-pretty x) rparen)] 732 | [(list x xs ...) 733 | (define x-doc (new-pretty x)) 734 | (define xs-doc (map new-pretty xs)) 735 | (<+> lparen 736 | (alt (as-concat (cons x-doc xs-doc)) 737 | (code:comment "Add a style cost to penalize the vertical style") 738 | (cost (list 0 0 1) (v-concat (cons x-doc xs-doc))) 739 | (<+> x-doc space (v-concat xs-doc))) 740 | rparen)] 741 | [_ (text s)])) 742 | ] 743 | 744 | Now we can pretty print as we desired: 745 | 746 | @examples[#:eval evaluator #:label #f 747 | (pretty-print/factory (new-pretty '("abc" "def" ("ghi" "jkl" "mno"))) 748 | (my-cost-factory #:page-width 15)) 749 | 750 | (code:comment "Three styles are still possible") 751 | (define new-abcd-doc (new-pretty '("a" "b" "c" "d"))) 752 | (pretty-print/factory new-abcd-doc (my-cost-factory #:page-width 10)) 753 | (pretty-print/factory new-abcd-doc (my-cost-factory #:page-width 6)) 754 | (pretty-print/factory new-abcd-doc (my-cost-factory #:page-width 4)) 755 | ] 756 | 757 | @section{Processing Documents} 758 | 759 | @defmodule[pretty-expressive/process] 760 | 761 | @defproc[(doc-process [f procedure?] [d doc?]) doc?]{ 762 | Calls @racket[f] on the immediate subdocuments of @racket[d] and reassembles the results back. 763 | The function attempts to avoid creating new objects as best as it can. Note that @racket[f] should be memoized. 764 | 765 | Prefer using this function over manual @racket[match]ing against all match expanders. 766 | The list of match expanders could change across versions of this library, 767 | making programs that directly matches against all expanders brittle to changes. 768 | Using this function on the other hand makes doc processing stable across versions. 769 | } 770 | 771 | @(generate-bibliography) 772 | --------------------------------------------------------------------------------