From 806c02c5335a5de76d0f1b30bdb1f10ffb6b2767 Mon Sep 17 00:00:00 2001
From: Vincent St-Amour <stamourv@racket-lang.org>
Date: Tue, 7 Aug 2012 16:11:17 -0400
Subject: [PATCH] Add :query-type/args.

Shows return type for a given function with given argument types.

original commit: 674c71103b65d5ac8467433def7c4542e01985a3
---
 collects/typed-racket/base-env/prims.rkt          |  2 ++
 collects/typed-racket/core.rkt                    | 15 ++++++++++++++-
 .../scribblings/reference/exploring-types.scrbl   |  3 +++
 3 files changed, 19 insertions(+), 1 deletion(-)

diff --git a/collects/typed-racket/base-env/prims.rkt b/collects/typed-racket/base-env/prims.rkt
index cd2064d9..f7e6e339 100644
--- a/collects/typed-racket/base-env/prims.rkt
+++ b/collects/typed-racket/base-env/prims.rkt
@@ -200,6 +200,8 @@ This file defines two sorts of primitives. All of them are provided into any mod
   (error ":type is only valid at the top-level of an interaction"))
 (define-syntax (:print-type stx)
   (error ":print-type is only valid at the top-level of an interaction"))
+(define-syntax (:query-type/args stx)
+  (error ":query-type/args is only valid at the top-level of an interaction"))
 (define-syntax (:query-type/result stx)
   (error ":query-type/result is only valid at the top-level of an interaction"))
 
diff --git a/collects/typed-racket/core.rkt b/collects/typed-racket/core.rkt
index d7186da1..5fc7a707 100644
--- a/collects/typed-racket/core.rkt
+++ b/collects/typed-racket/core.rkt
@@ -5,7 +5,7 @@
          (for-template racket/base)
          (private with-types type-contract parse-type)
          (except-in syntax/parse id)
-         racket/match racket/syntax unstable/match racket/list
+         racket/match racket/syntax unstable/match racket/list syntax/stx
          (types utils abbrev generalize)
          (typecheck provide-handling tc-toplevel tc-app-helper)
          (rep type-rep)
@@ -61,6 +61,19 @@
                                       (match type
                                         [(tc-result1: t f o) t]
                                         [(tc-results: t) (cons 'Values t)])))))]
+    ;; given a function and input types, display the result type
+    [(_ . ((~literal :query-type/args) op:expr arg-type:expr ...))
+     (with-syntax ([(dummy-arg ...) (generate-temporaries #'(arg-type ...))])
+       #`(display #,(tc-setup #'stx
+                              ;; create a dummy function with the right argument types
+                              #`(lambda #,(stx-map (lambda (a t)
+                                                     (syntax-property a 'type-label t))
+                                                   #'(dummy-arg ...) #'(arg-type ...))
+                                  (op dummy-arg ...))
+                              'top-level expanded init tc-toplevel-form before type
+                              (format "~a\n"
+                                      (match type
+                                        [(tc-result1: (and t (Function: _)) f o) t])))))]
     ;; given a function and a desired return type, fill in the blanks
     [(_ . ((~literal :query-type/result) op:expr desired-type:expr))
      (let ([expected (parse-type #'desired-type)])
diff --git a/collects/typed-racket/scribblings/reference/exploring-types.scrbl b/collects/typed-racket/scribblings/reference/exploring-types.scrbl
index 5cf6f709..2204cece 100644
--- a/collects/typed-racket/scribblings/reference/exploring-types.scrbl
+++ b/collects/typed-racket/scribblings/reference/exploring-types.scrbl
@@ -14,6 +14,9 @@ The following bindings are only available at the Typed Racket REPL.
 @defform[(:print-type e)]{Prints the type of @racket[_e]. This prints the whole
 type, which can sometimes be quite large.}
 
+@defform[(:query-type/args f t ...)]{Given a function @racket[f] and argument
+types @racket[t], shows the result type of @racket[f].}
+
 @defform[(:query-type/result f t)]{Given a function @racket[f] and a desired
 return type @racket[t], shows the arguments types @racket[f] should be given to
 return a value of type @racket[t].}