suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

cs: fix some printer problems exposed by "print.rktl" tests

Browse Source
This commit is contained in:
Matthew Flatt 2018-10-11 05:55:32 -06:00
parent d25058c94a
commit 26f785e64e
5 changed files with 137 additions and 56 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
pkgs/racket-test-core/tests/racket/print.rktl
View File

@ -139,6 +139,8 @@
(ptest "'(#<procedure:add1>)" (list add1))
(ptest "'#(#<procedure:add1>)" (vector add1))
(ptest "(arity-at-least 1)" (arity-at-least 1))
(ptest "#0='(#0#)" (read (open-input-string "#0=(#0#)")))
(ptest "#0='(#0# #0#)" (read (open-input-string "#0=(#0# #0#)")))
(ptest "#0='(#0# . #0#)" (read (open-input-string "#0=(#0# . #0#)")))
@ -261,12 +263,12 @@
;; path value in compiled code => path appears in .zo format:
(let ([o (open-output-string)])
(write (compile p) o)
(test #t regexp-match? (regexp-quote (path->bytes (current-directory))) (get-output-string o)))
(test #t 'path-in-code?1 (regexp-match? (regexp-quote (path->bytes (current-directory))) (get-output-string o))))
;; `current-write-relative-directory' set => path not in .zo format:
(let ([o (open-output-string)])
(parameterize ([current-write-relative-directory (current-directory)])
(write (compile p) o)
(test #f regexp-match? (regexp-quote (path->bytes (current-directory))) (get-output-string o))))
(test #f 'path-in-code?2 (regexp-match? (regexp-quote (path->bytes (current-directory))) (get-output-string o)))))
;; try all possible supers that have at least two path elements:
(let loop ([super (current-directory)])
(let ([super (let-values ([(base name dir?) (split-path super)])
@ -279,12 +281,12 @@
(let ([o (open-output-string)])
(parameterize ([current-write-relative-directory (current-directory)])
(write (compile (build-path super "other")) o)
(test #t regexp-match? (regexp-quote (path->bytes super)) (get-output-string o))))
(test #t 'path-in-code?3 (regexp-match? (regexp-quote (path->bytes super)) (get-output-string o)))))
(let ([o (open-output-string)])
(parameterize ([current-write-relative-directory (cons (current-directory)
super)])
(write (compile (build-path super "other")) o)
(test #f regexp-match? (regexp-quote (path->bytes super)) (get-output-string o))))
(test #f 'path-in-code?4 (regexp-match? (regexp-quote (path->bytes super)) (get-output-string o)))))
(loop super)))))
;; ----------------------------------------

17
racket/src/io/demo.rkt
View File

@ -279,9 +279,9 @@
void)))
(port-count-lines! specialist)
(test '(special #f #f #f #f) (read-byte-or-special specialist))
(test '(special #f 1 0 1) (read-byte-or-special specialist))
(test '#&(special src 1 1 2) (read-byte-or-special specialist box 'src))
(test '(special #f #f #f #f) (peek-byte-or-special specialist))
(test '(special #f 1 2 3) (peek-byte-or-special specialist))
(test '#&(special src 1 2 3) (peek-byte-or-special specialist 0 #f box 'src))
(test 'special (peek-byte-or-special specialist 0 #f 'special 'src))
(test 'special (peek-char-or-special specialist 0 'special 'src))
@ -603,13 +603,24 @@
(print-test b "#0='#&#0#"))
(let ([b (vector #f #f)])
(struct p (x y) #:transparent)
(vector-set! b 0 b)
(vector-set! b 1 b)
(print-test b "#0='#(#0# #0#)")
(print-test '(1) "'(1)")
(print-test (cons 1 (cons 2 3)) "'(1 2 . 3)")
(print-test (cons 1 (cons 2 (mcons 3 4))) "(cons 1 (cons 2 (mcons 3 4)))")
(print-test (cons 1 (cons (mcons 3 4) null)) "(list 1 (mcons 3 4))"))
(print-test (cons 1 (cons (mcons 3 4) null)) "(list 1 (mcons 3 4))")
(print-test '('a) "'('a)")
(print-test '(4 . 'a) "'(4 . 'a)")
(print-test '(4 unquote a) "'(4 . ,a)")
(print-test '(4 unquote @a) "'(4 . , @a)")
(print-test '#(4 unquote a) "'#(4 unquote a)")
(print-test '((quote a b)) "'((quote a b))")
(print-test (p 1 2) "(p 1 2)")
(print-test (box (p 1 2)) "(box (p 1 2))")
(print-test (hasheq 1 (p 1 2) 2 'other) "(hasheq 1 (p 1 2) 2 'other)")
)
(let ([b (make-hash)])
(hash-set! b 'self b)

3
racket/src/io/print/graph.rkt
View File

@ -58,8 +58,7 @@
[(and (struct? v)
(config-get config print-struct))
(and (not print-graph?)
(or (not (eq? mode PRINT-MODE/UNQUOTED))
(prefab-struct-key v)) ; can quote a prefab in `print` mode
(prefab-struct-key v) ; can quote a prefab in `print` mode
(quick-no-graph? (struct->vector v) (sub1 fuel)))]
[else fuel])))

96
racket/src/io/print/list.rkt
View File

@ -1,7 +1,10 @@
#lang racket/base
(require "write-with-max.rkt"
"mode.rkt"
"graph.rkt")
"graph.rkt"
"config.rkt"
"parameter.rkt"
"symbol.rkt")
(provide print-list)
@ -10,37 +13,68 @@
(and (eq? mode PRINT-MODE/UNQUOTED)
(not alt-list-constructor)
(not (uninterrupted-list? v graph))))
(let ([max-length
(define (abbreviation v)
(and (eq? mode PRINT-MODE/QUOTED)
(pair? v)
(pair? (cdr v))
(null? (cddr v))
(not alt-list-constructor)
(config-get config print-reader-abbreviations)
(let ([starts-@? (lambda (v)
(and (symbol? v)
(let ([s (symbol->print-string v #:config config)])
(char=? #\@ (string-ref s 0)))))])
(case (car v)
[(quote) "'"]
[(quasiquote) "`"]
[(unquote) (if (starts-@? (cadr v)) ", " ",")]
[(unquote-splicing) ",@"]
[(syntax) "#'"]
[(quasisyntax) "#`"]
[(unsyntax) (if (starts-@? (cadr v)) "#, " "#,")]
[(unsyntax-splicing) "#,@"]
[else #f]))))
(cond
[(abbreviation v)
=> (lambda (prefix)
(p who (cadr v) mode o (write-string/max prefix o max-length) graph config))]
[else
(let ([max-length
(cond
[(eq? mode PRINT-MODE/UNQUOTED)
(let ([max-length
(if unquoted-pairs?
(write-string/max "(cons" o max-length)
(write-string/max (or alt-list-constructor "(list") o max-length))])
(cond
[(null? v) max-length]
[else (write-string/max " " o max-length)]))]
[else (write-string/max (or alt-list-prefix "(") o max-length)])])
(let loop ([v v] [max-length max-length])
(cond
[(eq? mode PRINT-MODE/UNQUOTED)
(let ([max-length
(if unquoted-pairs?
(write-string/max "(cons" o max-length)
(write-string/max (or alt-list-constructor "(list") o max-length))])
(cond
[(null? v) max-length]
[else (write-string/max " " o max-length)]))]
[else (write-string/max (or alt-list-prefix "(") o max-length)])])
(let loop ([v v] [max-length max-length])
(cond
[(eq? max-length 'full) 'full]
[(null? v) (write-string/max ")" o max-length)]
[(and (null? (cdr v))
(not unquoted-pairs?))
(let ([max-length (p who (car v) mode o max-length graph config)])
(write-string/max ")" o max-length))]
[(and (pair? (cdr v))
(or (not graph) (non-graph? (hash-ref graph (cdr v) #f)))
(not unquoted-pairs?))
(let ([max-length (p who (car v) mode o max-length graph config)])
(loop (cdr v) (write-string/max " " o max-length)))]
[else
(let* ([max-length (p who (car v) mode o max-length graph config)]
[max-length (if unquoted-pairs?
(write-string/max " " o max-length)
(write-string/max " . " o max-length))]
[max-length (p who (cdr v) mode o max-length graph config)])
(write-string/max ")" o max-length))]))))
[(eq? max-length 'full) 'full]
[(null? v) (write-string/max ")" o max-length)]
[(and (null? (cdr v))
(not unquoted-pairs?))
(let ([max-length (p who (car v) mode o max-length graph config)])
(write-string/max ")" o max-length))]
[(and (pair? (cdr v))
(or (not graph) (non-graph? (hash-ref graph (cdr v) #f)))
(not unquoted-pairs?)
(not (abbreviation (cdr v))))
(let ([max-length (p who (car v) mode o max-length graph config)])
(loop (cdr v) (write-string/max " " o max-length)))]
[(abbreviation v)
=> (lambda (prefix)
;; Assume a "." has already printed
(p who (cadr v) mode o (write-string/max prefix o max-length) graph config))]
[else
(let* ([max-length (p who (car v) mode o max-length graph config)]
[max-length (if unquoted-pairs?
(write-string/max " " o max-length)
(write-string/max " . " o max-length))]
[max-length (p who (cdr v) mode o max-length graph config)])
(write-string/max ")" o max-length))])))]))
(define (uninterrupted-list? v graph)
(and (list? v)

67
racket/src/io/print/main.rkt
View File

@ -224,9 +224,13 @@
[(eq? mode DISPLAY-MODE) (write-string/max (string v) o max-length)]
[else (print-char v o max-length)])]
[(not v)
(write-string/max "#f" o max-length)]
(if (config-get config print-boolean-long-form)
(write-string/max "#false" o max-length)
(write-string/max "#f" o max-length))]
[(eq? v #t)
(write-string/max "#t" o max-length)]
(if (config-get config print-boolean-long-form)
(write-string/max "#true" o max-length)
(write-string/max "#t" o max-length))]
[(pair? v)
(print-list p who v mode o max-length graph config #f #f)]
[(vector? v)
@ -238,25 +242,40 @@
(define l (for/list ([e (in-fxvector v)]) e))
(print-list p who l mode o max-length graph config "#fx(" "(fxvector")]
[(box? v)
(if (config-get config print-box)
(p who (unbox v) mode o (write-string/max "#&" o max-length) graph config)
(write-string/max "#<box>" o max-length))]
(cond
[(config-get config print-box)
(cond
[(eq? mode PRINT-MODE/UNQUOTED)
(let* ([max-length (write-string/max "(box " o max-length)]
[max-length (p who (unbox v) mode o max-length graph config)])
(write-string/max ")" o max-length))]
[else
(p who (unbox v) mode o (write-string/max "#&" o max-length) graph config)])]
[else
(check-unreadable who config mode v)
(write-string/max "#<box>" o max-length)])]
[(hash? v)
(if (and (config-get config print-hash-table)
(not (hash-weak? v)))
(print-hash v o max-length p who mode graph config)
(write-string/max "#<hash>" o max-length))]
(cond
[(and (config-get config print-hash-table)
(not (hash-weak? v)))
(cond
[(eq? mode PRINT-MODE/UNQUOTED)
(define l (apply append (hash-map v list #t)))
(define prefix (cond
[(hash-eq? v) "(hasheq"]
[(hash-eqv? v) "(hasheqv"]
[else "(hash"]))
(print-list p who l mode o max-length graph config #f prefix)]
[else
(print-hash v o max-length p who mode graph config)])]
[else
(check-unreadable who config mode v)
(write-string/max "#<hash>" o max-length)])]
[(and (eq? mode WRITE-MODE)
(not (config-get config print-unreadable))
;; Regexps are a special case: custom writers that produce readable input
(not (printable-regexp? v)))
(raise (exn:fail
(string-append (symbol->string who)
": printing disabled for unreadable value"
"\n value: "
(parameterize ([print-unreadable #t])
((error-value->string-handler) v (error-print-width))))
(current-continuation-marks)))]
(fail-unreadable who v)]
[(mpair? v)
(print-mlist p who v mode o max-length graph config)]
[(custom-write? v)
@ -295,6 +314,22 @@
(print-named "input-port" v mode o max-length)]
[(core-output-port? v)
(print-named "output-port" v mode o max-length)]
[(unquoted-printing-string? v)
(write-string/max (unquoted-printing-string-value v) o max-length)]
[else
;; As a last resort, fall back to the host `format`:
(write-string/max (format "~s" v) o max-length)]))
(define (fail-unreadable who v)
(raise (exn:fail
(string-append (symbol->string who)
": printing disabled for unreadable value"
"\n value: "
(parameterize ([print-unreadable #t])
((error-value->string-handler) v (error-print-width))))
(current-continuation-marks))))
(define (check-unreadable who config mode v)
(when (and (eq? mode WRITE-MODE)
(not (config-get config print-unreadable)))
(fail-unreadable who v)))