From 27d3042ad6008432428368bda882987f1f8a23c1 Mon Sep 17 00:00:00 2001
From: Asumu Takikawa <asumu@ccs.neu.edu>
Date: Tue, 8 Jan 2013 16:15:12 -0500
Subject: [PATCH] Use correct contract for Procedure type

The only problem with this contract is that it does
not produce a very good error message
---
 .../tests/typed-racket/fail/procedure-top.rkt | 23 +++++++++++++++++++
 .../typed-racket/succeed/procedure-top.rkt    | 21 +++++++++++++++++
 .../typed-racket/private/type-contract.rkt    |  2 +-
 3 files changed, 45 insertions(+), 1 deletion(-)
 create mode 100644 collects/tests/typed-racket/fail/procedure-top.rkt
 create mode 100644 collects/tests/typed-racket/succeed/procedure-top.rkt

diff --git a/collects/tests/typed-racket/fail/procedure-top.rkt b/collects/tests/typed-racket/fail/procedure-top.rkt
new file mode 100644
index 0000000000..645af28bb9
--- /dev/null
+++ b/collects/tests/typed-racket/fail/procedure-top.rkt
@@ -0,0 +1,23 @@
+#;
+(exn-pred exn:fail:contract:arity?)
+#lang racket/load
+
+;; fail version
+
+(module example typed/racket
+  ;; coerces into unapplicable function
+  (: id (Procedure -> Procedure))
+  (define (id x) x)
+
+  (: f (Integer -> Integer))
+  (define (f x) (+ x 1))
+
+  (define g (id f))
+
+  ;; contract here should make sure g is not applicable
+  (provide g))
+
+(require 'example)
+
+;; g should now be unapplicable via case-> contract
+(g 3)
diff --git a/collects/tests/typed-racket/succeed/procedure-top.rkt b/collects/tests/typed-racket/succeed/procedure-top.rkt
new file mode 100644
index 0000000000..338bccc23e
--- /dev/null
+++ b/collects/tests/typed-racket/succeed/procedure-top.rkt
@@ -0,0 +1,21 @@
+#lang racket
+
+;; succeed version
+
+(module example typed/racket
+  ;; coerces into unapplicable function
+  (: id (Procedure -> Procedure))
+  (define (id x) x)
+
+  (: f (Integer -> Integer))
+  (define (f x) (+ x 1))
+
+  (define g (id f))
+
+  ;; contract here should allow application
+  (provide id))
+
+(require 'example)
+
+;; id's argument is procedure?, result is (case->)
+(id +)
diff --git a/collects/typed-racket/private/type-contract.rkt b/collects/typed-racket/private/type-contract.rkt
index 383e3af746..9f08758792 100644
--- a/collects/typed-racket/private/type-contract.rkt
+++ b/collects/typed-racket/private/type-contract.rkt
@@ -129,7 +129,7 @@
         (loop t (not pos?) (not from-typed?) structs-seen kind))
       (define (t->c/fun f #:method [method? #f])
         (match f
-          [(Function: (list (top-arr:))) #'procedure?]
+          [(Function: (list (top-arr:))) (if pos? #'(case->) #'procedure?)]
           [(Function: arrs)
            (set-chaperone!)
            ;; Try to generate a single `->*' contract if possible.