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

Make top interaction commands lazily loaded.

Browse Source
This commit is contained in:
Eric Dobson 2013-12-15 13:21:07 -08:00
parent 8e51f2b5ac
commit 5d4cb8c08b
1 changed files with 97 additions and 89 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,8 +1,37 @@
#lang racket/base #lang racket/base
(require (require
"../utils/utils.rkt" (for-syntax racket/base racket/lazy-require syntax/parse))
(begin-for-syntax
(lazy-require ['implementantion (:type-impl :print-type-impl :query-type/args-impl :query-type/result-impl)]))
(provide
(for-syntax (for-syntax
interactive-command?
interactive-command-procedure)
:type :print-type :query-type/args :query-type/result)
(define-for-syntax (fail _ stx)
(syntax-parse stx
[_:id
(raise-syntax-error #f "must be applied to arguments" stx)]
[_ (raise-syntax-error #f "only valid at the top-level of an interaction" stx)]))
(begin-for-syntax
(struct interactive-command (procedure)
#:property prop:procedure fail))
(define-syntax :type (interactive-command :type-impl))
(define-syntax :print-type (interactive-command :print-type-impl))
(define-syntax :query-type/args (interactive-command :query-type/args-impl))
(define-syntax :query-type/result (interactive-command :query-type/result-impl))
(module implementation racket/base
(require
"../utils/utils.rkt"
racket/base racket/base
racket/match racket/match
racket/format racket/format
@ -15,55 +44,37 @@
(types utils abbrev printer) (types utils abbrev printer)
(typecheck tc-toplevel tc-app-helper) (typecheck tc-toplevel tc-app-helper)
(rep type-rep) (rep type-rep)
(utils tc-utils))) (utils tc-utils))
(provide (provide
(for-syntax :type-impl :print-type-impl :query-type/args-impl :query-type/result-impl)
interactive-command?
interactive-command-procedure)
:type :print-type :query-type/args :query-type/result) (define (:type-impl stx init)
(syntax-parse stx
[(_ (~optional (~and #:verbose verbose-kw)) ty:expr)
(parameterize ([current-print-type-fuel
(if (attribute verbose-kw) +inf.0 1)]
;; This makes sure unions are totally flat for the
;; infinite fuel case. If fuel that's not 0, 1, or +inf.0
;; is ever used, more may need to be done.
[current-type-names
(if (attribute verbose-kw) '() (current-type-names))]
[current-print-unexpanded (box '())])
(init)
(define type (format "~a" (parse-type #'ty)))
(define unexpanded
(remove-duplicates (unbox (current-print-unexpanded))))
(define cue (if (null? unexpanded)
""
(format "[can expand further: ~a]"
(string-join (map ~a unexpanded)))))
#`(display #,(format "~a\n~a" type cue)))]
[form
(raise-syntax-error #f "must be applied to exactly one argument" #'form)]))
(define-for-syntax (fail _ stx) ;; TODO what should be done with stx
(syntax-parse stx ;; Prints the _entire_ type. May be quite large.
[_:id (define (:print-type-impl stx init)
(raise-syntax-error #f "must be applied to arguments" stx)] (syntax-parse stx
[_ (raise-syntax-error #f "only valid at the top-level of an interaction" stx)]))
(begin-for-syntax
(struct interactive-command (procedure)
#:property prop:procedure fail))
(define-syntax :type
(interactive-command
(λ (stx init)
(syntax-parse stx
[(_ (~optional (~and #:verbose verbose-kw)) ty:expr)
(parameterize ([current-print-type-fuel
(if (attribute verbose-kw) +inf.0 1)]
;; This makes sure unions are totally flat for the
;; infinite fuel case. If fuel that's not 0, 1, or +inf.0
;; is ever used, more may need to be done.
[current-type-names
(if (attribute verbose-kw) '() (current-type-names))]
[current-print-unexpanded (box '())])
(init)
(define type (format "~a" (parse-type #'ty)))
(define unexpanded
(remove-duplicates (unbox (current-print-unexpanded))))
(define cue (if (null? unexpanded)
""
(format "[can expand further: ~a]"
(string-join (map ~a unexpanded)))))
#`(display #,(format "~a\n~a" type cue)))]
[form
(raise-syntax-error #f "must be applied to exactly one argument" #'form)]))))
;; Prints the _entire_ type. May be quite large.
(define-syntax :print-type
(interactive-command
(λ (stx init)
(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
@ -73,46 +84,43 @@
[(tc-results: t) (-values t)] [(tc-results: t) (-values t)]
[(tc-any-results:) ManyUniv])))))] [(tc-any-results:) ManyUniv])))))]
[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)]))
;; given a function and input types, display the result type ;; given a function and input types, display the result type
(define-syntax :query-type/args (define (:query-type/args-impl stx init)
(interactive-command (syntax-parse stx
(λ (stx init) [(_ op arg-type ...)
(syntax-parse stx (with-syntax ([(dummy-arg ...) (generate-temporaries #'(arg-type ...))])
[(_ op arg-type ...) (tc-setup stx
(with-syntax ([(dummy-arg ...) (generate-temporaries #'(arg-type ...))]) ;; create a dummy function with the right argument types
(tc-setup stx #`(lambda #,(stx-map type-label-property
;; create a dummy function with the right argument types #'(dummy-arg ...) #'(arg-type ...))
#`(lambda #,(stx-map type-label-property (op dummy-arg ...))
#'(dummy-arg ...) #'(arg-type ...)) 'top-level expanded init tc-toplevel-form before type
(op dummy-arg ...)) #`(display
'top-level expanded init tc-toplevel-form before type #,(format "~a\n"
#`(display (match type
#,(format "~a\n" [(tc-result1: (and t (Function: _)) f o) t])))))]
(match type [form
[(tc-result1: (and t (Function: _)) f o) t])))))] (raise-syntax-error #f "must be applied to at least one argument" #'form)]))
[form
(raise-syntax-error #f "must be applied to at least one argument" #'form)])))) ;; given a function and a desired return type, fill in the blanks
(define (:query-type/result-impl stx init)
(syntax-parse stx
[(_ op desired-type)
(init)
(let ([expected (parse-type #'desired-type)])
(tc-setup stx #'op 'top-level expanded init tc-toplevel-form before type
(match type
[(tc-result1: (and t (Function: _)) f o)
(let ([cleaned (cleanup-type t expected)])
#`(display
#,(match cleaned
[(Function: '())
"Desired return type not in the given function's range.\n"]
[(Function: arrs)
(format "~a\n" cleaned)])))]
[_ (error (format "~a: not a function" (syntax->datum #'op) ))])))]
[form
(raise-syntax-error #f "must be applied to exactly two arguments" #'form)])))
;; given a function and a desired return type, fill in the blanks
(define-syntax :query-type/result
(interactive-command
(λ (stx init)
(syntax-parse stx
[(_ op desired-type)
(init)
(let ([expected (parse-type #'desired-type)])
(tc-setup stx #'op 'top-level expanded init tc-toplevel-form before type
(match type
[(tc-result1: (and t (Function: _)) f o)
(let ([cleaned (cleanup-type t expected)])
#`(display
#,(match cleaned
[(Function: '())
"Desired return type not in the given function's range.\n"]
[(Function: arrs)
(format "~a\n" cleaned)])))]
[_ (error (format "~a: not a function" (syntax->datum #'op) ))])))]
[form
(raise-syntax-error #f "must be applied to exactly two arguments" #'form)]))))