From fd33584b6f7198f9557f827d5422a16fcc0e8315 Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Mon, 20 May 2013 15:45:35 -0400 Subject: [PATCH] Cut off type printing with :type at one level Makes types print nicer with :type in most cases. Previously, the printer expanded type aliases as much as possible. Now, it defaults to a single level of expansion. A later commit adds a #:verbose option to show the entire type. --- .../succeed/type-printer-single-level.rkt | 23 +++++++++++ collects/typed-racket/core.rkt | 5 ++- collects/typed-racket/tc-setup.rkt | 20 ++++++---- collects/typed-racket/types/printer.rkt | 39 ++++++++++++++----- 4 files changed, 69 insertions(+), 18 deletions(-) create mode 100644 collects/tests/typed-racket/succeed/type-printer-single-level.rkt diff --git a/collects/tests/typed-racket/succeed/type-printer-single-level.rkt b/collects/tests/typed-racket/succeed/type-printer-single-level.rkt new file mode 100644 index 0000000000..4cbe08c8de --- /dev/null +++ b/collects/tests/typed-racket/succeed/type-printer-single-level.rkt @@ -0,0 +1,23 @@ +#lang racket + +;; Make sure that the type printer expands only a single +;; level for (:type ...) + +(require rackunit + racket/sandbox) + +(define out (open-output-string)) + +(define tr-eval + (parameterize ([sandbox-output out]) + (call-with-trusted-sandbox-configuration + (thunk (make-evaluator 'typed/racket))))) + +(tr-eval '(require typed/racket)) +(tr-eval '(define-type Foo (U String Integer))) +(tr-eval '(define-type Bar (Foo -> Foo))) + +(tr-eval '(:type Foo)) +(tr-eval '(:type Bar)) + +(check-equal? (get-output-string out) "(U Integer String)\n(Foo -> Foo)\n") diff --git a/collects/typed-racket/core.rkt b/collects/typed-racket/core.rkt index 05f0bd8e7f..fb77967fe8 100644 --- a/collects/typed-racket/core.rkt +++ b/collects/typed-racket/core.rkt @@ -6,6 +6,7 @@ (private with-types type-contract parse-type) (except-in syntax/parse id) racket/match racket/syntax unstable/match racket/list syntax/stx + racket/promise (types utils abbrev generalize printer) (typecheck provide-handling tc-toplevel tc-app-helper) (rep type-rep) @@ -48,11 +49,13 @@ (define did-I-suggest-:print-type-already? #f) (define :print-type-message " ... [Use (:print-type ) to see more.]") (define (ti-core stx init) + (current-type-names (init-current-type-names)) (syntax-parse stx [(_ . ((~datum module) . rest)) #'(module . rest)] [(_ . ((~literal :type) ty:expr)) - #`(display #,(format "~a\n" (parse-type #'ty)))] + (parameterize ([current-print-type-fuel 1]) + #`(display #,(format "~a\n" (parse-type #'ty))))] ;; Prints the _entire_ type. May be quite large. [(_ . ((~literal :print-type) e:expr)) (tc-setup #'stx #'e 'top-level expanded init tc-toplevel-form before type diff --git a/collects/typed-racket/tc-setup.rkt b/collects/typed-racket/tc-setup.rkt index 9e24036e7d..90b00d9818 100644 --- a/collects/typed-racket/tc-setup.rkt +++ b/collects/typed-racket/tc-setup.rkt @@ -13,7 +13,7 @@ (for-template racket/base)) (lazy-require [typed-racket/optimizer/optimizer (optimize-top)]) -(provide tc-setup invis-kw maybe-optimize) +(provide tc-setup invis-kw maybe-optimize init-current-type-names) (define-syntax-class invis-kw #:literals (define-values define-syntaxes #%require #%provide begin) @@ -28,6 +28,16 @@ (do-time "Optimized"))) body)) +;; -> Promise> +;; initialize the type names for printing +(define (init-current-type-names) + (lazy + (append + (type-name-env-map (lambda (id ty) + (cons (syntax-e id) ty))) + (type-alias-env-map (lambda (id ty) + (cons (syntax-e id) ty)))))) + (define-syntax-rule (tc-setup orig-stx stx expand-ctxt fully-expanded-stx init checker pre-result post-result . body) (let () (set-box! typed-context? #t) @@ -41,13 +51,7 @@ [print-syntax? #f] ;; this parameter is just for printing types ;; this is a parameter to avoid dependency issues - [current-type-names - (lazy - (append - (type-name-env-map (lambda (id ty) - (cons (syntax-e id) ty))) - (type-alias-env-map (lambda (id ty) - (cons (syntax-e id) ty)))))] + [current-type-names (init-current-type-names)] ;; reinitialize disappeared uses [disappeared-use-todo null] [disappeared-bindings-todo null]) diff --git a/collects/typed-racket/types/printer.rkt b/collects/typed-racket/types/printer.rkt index 38cb7aa491..52f7c4b175 100644 --- a/collects/typed-racket/types/printer.rkt +++ b/collects/typed-racket/types/printer.rkt @@ -23,7 +23,8 @@ #'(provide print-type print-filter print-object print-pathelem))) (provide-printer) -(provide print-multi-line-case-> special-dots-printing? print-complex-filters?) +(provide print-multi-line-case-> special-dots-printing? print-complex-filters? + current-print-type-fuel) ;; do we attempt to find instantiations of polymorphic types to print? @@ -36,8 +37,14 @@ (define special-dots-printing? (make-parameter #f)) (define print-complex-filters? (make-parameter #f)) +;; this parameter controls how far down the type to expand type names +;; interp. 0 -> don't expand +;; 1 -> expand one level, etc. +;; +inf.0 -> expand always +(define current-print-type-fuel (make-parameter 0)) + ;; does t have a type name associated with it currently? -;; has-name : Type -> Maybe[Symbol] +;; has-name : Type -> Maybe[Listof] (define (has-name? t) (cond [print-aliases @@ -47,7 +54,7 @@ n)) (if (null? candidates) #f - (car (sort candidates string>? #:key symbol->string)))] + (sort candidates string>? #:key symbol->string))] [else #f])) ;; print-filter : Filter Port Boolean @@ -104,11 +111,12 @@ [(Path: pes i) (fp "~a" (append pes (list i)))] [else (fp "(Unknown Object: ~a)" (struct->vector object))])) +;; print-union : Type LSet -> Void ;; Unions are represented as a flat list of branches. In some cases, it would ;; be nicer to print them using higher-level descriptions instead. ;; We do set coverage, with the elements of the union being what we want to ;; cover, and all the names types we know about being the sets. -(define (print-union t) +(define (print-union t ignored-names) (match-define (Union: elems) t) (define valid-names ;; We keep only unions, and only those that are subtypes of t. @@ -116,7 +124,8 @@ (filter (lambda (p) (match p [(cons name (and t* (Union: elts))) - (subtype t* t)] + (and (not (member name ignored-names)) + (subtype t* t))] [_ #f])) (force (current-type-names)))) ;; names and the sets themselves (not the union types) @@ -215,7 +224,7 @@ ;; print out a type ;; print-type : Type Port Boolean -> Void -(define (print-type type port write?) +(define (print-type type port write? [ignored-names '()]) (define (fp . args) (apply fprintf port args)) (define (tuple? t) (match t @@ -233,8 +242,20 @@ [(Univ:) (fp "Any")] ;; names are just the printed as the original syntax [(Name: stx) (fp "~a" (syntax-e stx))] - [(app has-name? (? values name)) - (fp "~a" name)] + ;; If a type has a name, then print it with that name. + ;; However, we expand the alias in some cases + ;; (i.e., the fuel is > 0) for the :type form. + [(app has-name? (? values names)) + (=> fail) + (when (not (null? ignored-names)) (fail)) + (define fuel (current-print-type-fuel)) + (if (> fuel 0) + (parameterize ([current-print-type-fuel (sub1 fuel)]) + ;; if we still have fuel, print the expanded type and + ;; add the name to the ignored list so that the union + ;; printer does not try to print with the name. + (print-type type port write? (append names ignored-names))) + (fp "~a" (car names)))] [(StructType: (Struct: nm _ _ _ _ _)) (fp "(StructType ~a)" (syntax-e nm))] [(StructTop: (Struct: nm _ _ _ _ _)) (fp "(Struct ~a)" (syntax-e nm))] [(BoxTop:) (fp "Box")] @@ -282,7 +303,7 @@ [(Ephemeron: e) (fp "(Ephemeronof ~a)" e)] [(CustodianBox: e) (fp "(CustodianBoxof ~a)" e)] [(Set: e) (fp "(Setof ~a)" e)] - [(Union: elems) (fp "~a" (cons 'U (print-union type)))] + [(Union: elems) (fp "~a" (cons 'U (print-union type ignored-names)))] [(Pair: l r) (fp "(Pairof ~a ~a)" l r)] [(ListDots: dty dbound) (fp "(List ~a ...~a~a)" dty (if (special-dots-printing?) "" " ") dbound)]