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

Use actual original syntax.

Browse Source 
Don't know how to test that this is better since I don't even know if it
is used.
This commit is contained in:
Eric Dobson 2013-11-17 19:26:26 -08:00
parent f8eae8c00d
commit 02a5616ccd
1 changed files with 3 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/top-interaction.rkt
View File

@ -58,14 +58,13 @@
[form [form
(raise-syntax-error #f "must be applied to exactly one argument" #'form)])))) (raise-syntax-error #f "must be applied to exactly one argument" #'form)]))))
;; TODO what should be done with stx
;; Prints the _entire_ type. May be quite large. ;; Prints the _entire_ type. May be quite large.
(define-syntax :print-type (define-syntax :print-type
(interactive-command (interactive-command
(λ (stx init) (λ (stx init)
(syntax-parse stx (syntax-parse stx
[(_ e) [(_ e)
(tc-setup #'stx #'e 'top-level expanded init tc-toplevel-form before type (tc-setup stx #'e 'top-level expanded init tc-toplevel-form before type
#`(display #`(display
#,(parameterize ([print-multi-line-case-> #t]) #,(parameterize ([print-multi-line-case-> #t])
(format "~a\n" (match type (format "~a\n" (match type
@ -82,7 +81,7 @@
(syntax-parse stx (syntax-parse stx
[(_ op arg-type ...) [(_ op arg-type ...)
(with-syntax ([(dummy-arg ...) (generate-temporaries #'(arg-type ...))]) (with-syntax ([(dummy-arg ...) (generate-temporaries #'(arg-type ...))])
(tc-setup #'stx (tc-setup stx
;; create a dummy function with the right argument types ;; create a dummy function with the right argument types
#`(lambda #,(stx-map type-label-property #`(lambda #,(stx-map type-label-property
#'(dummy-arg ...) #'(arg-type ...)) #'(dummy-arg ...) #'(arg-type ...))
@ -102,7 +101,7 @@
(syntax-parse stx (syntax-parse stx
[(_ op desired-type) [(_ op desired-type)
(let ([expected (parse-type #'desired-type)]) (let ([expected (parse-type #'desired-type)])
(tc-setup #'stx #'op 'top-level expanded init tc-toplevel-form before type (tc-setup stx #'op 'top-level expanded init tc-toplevel-form before type
(match type (match type
[(tc-result1: (and t (Function: _)) f o) [(tc-result1: (and t (Function: _)) f o)
(let ([cleaned (cleanup-type t expected)]) (let ([cleaned (cleanup-type t expected)])