diff --git a/collects/tests/typed-racket/tr-random-testing.rkt b/collects/tests/typed-racket/tr-random-testing.rkt index f8059145..d0c1c3b3 100644 --- a/collects/tests/typed-racket/tr-random-testing.rkt +++ b/collects/tests/typed-racket/tr-random-testing.rkt @@ -105,7 +105,6 @@ (define (get-type e [typecheck (compose tc-expr expand)]) (parameterize ([delay-errors? #f] [current-namespace (namespace-anchor->namespace anch)] - [custom-printer #t] [infer-param infer] [orig-module-stx (quote-syntax e)]) (typecheck (datum->syntax #'here e)))) diff --git a/collects/tests/typed-racket/unit-tests/typecheck-tests.rkt b/collects/tests/typed-racket/unit-tests/typecheck-tests.rkt index d09b28af..627db5a3 100644 --- a/collects/tests/typed-racket/unit-tests/typecheck-tests.rkt +++ b/collects/tests/typed-racket/unit-tests/typecheck-tests.rkt @@ -74,7 +74,6 @@ [(_ e) #`(parameterize ([delay-errors? #f] [current-namespace (namespace-anchor->namespace anch)] - [custom-printer #t] [infer-param infer] [orig-module-stx (quote-syntax e)]) (let ([ex (expand 'e)]) @@ -86,7 +85,6 @@ [(_ e) #`(parameterize ([delay-errors? #f] [current-namespace (namespace-anchor->namespace anch)] - [custom-printer #t] [infer-param infer] [orig-module-stx (quote-syntax e)]) (let ([ex (expand 'e)]) diff --git a/collects/typed-racket/core.rkt b/collects/typed-racket/core.rkt index 1f16bd73..57e5d92e 100644 --- a/collects/typed-racket/core.rkt +++ b/collects/typed-racket/core.rkt @@ -6,7 +6,7 @@ (private with-types type-contract parse-type) (except-in syntax/parse id) racket/match racket/syntax unstable/match racket/list syntax/stx - (types utils abbrev generalize) + (types utils abbrev generalize printer) (typecheck provide-handling tc-toplevel tc-app-helper) (rep type-rep) (env env-req) diff --git a/collects/typed-racket/types/printer.rkt b/collects/typed-racket/types/printer.rkt index 0a648956..cf0469b9 100644 --- a/collects/typed-racket/types/printer.rkt +++ b/collects/typed-racket/types/printer.rkt @@ -5,9 +5,23 @@ (path-up "rep/type-rep.rkt" "rep/filter-rep.rkt" "rep/object-rep.rkt" "rep/rep-utils.rkt" "types/abbrev.rkt" "types/subtype.rkt" "utils/utils.rkt" - "utils/tc-utils.rkt")) + "utils/tc-utils.rkt") + (for-syntax racket/base)) -(provide print-type print-filter print-object print-pathelem) +;; printer-type: (one-of/c 'custom 'debug) +(define-for-syntax printer-type 'custom) + +(define-syntax (make-provides stx) + (if (eq? printer-type 'debug) + #'(provide (rename-out + (debug-printer print-type) + (debug-printer print-filter) + (debug-printer print-object) + (debug-printer print-pathelem))) + #'(provide print-type print-filter print-object print-pathelem))) +(make-provides) + +(provide print-multi-line-case-> special-dots-printing? print-complex-filters?) ;;TODO try to remove requirement on abbrev once promise is fixed @@ -17,9 +31,9 @@ ;; do we use simple type aliases in printing (define print-aliases #t) +(define print-multi-line-case-> (make-parameter #f)) (define special-dots-printing? (make-parameter #f)) (define print-complex-filters? (make-parameter #f)) -(provide special-dots-printing? print-complex-filters?) ;; does t have a type name associated with it currently? ;; has-name : Type -> Maybe[Symbol] @@ -309,3 +323,37 @@ [else (fp "(Unknown Type: ~a)" (struct->vector c))] )) + + +(define-syntax (make-debug-printer stx) + (syntax-local-introduce + (if (eq? printer-type 'debug) + #'(begin + (require racket/pretty) + (require mzlib/pconvert) + + (define (converter v basic sub) + (define (gen-constructor sym) + (string->symbol (string-append "make-" (substring (symbol->string sym) 7)))) + (match v + [(? (lambda (e) (or (Filter? e) + (Object? e) + (PathElem? e))) + (app (lambda (v) (vector->list (struct->vector v))) + (list-rest tag seq fv fi stx vals))) + `(,(gen-constructor tag) ,@(map sub vals))] + [(? Type? + (app (lambda (v) (vector->list (struct->vector v))) (list-rest tag seq fv fi stx key vals))) + `(,(gen-constructor tag) ,@(map sub vals))] + [_ (basic v)])) + + (define (debug-printer v port write?) + ((if write? + pretty-write + pretty-print) + (parameterize ((current-print-convert-hook converter)) + (print-convert v)) + port))) + #'(begin)))) +(make-debug-printer) + diff --git a/collects/typed-racket/utils/utils.rkt b/collects/typed-racket/utils/utils.rkt index 74abbada..f36deb00 100644 --- a/collects/typed-racket/utils/utils.rkt +++ b/collects/typed-racket/utils/utils.rkt @@ -21,7 +21,7 @@ at least theoretically. ;; logging printf/log show-input? ;; struct printing - print-multi-line-case-> define-struct/printer + define-struct/printer ;; provide macros rep utils typecheck infer env private types) @@ -109,9 +109,6 @@ at least theoretically. #'(log-debug (format fmt . args))]) #'(void))) -;; custom printing -(define-for-syntax custom-printer #t) -(define print-multi-line-case-> (make-parameter #f)) (define-syntax (define-struct/printer stx) (syntax-parse stx @@ -120,11 +117,9 @@ at least theoretically. #:property prop:custom-print-quotable 'never ;; Eta expansion so that printer is not evaluated ;; until needed. - #,@(if custom-printer - #'(#:methods gen:custom-write - [(define (write-proc v port write?) - (printer v port write?))]) - #'()) + #:methods gen:custom-write + [(define (write-proc v port write?) + (printer v port write?))] #:transparent)]))