Move code for top-interaction commands to their own file.

Also adds some more test cases. original commit: 7e0553e037bcff0a549fd3bdc86b09f00f8796f6
2013-11-17 17:36:51 -08:00 · 2013-11-17 17:36:51 -08:00 · c019c9dc4b
commit c019c9dc4b
parent 16a4734803
4 changed files with 146 additions and 83 deletions
--- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt
@ -27,6 +27,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
                     -lambda -define)
         ;; provide the contracted bindings as primitives
         (all-from-out "base-contracted.rkt")
+         (all-from-out "top-interaction.rkt")
         :
         (rename-out [define-typed-struct define-struct:]
                     [lambda: λ:]
@ -52,6 +53,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
         (rename-in racket/contract/base [-> c->] [case-> c:case->])
         ;; contracted bindings to replace built-in ones
         (except-in "base-contracted.rkt" initialize-contracted)
+         "top-interaction.rkt"
         "base-types.rkt"
         "base-types-extra.rkt"
         'struct-extraction
@ -316,16 +318,6 @@ This file defines two sorts of primitives. All of them are provided into any mod
                    #:typed-side #f
                    (type->contract-fail typ #'ty)))))])]))

-(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)]))
-(define-syntax :type fail)
-(define-syntax :print-type fail)
-(define-syntax :query-type/args fail)
-(define-syntax :query-type/result fail)
-
 (define-syntax (require/opaque-type stx)
  (define-syntax-class name-exists-kw
    (pattern #:name-exists))
--- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/top-interaction.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/top-interaction.rkt
@ -0,0 +1,117 @@
+#lang racket/base
+
+(require
+  "../utils/utils.rkt"
+  (for-syntax
+    racket/base
+    racket/match
+    racket/format
+    racket/string
+    racket/list
+    syntax/stx
+    syntax/parse
+    "../tc-setup.rkt"
+    (private parse-type syntax-properties)
+    (types utils abbrev printer)
+    (typecheck tc-toplevel tc-app-helper)
+    (rep type-rep)
+    (utils tc-utils)))
+(provide
+  (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
+    (λ (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 '())])
+           (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)]))))
+
+;; TODO what should be done with stx
+;; Prints the _entire_ type. May be quite large.
+(define-syntax :print-type
+  (interactive-command
+    (λ (stx init)
+      (syntax-parse stx
+        [(_ e)
+         (tc-setup #'stx #'e 'top-level expanded init tc-toplevel-form before type
+                   #`(display
+                      #,(parameterize ([print-multi-line-case-> #t])
+                          (format "~a\n" (match type
+                                           [(tc-result1: t f o) t]
+                                           [(tc-results: t) (-values t)]
+                                           [(tc-any-results:) ManyUniv])))))]
+        [form
+         (raise-syntax-error #f "must be applied to exactly one argument" #'form)]))))
+
+;; given a function and input types, display the result type
+(define-syntax :query-type/args
+  (interactive-command
+    (λ (stx init)
+      (syntax-parse stx
+        [(_ op arg-type ...)
+         (with-syntax ([(dummy-arg ...) (generate-temporaries #'(arg-type ...))])
+            (tc-setup #'stx
+                      ;; create a dummy function with the right argument types
+                      #`(lambda #,(stx-map type-label-property
+                                           #'(dummy-arg ...) #'(arg-type ...))
+                          (op dummy-arg ...))
+                      'top-level expanded init tc-toplevel-form before type
+                      #`(display
+                         #,(format "~a\n"
+                                   (match type
+                                     [(tc-result1: (and t (Function: _)) f o) t])))))]
+        [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-syntax :query-type/result
+  (interactive-command
+    (λ (stx init)
+      (syntax-parse stx
+        [(_ op desired-type)
+         (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."]
+                                 [(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)]))))
--- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/core.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/core.rkt
@ -3,15 +3,13 @@
 (require (rename-in "utils/utils.rkt")
         (for-syntax racket/base)
         (for-template racket/base)
-         (private with-types type-contract parse-type syntax-properties)
+         (private with-types type-contract)
         (except-in syntax/parse id)
-         racket/match racket/syntax racket/list syntax/stx
-         racket/format
-         (only-in racket/string string-join)
-         (types utils abbrev generalize printer)
+         racket/match racket/syntax
+         (types utils abbrev generalize)
         (typecheck provide-handling tc-toplevel tc-app-helper)
         (rep type-rep)
-         (for-template (only-in (base-env prims) :type :print-type :query-type/args :query-type/result))
+         (for-template (base-env top-interaction))
         (utils utils tc-utils arm)
         "tc-setup.rkt")

@ -53,69 +51,8 @@
  (syntax-parse stx
    [(_ . ((~datum module) . rest))
     #'(module . rest)]
-    [(_ . ((~literal :type)
-           (~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 '())])
-       (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)))]
-    [(_ . (~and form ((~literal :type) . _)))
-     (raise-syntax-error #f "must be applied to exactly one argument" #'form)]
-    ;; Prints the _entire_ type. May be quite large.
-    [(_ . ((~literal :print-type) e))
-     (tc-setup #'stx #'e 'top-level expanded init tc-toplevel-form before type
-               #`(display
-                  #,(parameterize ([print-multi-line-case-> #t])
-                      (format "~a\n" (match type
-                                       [(tc-result1: t f o) t]
-                                       [(tc-results: t) (cons 'Values t)]
-                                       [(tc-any-results:) ManyUniv])))))]
-    [(_ . (~and form ((~literal :print-type) . _)))
-     (raise-syntax-error #f "must be applied to exactly one argument" #'form)]
-    ;; given a function and input types, display the result type
-    [(_ . ((~literal :query-type/args) op arg-type ...))
-     (with-syntax ([(dummy-arg ...) (generate-temporaries #'(arg-type ...))])
-       (tc-setup #'stx
-                 ;; create a dummy function with the right argument types
-                 #`(lambda #,(stx-map type-label-property
-                                      #'(dummy-arg ...) #'(arg-type ...))
-                     (op dummy-arg ...))
-                 'top-level expanded init tc-toplevel-form before type
-                 #`(display
-                    #,(format "~a\n"
-                              (match type
-                                [(tc-result1: (and t (Function: _)) f o) t])))))]
-    [(_ . (~and form ((~literal :query-type/args) . _)))
-     (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
-    [(_ . ((~literal :query-type/result) op desired-type))
-     (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."]
-                             [(Function: arrs)
-                              (format "~a\n" cleaned)])))]
-                   [_ (error (format "~a: not a function" (syntax->datum #'op) ))])))]
-    [(_ . (~and form ((~literal :query-type/result) . _)))
-     (raise-syntax-error #f "must be applied to exactly two arguments" #'form)]
+    [(_ . (~and form ((~var command (static interactive-command? #f)) . _)))
+     ((interactive-command-procedure (attribute command.value)) #'form init)]
    [(_ . form)
     (init)
     (tc-setup
--- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/interactive-tests.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/interactive-tests.rkt
@ -43,6 +43,7 @@
               (eval `(#%top-interaction .
                       ,(syntax->datum #'form)) (force promised-ns)))))))]))

+;; Add 'only at the toplevel tests'
 (define (interactive-tests)
  (test-suite "Interactive tests"
    (test-form #rx"1"
@ -51,8 +52,10 @@
      (:type Byte))
    (test-form (regexp-quote "(U 0 1 Byte-Larger-Than-One")
      (:type #:verbose Byte))
-    (test-form-exn #rx"applied to arguments"
+    (test-form-exn #rx":type.*applied to arguments"
      :type)
+    (test-form-exn #rx":type.*only valid at the top-level"
+      (list (:type)))
    (test-form-exn #rx"exactly one argument"
      (:type))
    (test-form-exn #rx"exactly one argument"
@ -60,20 +63,34 @@
    (test-form-exn #rx"exactly one argument"
      (:type #:verbose))

-    (test-form-exn #rx"applied to arguments"
+    (test-form #rx"Positive-Index"
+      (:print-type (+ 1 1)))
+    (test-form (regexp-quote "(values One One)")
+      (:print-type (values 1 1)))
+    (test-form-exn #rx":print-type.*applied to arguments"
      :print-type)
+    (test-form-exn #rx":print-type.*only valid at the top-level"
+      (list (:print-type)))
    (test-form-exn #rx"exactly one argument"
      (:print-type))
    (test-form-exn #rx"exactly one argument"
      (:print-type 1 2))

-    (test-form-exn #rx"applied to arguments"
+    (test-form (regexp-quote "(4 Zero -> Zero)")
+      (:query-type/args * 4 0))
+    (test-form-exn #rx":query-type/args.*applied to arguments"
      :query-type/args)
+    (test-form-exn #rx":query-type/args.*only valid at the top-level"
+      (list (:query-type/args)))
    (test-form-exn #rx"at least one argument"
      (:query-type/args))

-    (test-form-exn #rx"applied to arguments"
+    (test-form (regexp-quote "(case-> (One -> One) (-> One))")
+      (:query-type/result * 1))
+    (test-form-exn #rx":query-type/result.*applied to arguments"
      :query-type/result)
+    (test-form-exn #rx":query-type/result.*only valid at the top-level"
+      (list (:query-type/result)))
    (test-form-exn #rx"exactly two arguments"
      (:query-type/result))
    (test-form-exn #rx"exactly two arguments"