6 files changed, 76 insertions, 13 deletions

diff --git a/testsuite/tests/th/TH_repPatSig.hs b/testsuite/tests/th/TH_repPatSig.hs
index 3f504ff372..47aee26e13 100644
--- a/testsuite/tests/th/TH_repPatSig.hs
+++ b/testsuite/tests/th/TH_repPatSig.hs
@@ -1,17 +1,17 @@
 {-# LANGUAGE ScopedTypeVariables #-}
--- test the representation of unboxed literals
 
 module Main
 where
 
-import Language.Haskell.TH
+import TH_repPatSig_asserts
 
-$(
-  [d|
-     foo :: Int -> Int
-     foo (x :: Int) = x
-   |]
- )
+assertFoo [d| foo :: Int -> Int
+              foo (x :: Int) = x
+            |]
+
+assertCon [| \(x :: Either Char Int -> (Char, Int)) -> x |]
+
+assertVar [| \(x :: Maybe a) -> case x of Just y -> (y :: a) |]
 
 main :: IO ()
 main = return ()
diff --git a/testsuite/tests/th/TH_repPatSig.stderr b/testsuite/tests/th/TH_repPatSig.stderr
deleted file mode 100644
index 7269068d7d..0000000000
--- a/testsuite/tests/th/TH_repPatSig.stderr
+++ /dev/null
@@ -1,4 +0,0 @@
-
-TH_repPatSig.hs:10:3:
-    Type signatures in patterns not (yet) handled by Template Haskell
-      x :: Int
diff --git a/testsuite/tests/th/TH_repPatSigTVar.hs b/testsuite/tests/th/TH_repPatSigTVar.hs
new file mode 100644
index 0000000000..53f896bc19
--- /dev/null
+++ b/testsuite/tests/th/TH_repPatSigTVar.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Main
+where
+
+import Language.Haskell.TH
+
+$([d| f = \(_ :: Either a b) -> $(sigE (varE 'undefined) (varT ''c)) |])
+
+main :: IO ()
+main = return ()
diff --git a/testsuite/tests/th/TH_repPatSigTVar.stderr b/testsuite/tests/th/TH_repPatSigTVar.stderr
new file mode 100644
index 0000000000..fb02dd9fb8
--- /dev/null
+++ b/testsuite/tests/th/TH_repPatSigTVar.stderr
@@ -0,0 +1,8 @@
+
+TH_repPatSigTVar.hs:8:64: error:
+    • Not in scope: type variable ‘c’
+    • In the Template Haskell quotation ''c
+      In the untyped splice: $(sigE (varE 'undefined) (varT ''c))
+      In the Template Haskell quotation
+        [d| f = \ (_ :: Either a b)
+                  -> $(sigE (varE 'undefined) (varT ''c)) |]
diff --git a/testsuite/tests/th/TH_repPatSig_asserts.hs b/testsuite/tests/th/TH_repPatSig_asserts.hs
new file mode 100644
index 0000000000..42ade65ab4
--- /dev/null
+++ b/testsuite/tests/th/TH_repPatSig_asserts.hs
@@ -0,0 +1,44 @@
+module TH_repPatSig_asserts where
+
+import Language.Haskell.TH
+
+assertFoo :: Q [Dec] -> Q [Dec]
+assertFoo decsQ = do
+  decs <- decsQ
+  case decs of
+    [ SigD _ (AppT (AppT ArrowT (ConT t1)) (ConT t2)),
+      FunD _ [Clause [SigP (VarP _) (ConT t3)] (NormalB (VarE _)) []] ]
+      | t1 == ''Int && t2 == ''Int && t3 == ''Int -> return []
+    _  -> do reportError $ "Unexpected quote contents: " ++ show decs
+             return []
+
+assertCon :: Q Exp -> Q [Dec]
+assertCon expQ = do
+  exp <- expQ
+  case exp of
+    LamE [SigP (VarP _) (AppT (AppT ArrowT (AppT (AppT (ConT eitherT)
+                                                       (ConT charT1))
+                                                 (ConT intT1)))
+                              (AppT (AppT (TupleT 2) (ConT charT2))
+                                    (ConT intT2)))]
+         (VarE _)
+      | eitherT == ''Either &&
+        charT1 == ''Char &&
+        charT2 == ''Char &&
+        intT1 == ''Int &&
+        intT2 == ''Int -> return []
+    _ -> do reportError $ "Unexpected quote contents: " ++ show exp
+            return []
+
+assertVar :: Q Exp -> Q [Dec]
+assertVar expQ = do
+  exp <- expQ
+  case exp of
+    LamE [SigP (VarP x) (AppT (ConT _) (VarT a))]
+         (CaseE (VarE x1) [Match (ConP _ [VarP y])
+                                 (NormalB (SigE (VarE y1) (VarT a1))) []])
+      | x1 == x &&
+        y1 == y &&
+        a1 == a -> return []
+    _ -> do reportError $ "Unexpected quote contents: " ++ show exp
+            return []
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index 4f21121f9a..e0a97fa286 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -24,7 +24,11 @@ test('TH_repPrimOutput', normal, compile_and_run, [''])
 test('TH_repPrimOutput2', normal, compile_and_run, [''])
 test('TH_repGuard', normal, compile, ['-v0'])
 test('TH_repGuardOutput', normal, compile_and_run, [''])
-test('TH_repPatSig', normal, compile_fail, [''])
+test('TH_repPatSig',
+     extra_clean(['TH_repPatSig_asserts.hi', 'TH_repPatSig_asserts.o']),
+     multimod_compile,
+     ['TH_repPatSig.hs', '-v0 ' + config.ghc_th_way_flags])
+test('TH_repPatSigTVar', normal, compile_fail, ['-v0'])
 
 test('TH_overlaps', normal, compile, ['-v0'])