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

76
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,28 +44,11 @@
(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)
(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
(λ (stx init)
(syntax-parse stx (syntax-parse stx
[(_ (~optional (~and #:verbose verbose-kw)) ty:expr) [(_ (~optional (~and #:verbose verbose-kw)) ty:expr)
(parameterize ([current-print-type-fuel (parameterize ([current-print-type-fuel
@ -57,12 +69,11 @@
(string-join (map ~a unexpanded))))) (string-join (map ~a unexpanded)))))
#`(display #,(format "~a\n~a" type cue)))] #`(display #,(format "~a\n~a" type cue)))]
[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 (:print-type-impl stx init)
(interactive-command
(λ (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
@ -73,12 +84,10 @@
[(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
(λ (stx init)
(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 ...))])
@ -93,12 +102,10 @@
(match type (match type
[(tc-result1: (and t (Function: _)) f o) t])))))] [(tc-result1: (and t (Function: _)) f o) t])))))]
[form [form
(raise-syntax-error #f "must be applied to at least one argument" #'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 ;; given a function and a desired return type, fill in the blanks
(define-syntax :query-type/result (define (:query-type/result-impl stx init)
(interactive-command
(λ (stx init)
(syntax-parse stx (syntax-parse stx
[(_ op desired-type) [(_ op desired-type)
(init) (init)
@ -115,4 +122,5 @@
(format "~a\n" cleaned)])))] (format "~a\n" cleaned)])))]
[_ (error (format "~a: not a function" (syntax->datum #'op) ))])))] [_ (error (format "~a: not a function" (syntax->datum #'op) ))])))]
[form [form
(raise-syntax-error #f "must be applied to exactly two arguments" #'form)])))) (raise-syntax-error #f "must be applied to exactly two arguments" #'form)])))