From 2badae67b0a14ffbcf2158b4b9e434572df8ed59 Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Tue, 7 Jan 2014 17:11:57 -0500 Subject: [PATCH] Print ->* style types with ->* constructor This recognizes the type for a function like `regexp-match?` and will print it concisely. original commit: 54f72050a631c45785b95bdfaca9877db41bc3b8 --- .../typed-racket/private/parse-type.rkt | 26 ++++---- .../typed-racket/types/printer.rkt | 63 ++++++++++++++++++- .../unit-tests/type-printer-tests.rkt | 19 +++++- 3 files changed, 92 insertions(+), 16 deletions(-) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/parse-type.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/parse-type.rkt index 50e55fc3..41d589d0 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/parse-type.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/parse-type.rkt @@ -100,12 +100,16 @@ [(:All^ (_:id ...) _ _ _ ...) (tc-error "All: too many forms in body of All type")] [(:All^ . rest) (tc-error "All: bad syntax")])) -(define-splicing-syntax-class mandatory-kw-tys +;; syntax class for standard keyword syntax (same as contracts), may be +;; optional or mandatory depending on where it's used +(define-splicing-syntax-class plain-kw-tys (pattern (~seq k:keyword t:expr) - #:attr Keyword (make-Keyword (syntax-e #'k) (parse-type #'t) #t))) + #:attr mand-kw (make-Keyword (syntax-e #'k) (parse-type #'t) #t) + #:attr opt-kw (make-Keyword (syntax-e #'k) (parse-type #'t) #f))) (define-splicing-syntax-class keyword-tys - (pattern kw:mandatory-kw-tys #:attr Keyword (attribute kw.Keyword)) + (pattern kw:plain-kw-tys #:attr Keyword (attribute kw.mand-kw)) + ;; custom optional keyword syntax for TR (pattern (~seq [k:keyword t:expr]) #:attr Keyword (make-Keyword (syntax-e #'k) (parse-type #'t) #f))) @@ -376,11 +380,8 @@ (parse-values-type #'rng) #:kws (attribute kws.Keyword)))))] [(:->*^ - (dom:non-keyword-ty ... mand-kws:mandatory-kw-tys ...) - ;; this clause uses the syntax of mandatory keyword types to - ;; match the ->* contract, but they are optional - ;; (the code below swaps the boolean appropriately) - (~optional (opt-dom:non-keyword-ty ... opt-kws:mandatory-kw-tys ...)) + (dom:non-keyword-ty ... mand-kws:plain-kw-tys ...) + (~optional (opt-dom:non-keyword-ty ... opt-kws:plain-kw-tys ...)) (~optional (~seq #:rest rest-type:non-keyword-ty)) rng) (define doms (for/list ([d (in-syntax #'(dom ...))]) @@ -392,11 +393,10 @@ (opt-fn doms opt-doms (parse-values-type #'rng) #:rest (and (attribute rest-type) (parse-type #'rest-type)) - #:kws (append (attribute mand-kws.Keyword) - (map (match-lambda [(Keyword: k t _) (make-Keyword k t #f)]) - (if (attribute opt-kws) - (attribute opt-kws.Keyword) - null))))] + #:kws (append (attribute mand-kws.mand-kw) + (if (attribute opt-kws) + (attribute opt-kws.opt-kw) + null)))] [id:identifier (cond ;; if it's a type variable, we just produce the corresponding reference (which is in the HT) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/printer.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/printer.rkt index 07b3f9cb..7aee55a7 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/printer.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/printer.rkt @@ -5,10 +5,13 @@ (require racket/require racket/match unstable/sequence racket/string racket/promise racket/pretty + racket/list (prefix-in s: srfi/1) (path-up "rep/type-rep.rkt" "rep/filter-rep.rkt" "rep/object-rep.rkt" "rep/rep-utils.rkt" "types/subtype.rkt" "types/match-expanders.rkt" + "types/kw-types.rkt" + "types/utils.rkt" "utils/utils.rkt" "utils/tc-utils.rkt") (for-syntax racket/base syntax/parse)) @@ -257,6 +260,59 @@ [_ (list (type->sexp rng))]))] [else `(Unknown Function Type: ,(struct->vector arr))])) +;; format->* : (Listof arr) -> S-Expression +;; Format arrs that correspond to a ->* type +(define (format->* arrs) + (define out (open-output-string)) + (define (fp . args) (apply fprintf out args)) + ;; see type-contract.rkt, which does something similar and this code + ;; was stolen from/inspired by/etc. + (match* ((first arrs) (last arrs)) + [((arr: first-dom rng rst _ kws) + (arr: last-dom _ _ _ _)) + (define-values (mand-kws opt-kws) (partition-kws kws)) + (define opt-doms (drop last-dom (length first-dom))) + `(->* + ,(append* (for/list ([dom (in-list first-dom)]) + (type->sexp dom)) + (for/list ([mand-kw (in-list mand-kws)]) + (match-define (Keyword: k t _) mand-kw) + (list k (type->sexp t)))) + ,(append* (for/list ([opt-dom (in-list opt-doms)]) + (type->sexp opt-dom)) + (for/list ([opt-kw (in-list opt-kws)]) + (match-define (Keyword: k t _) opt-kw) + (list k (type->sexp t)))) + ,@(if rst (list '#:rest (type->sexp rst)) null) + ,(type->sexp rng))])) + +;; cover-case-lambda : (Listof arr) -> (Listof s-expression) +;; Try to cover a case-> type with ->* types +(define (cover-case-lambda arrs) + ;; sublists : (Listof X) -> (Listof (List (Listof X) (Listof X) (Listof X))) + ;; produce sublists of a list in decreasing order, also + ;; returning the rest of the list before and after the + ;; sublist for each. + (define (sublists lst) + (define (sublist-n n lst) + (for/list ([to-drop (range (- (length lst) (- n 1)))]) + (define-values (pre mid) (split-at lst to-drop)) + (define-values (sub post) (split-at mid n)) + (list pre sub post))) + (apply append (for/list ([i (range (length lst) 0 -1)]) + (sublist-n i lst)))) + (let loop ([left-to-cover arrs]) + ;; try to match the largest sublists possible that correspond to + ;; ->* types and then the remainder are formatted normally + (define a-match + (for/first ([sub (in-list (sublists left-to-cover))] + #:when (has-optional-args? (second sub))) + sub)) + (cond [a-match + (match-define (list pre sub post) a-match) + (append (loop pre) (list (format->* sub)) (loop post))] + [else (map arr->sexp left-to-cover)]))) + ;; case-lambda->sexp : Type -> S-expression ;; Convert a case-> type to an s-expression (define (case-lambda->sexp type) @@ -265,8 +321,11 @@ (match arities [(list) '(case->)] [(list a) (arr->sexp a)] - [(list a b ...) - `(case-> ,(arr->sexp a) ,@(map arr->sexp b))])])) + [(and arrs (list a b ...)) + (define cover (cover-case-lambda arrs)) + (if (> (length cover) 1) + `(case-> ,@cover) + (car cover))])])) ;; type->sexp : Type -> S-expression ;; convert a type to an s-expression that can be printed diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/type-printer-tests.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/type-printer-tests.rkt index f8754009..ac3afec9 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/type-printer-tests.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/type-printer-tests.rkt @@ -86,7 +86,24 @@ (string-append "(Any Path-String [#:exists (U 'error" " 'append 'update 'replace 'truncate" " 'truncate/replace)] [#:mode (U" - " 'binary 'text)] -> Void)"))) + " 'binary 'text)] -> Void)")) + (check-prints-as? (->opt Univ [] -Void) "(Any -> Void)") + (check-prints-as? (->opt [-String] -Void) "(->* () (String) Void)") + (check-prints-as? (->opt Univ [-String] -Void) "(->* (Any) (String) Void)") + (check-prints-as? (->opt Univ -Symbol [-String] -Void) + "(->* (Any Symbol) (String) Void)") + (check-prints-as? (->optkey Univ [-String] #:x -String #f -Void) + "(->* (Any) (String #:x String) Void)") + (check-prints-as? (->optkey Univ [-String] #:x -String #t -Void) + "(->* (Any #:x String) (String) Void)") + (check-prints-as? (->optkey Univ [-String] #:x -String #t -Void) + "(->* (Any #:x String) (String) Void)") + (check-prints-as? (->optkey Univ [-String] #:rest -String #:x -String #t -Void) + "(->* (Any #:x String) (String) #:rest String Void)") + (check-prints-as? (cl->* (->opt -Pathlike [-String] -Void) + (->optkey Univ [-String] #:rest -String #:x -String #t -Void)) + (string-append "(case-> (->* (Path-String) (String) Void) " + "(->* (Any #:x String) (String) #:rest String Void))"))) (test-suite "Pretty printing tests" (check-pretty-prints-as? (-val 3) "3")