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

Minor printer refactoring.

Browse Source 
original commit: fddd5c63ff4113c104dd184b90b38900aa99b4ad
This commit is contained in:
Sam Tobin-Hochstadt 2012-08-14 09:56:49 -04:00
parent 8442c9da34
commit 74b6ccbf6a
1 changed files with 37 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

75
collects/typed-racket/types/printer.rkt
View File

@ -6,20 +6,19 @@
"rep/rep-utils.rkt" "types/abbrev.rkt" "types/subtype.rkt"
"utils/utils.rkt"
"utils/tc-utils.rkt")
(for-syntax racket/base))
(for-syntax racket/base syntax/parse))
;; printer-type: (one-of/c 'custom 'debug)
(define-for-syntax printer-type 'custom)
(define-syntax (make-provides stx)
(define-syntax (provide-printer 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 (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-printer)
(provide print-multi-line-case-> special-dots-printing? print-complex-filters?)
@ -325,35 +324,35 @@
(define-syntax (make-debug-printer stx)
(syntax-local-introduce
(if (eq? printer-type 'debug)
#'(begin
(require racket/pretty)
(require mzlib/pconvert)
(define-syntax (define-debug-printer stx)
(syntax-parse stx
[(_ debug-printer:id)
#:when (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)]))
(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)
(define-debug-printer debug-printer)