From 8e2a45002d69845766454b0146d436b46451fde5 Mon Sep 17 00:00:00 2001
From: Asumu Takikawa <asumu@ccs.neu.edu>
Date: Fri, 18 Apr 2014 11:14:30 -0400
Subject: [PATCH] Fix `typecheck-fail` in TR

Closes PR 14449

original commit: 9e7b013a7d61dabe48785377f2e5f39f04def90b
---
 .../typed-racket/typecheck/internal-forms.rkt         | 11 ++++++++---
 .../tests/typed-racket/unit-tests/typecheck-tests.rkt |  6 ++++++
 2 files changed, 14 insertions(+), 3 deletions(-)

diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/internal-forms.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/internal-forms.rkt
index 80461e4e..a11abf7d 100644
--- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/internal-forms.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/internal-forms.rkt
@@ -113,9 +113,14 @@
   [predicate-assertion
     (assert-predicate-internal type predicate)]
   [type-declaration
-    (:-internal id:identifier type)]
-  [typecheck-failure
-    (typecheck-fail-internal stx message:str var:id)])
+    (:-internal id:identifier type)])
+
+;; Define separately outside of `define-internal-classes` since this form
+;; is meant to appear in expression positions, so it doesn't make sense to use
+;; the `define-values` protocol used for other internal forms.
+(define-syntax-class typecheck-failure
+  #:literal-sets (kernel-literals internal-literals)
+  (pattern (quote-syntax (typecheck-fail-internal stx message:str var))))
 
 ;;; Internal form creation
 (begin-for-syntax
diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/typecheck-tests.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/typecheck-tests.rkt
index 1f81f11c..9e7427b5 100644
--- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/typecheck-tests.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/typecheck-tests.rkt
@@ -2747,6 +2747,12 @@
            (f 1 2 3))
          #:ret (ret Univ -true-filter)]
 
+       ;; typecheck-fail should fail
+       [tc-err (typecheck-fail #'stx "typecheck-fail")
+               #:msg #rx"typecheck-fail"]
+       [tc-err (string-append (typecheck-fail #'stx "typecheck-fail") "bar")
+               #:ret (ret -String)
+               #:msg #rx"typecheck-fail"]
         )
   (test-suite
    "tc-literal tests"